blk/001

@@ -2,8 +2,6 @@ MASTER INDEX
 
   3 Usage                      30 Dictionary
  70 Implementation notes      100 Block editor
-120 Linker                    140 Addressed devices
-150 AT28 Driver
 200 Z80 assembler             260 Cross compilation
 280 Z80 boot code             350 ACIA driver
 370 SD Card driver            390 Inner core
@@ -15,3 +13,4 @@ MASTER INDEX
 
 
 
+

blk/120

@@ -1,16 +0,0 @@
-Linker
-
-Relink a dictionary by applying offsets to all word references
-in words of the "compiled" type.
-
-A typical usage of this unit would be to, right after a
-bootstrap-from-icore-from-source operation, identify the root
-word of the source part, probably "H@", and run " ' thatword
-RLDICT ". Then, take the resulting relinked binary, concatenate
-it to the boot binary, and write to boot media.
-
-LIMITATIONS
-
-This unit can't automatically detect all offsets needing
-relinking. This is a list of situations that aren't handled:
-                                                        (cont.)

blk/121

@@ -1,8 +0,0 @@
-Cells: It's not possible to know for sure whether a cellWord
-contains an address or a number. They are therefore not
-automatically relinked. You have to manually relink each of
-them with RLCELL. In the case of a DOES> word, PFA+2, which
-is always an offset, is automatically relinked, but not
-PFA+0.
-
-Load with "122 LOAD"

blk/122

@@ -1 +0,0 @@
-123 132 LOADR

blk/123

@@ -1,15 +0,0 @@
-( Skip atom, considering special atom types. )
-: ASKIP ( a -- a+n )
-    DUP @       ( a n )
-    ( ?br or br or NUMBER )
-    DUP <>{ 0x67 &= 0x53 |= 0x20 |= 0x24 |= <>}
-    IF DROP 4 + EXIT THEN
-    ( regular word )
-    0x22 = NOT IF 2+ EXIT THEN
-    ( it's a lit, skip to null char )
-    ( a )
-    1+  ( we skip by 2, but the loop below is pre-inc... )
-    BEGIN 1+ DUP C@ NOT UNTIL
-    ( skip null char )
-    1+
-;

blk/124

@@ -1,11 +0,0 @@
-( RLATOM pre-comment
-
-  Relink atom at a, applying offset o with limit ol.
-  Returns a, appropriately skipped.
-
-  0x24 = IF: 0x24 is an addrWord, which should be offsetted in
-  the same way that a regular word would. To achieve this, we
-  skip ASKIP and instead of skipping 4 bytes like a numberWord,
-  we skip only 2, which means that our number will be treated
-  like a regular wordref. )
-

blk/125

@@ -1,16 +0,0 @@
-: RLATOM ( a o ol -- a+n )
-    ROT             ( o ol a )
-    DUP @           ( o ol a n )
-    DUP 0x24 = IF
-        DROP 2+     ( o ol a+2 )
-        ROT ROT 2DROP ( a ) EXIT
-    THEN
-    ROT             ( o a n ol )
-    < IF  ( under limit, do nothing )
-        SWAP DROP    ( a )
-    ELSE ( o a )
-        SWAP OVER @  ( a o n )
-        -^           ( a n-o )
-        OVER !       ( a )
-    THEN
-    ASKIP ;

blk/126

@@ -1,15 +0,0 @@
-( RLWORD pre-comment
-
-  Relink a word with specified offset. If it's not of the type
-  "compiled word", ignore. If it is, advance in word until a2
-  is met, and for each word that is above ol, reduce that
-  reference by o.
-  Arguments: a1: wordref a2: word end addr o: offset to apply
-             ol: offset limit. don't apply on refs under it.
-
-  The 0x0e and 0x2b check at the beginning is to ensure we have
-  either a compiledWord or a doesWord. If we don't, we do
-  nothing. The further 0x2b check is because if we have a
-  doesWord, we start 2 bytes later.
-)
-

blk/127

@@ -1,16 +0,0 @@
-: RLWORD ( ol o a1 a2 -- )
-    SWAP DUP C@             ( ol o a2 a1 n )
-    DUP <>{ 0x0e &= 0x2b |= <>} NOT IF ( unwind all args )
-        2DROP 2DROP EXIT THEN
-    0x2b = IF 2+ THEN ( ol o a2 a1 )
-    1+                          ( ol o a2 a1+1 )
-    BEGIN                       ( ol o a2 a1 )
-        2OVER SWAP              ( ol o a2 a1 o ol )
-        RLATOM                  ( ol o a2 a+n )
-        2DUP < IF ABORT THEN    ( Something is very wrong )
-        2DUP =                  ( ol o a2 a+n f )
-        IF ( unwind )
-            2DROP 2DROP EXIT
-        THEN
-    AGAIN
-;

blk/128

@@ -1,16 +0,0 @@
-( RLDICT pre-comment: Copy dict from target wordref, including
-header, up to HERE.  We're going relocate those words by
-specified offset. To do this, we're copying this whole memory
-area in HERE and then iterate through that copied area and call
-RLWORD on each word. That results in a dict that can be
-concatenated to target's prev entry in a more compact way.
-
-  This copy of data doesn't allocate anything, so H@ doesn't
-move. Moreover, we reserve 4 bytes at H@ to write our target
-and offset because otherwise, things get too complicated with
-the PSP.
-
-  The output of this word is 3 numbers: top copied address, top
-copied CURRENT, and then the beginning of the copied dict at
-the end to indicate that we're finished processing.
-                                                        cont. )

blk/130

@@ -1,16 +0,0 @@
-( Note that the last word is always skipped because it's not
-possible to reliably detect its end. If you need that last
-word, define a dummy word before calling RLDICT.
-
-We first start by copying the affected area to H@+4. This is
-where the relinking will take place.
-
-Then we iterate the new dict from the top, keeping track of
-wr, the current wordref and we, wr's end offset.
-
-Initially, we get our wr and we, withH@ and CURRENT, which we
-offset by u+4. +4 before, remember, we're using 4 bytes
-as variable space.
-
-At each iteration, we becomes wr-header and wr is fetched from
-PREV field. )

blk/131

@@ -1,16 +0,0 @@
-: RLDICT ( target offset -- )
-    H@ 2+ ! H@ ! ( H@+2 == offset, H@ == target )
-    H@ @ WORD( DUP H@ -^        ( src u )
-    DUP ROT SWAP H@ 4 +         ( u src u dst )
-    SWAP MOVE                   ( u )
-    4 + DUP CURRENT @ WORD( +   ( u we )
-    DUP .X CRLF
-    SWAP CURRENT @ PREV + DUP .X CRLF ( we wr )
-    BEGIN                       ( we wr )
-        DUP ROT                 ( wr wr we )
-        H@ @ H@ 2+ @            ( wr wr we ol o )
-        2SWAP RLWORD            ( wr )
-        DUP PREV SWAP           ( wr oldwr )
-        WORD( SWAP              ( we wr )
-        DUP 4 - H@ <= ( are we finished? )
-    UNTIL H@ 4 + .X CRLF ;

blk/132

@@ -1,9 +0,0 @@
-( Relink a regular Forth full interpreter. )
-: RLCORE
-    LIT< H@ (find) DROP         ( target )
-    DUP 3 - @                   ( t prevoff )
-    ( subtract H@ name length )
-    2-                          ( t o )
-    RLDICT
-;
-

blk/140

@@ -1,10 +0,0 @@
-Addressed devices
-
-Abstractions to read and write to devices that allow addressed
-access. At all times, we have one active "fetch" device and
-one active "store" device, A@ and A!.
-
-Those words have the same signature as C@ and C!, and in fact,
-initially default to proxy of those words.
-
-Load with "142 LOAD"

blk/142

@@ -1 +0,0 @@
-143 144 LOADR

blk/143

@@ -1,15 +0,0 @@
-: ADEVMEM+ 0x55 RAM+ @ + ;
-: A@* 0 ADEVMEM+ ;
-: A!* 2 ADEVMEM+ ;
-
-: ADEV$
-    H@ 0x55 RAM+ !
-    4 ALLOT
-    ['] C@ A@* !
-    ['] C! A!* !
-;
-
-: A@ A@* @ EXECUTE ;
-: A! A!* @ EXECUTE ;
-
-

blk/144

@@ -1,11 +0,0 @@
-( Same as MOVE, but with A@ and A! )
-( src dst u -- )
-: AMOVE
-    ( u ) 0 DO
-        SWAP DUP I + A@   ( dst src x )
-        ROT SWAP OVER I + ( src dst x dst )
-        A!                ( src dst )
-    LOOP
-    2DROP
-;
-

blk/150

@@ -1,6 +0,0 @@
-AT28 Driver
-
-Write to an AT28 EEPROM while making sure that proper timing
-is followed and verify data integrity.
-
-Load with "151 LOAD"

blk/357

@@ -1 +1,14 @@
+0x20 CONSTANT ACIABUFSZ
+
+( Points to ACIA buf )
+: ACIA( [ ACIA_MEM 4 + LITN ] ;
+( Points to ACIA buf end )
+: ACIA) [ ACIA_MEM 6 + LITN ] ;
+( Read buf pointer. Pre-inc )
+: ACIAR> [ ACIA_MEM LITN ] ;
+( Write buf pointer. Post-inc )
+: ACIAW> [ ACIA_MEM 2 + LITN ] ;
+( This means that if W> == R>, buffer is full.
+  If R>+1 == W>, buffer is empty. )
+
 358 360 LOADR

blk/358

@@ -1,13 +1,16 @@
-0x20 CONSTANT ACIABUFSZ
+: ACIA$
-
+    H@ DUP DUP ACIA( ! ACIAR> !
-( Points to ACIA buf )
+    1+ ACIAW> !  ( write index starts one position later )
-: ACIA( [ ACIA_MEM 4 + LITN ] ;
+    ACIABUFSZ ALLOT
-( Points to ACIA buf end )
+    H@ ACIA) !
-: ACIA) [ ACIA_MEM 6 + LITN ] ;
+( setup ACIA
-( Read buf pointer. Pre-inc )
+  CR7 (1) - Receive Interrupt enabled
-: ACIAR> [ ACIA_MEM LITN ] ;
+  CR6:5 (00) - RTS low, transmit interrupt disabled.
-( Write buf pointer. Post-inc )
+  CR4:2 (101) - 8 bits + 1 stop bit
-: ACIAW> [ ACIA_MEM 2 + LITN ] ;
+  CR1:0 (10) - Counter divide: 64 )
-( This means that if W> == R>, buffer is full.
+    0b10010110 ACIA_CTL PC!
-  If R>+1 == W>, buffer is empty. )
+( setup interrupt )
-
+    0xc3 0x4e RAM+ C!  ( c3==JP, 4e==INTJUMP )
+    ['] ~ACIA 0x4f RAM+ !
+    (im1)
+;

blk/359

@@ -1,16 +1,14 @@
-: ACIA$
+: KEY
-    H@ DUP DUP ACIA( ! ACIAR> !
+    ( inc then fetch )
-    1+ ACIAW> !  ( write index starts one position later )
+    ACIAR> @ 1+ DUP ACIA) @ = IF
-    ACIABUFSZ ALLOT
+        DROP ACIA( @
-    H@ ACIA) !
+    THEN
-( setup ACIA
+
-  CR7 (1) - Receive Interrupt enabled
+    ( As long as R> == W>-1, it means that buffer is empty )
-  CR6:5 (00) - RTS low, transmit interrupt disabled.
+    BEGIN DUP ACIAW> @ = NOT UNTIL
-  CR4:2 (101) - 8 bits + 1 stop bit
+
-  CR1:0 (10) - Counter divide: 64 )
+    ACIAR> !
-    0b10010110 ACIA_CTL PC!
+    ACIAR> @ C@
-( setup interrupt )
-    0xc3 0x4e RAM+ C!  ( c3==JP, 4e==INTJUMP )
-    ['] ~ACIA 0x4f RAM+ !
-    (im1)
 ;
+
+

blk/360

@@ -1,16 +1,7 @@
-: KEY
-    ( inc then fetch )
-    ACIAR> @ 1+ DUP ACIA) @ = IF
-        DROP ACIA( @
-    THEN
-    ( As long as R> == W>-1, it means that buffer is empty )
-    BEGIN DUP ACIAW> @ = NOT UNTIL
-    ACIAR> !
-    ACIAR> @ C@
-;
 : EMIT
     ( As long at CTL bit 1 is low, we are transmitting. wait )
     BEGIN ACIA_CTL PC@ 0x02 AND UNTIL
     ( The way is clear, go! )
     ACIA_IO PC!
 ;
+

drv/acia.fs

@@ -0,0 +1,69 @@
+( ACIA
+
+Manage I/O from an asynchronous communication interface adapter
+(ACIA). provides "EMIT" to put c char on the ACIA as well as
+an input buffer. You have to call "~ACIA" on interrupt for
+this module to work well.
+
+CONFIGURATION
+
+ACIA_CTL: IO port for the ACIA's control registers
+ACIA_IO: IO port for the ACIA's data registers
+ACIA_MEM: Address in memory that can be used variables shared
+          with ACIA's native words. 8 bytes used.
+)
+
+0x20 CONSTANT ACIABUFSZ
+
+( Points to ACIA buf )
+: ACIA( [ ACIA_MEM 4 + LITN ] ;
+( Points to ACIA buf end )
+: ACIA) [ ACIA_MEM 6 + LITN ] ;
+( Read buf pointer. Pre-inc )
+: ACIAR> [ ACIA_MEM LITN ] ;
+( Write buf pointer. Post-inc )
+: ACIAW> [ ACIA_MEM 2 + LITN ] ;
+( This means that if W> == R>, buffer is full.
+  If R>+1 == W>, buffer is empty. )
+
+
+: ACIA$
+    H@ DUP DUP ACIA( ! ACIAR> !
+    1+ ACIAW> !  ( write index starts one position later )
+    ACIABUFSZ ALLOT
+    H@ ACIA) !
+( setup ACIA
+  CR7 (1) - Receive Interrupt enabled
+  CR6:5 (00) - RTS low, transmit interrupt disabled.
+  CR4:2 (101) - 8 bits + 1 stop bit
+  CR1:0 (10) - Counter divide: 64
+)
+    0b10010110 ACIA_CTL PC!
+
+( setup interrupt )
+    ( 4e == INTJUMP )
+    0xc3 0x4e RAM+ C!  ( JP upcode )
+    ['] ~ACIA 0x4f RAM+ !
+    (im1)
+;
+
+: KEY
+    ( inc then fetch )
+    ACIAR> @ 1+ DUP ACIA) @ = IF
+        DROP ACIA( @
+    THEN
+
+    ( As long as R> == W>-1, it means that buffer is empty )
+    BEGIN DUP ACIAW> @ = NOT UNTIL
+
+    ACIAR> !
+    ACIAR> @ C@
+;
+
+: EMIT
+    ( As long at CTL bit 1 is low, we are transmitting. wait )
+    BEGIN ACIA_CTL PC@ 0x02 AND UNTIL
+    ( The way is clear, go! )
+    ACIA_IO PC!
+;
+

drv/at28.fs

@@ -1,7 +1,9 @@
 ( With dst being assumed to be an AT28 EEPROM, perform !
   operation while doing the right thing. Checks data integrity
-  and ABORT on mismatch. )
+  and ABORT on mismatch.
-: AT28! ( n a -- )
+)
+( n a -- )
+: AT28!
     2DUP C!
     ( as long as writing operation is running, IO/6 will toggle at each
       read attempt. We know that write is finished when we read the same

drv/sdc.fs

@@ -0,0 +1,215 @@
+( -- n )
+: _idle 0xff _sdcSR ;
+
+( -- n )
+( _sdcSR 0xff until the response is something else than 0xff
+  for a maximum of 20 times. Returns 0xff if no response. )
+: _wait
+    0  ( cnt )
+    BEGIN
+        _idle
+        DUP 0xff = IF DROP ELSE SWAP DROP EXIT THEN
+        1+
+    DUP 20 = UNTIL
+    DROP 0xff
+;
+
+( -- )
+( The opposite of sdcWaitResp: we wait until response is 0xff.
+  After a successful read or write operation, the card will be
+  busy for a while. We need to give it time before interacting
+  with it again. Technically, we could continue processing on
+  our side while the card it busy, and maybe we will one day,
+  but at the moment, I'm having random write errors if I don't
+  do this right after a write, so I prefer to stay cautious
+  for now. )
+: _ready BEGIN _idle 0xff = UNTIL ;
+
+( c n -- c )
+( Computes n into crc c with polynomial 0x09
+  Note that the result is "left aligned", that is, that 8th
+  bit to the "right" is insignificant (will be stop bit). )
+: _crc7
+    XOR           ( c )
+    8 0 DO
+        2 *       ( <<1 )
+        DUP 255 > IF
+            ( MSB was set, apply polynomial )
+            0xff AND
+            0x12 XOR  ( 0x09 << 1, we apply CRC on high bits )
+        THEN
+    LOOP
+;
+
+( c n -- c )
+( Computes n into crc c with polynomial 0x1021 )
+: _crc16
+    SWAP DUP 256 /    ( n c c>>8 )
+    ROT XOR           ( c x )
+    DUP 16 / XOR      ( c x^x>>4 )
+    SWAP 256 *        ( x c<<8 )
+    OVER 4096 * XOR   ( x c^x<<12 )
+    OVER 32 * XOR     ( x c^x<<5 )
+    XOR               ( c )
+;
+
+( send-and-crc7 )
+( n c -- c )
+: _s+crc SWAP DUP _sdcSR DROP _crc7 ;
+
+( cmd arg1 arg2 -- resp )
+( Sends a command to the SD card, along with arguments and
+  specified CRC fields. (CRC is only needed in initial commands
+  though).
+  This does *not* handle CS. You have to select/deselect the
+  card outside this routine. )
+: _cmd
+    _wait DROP
+    ROT            ( a1 a2 cmd )
+    0 _s+crc       ( a1 a2 crc )
+    ROT 256 /MOD   ( a2 crc h l )
+    ROT            ( a2 h l crc )
+    _s+crc         ( a2 h crc )
+    _s+crc         ( a2 crc )
+    SWAP 256 /MOD  ( crc h l )
+    ROT            ( h l crc )
+    _s+crc         ( h crc )
+    _s+crc         ( crc )
+    ( send CRC )
+    0x01 OR        ( ensure stop bit )
+    _sdcSR DROP
+    ( And now we just have to wait for a valid response... )
+    _wait
+;
+
+( cmd arg1 arg2 -- r )
+( Send a command that expects a R1 response, handling CS. )
+: SDCMDR1 _sdcSel _cmd _sdcDesel ;
+
+( cmd arg1 arg2 -- r arg1 arg2 )
+( Send a command that expects a R7 response, handling CS. A R7
+  is a R1 followed by 4 bytes. arg1 contains bytes 0:1, arg2
+  has 2:3 )
+: SDCMDR7
+    _sdcSel
+    _cmd        ( r )
+    _idle 256 * ( r h )
+    _idle +     ( r arg1 )
+    _idle 256 * ( r arg1 h )
+    _idle +     ( r arg1 arg2 )
+    _sdcDesel
+;
+
+: _err _sdcDesel ABORT" SDerr" ;
+
+( Initialize a SD card. This should be called at least 1ms
+  after the powering up of the card. )
+: SDC$
+    ( Wake the SD card up. After power up, a SD card has to
+      receive at least 74 dummy clocks with CS and DI high. We
+      send 80. )
+    10 0 DO _idle DROP LOOP
+
+    ( call cmd0 and expect a 0x01 response (card idle)
+	  this should be called multiple times. we're actually
+      expected to. let's call this for a maximum of 10 times. )
+    0  ( dummy )
+    10 0 DO  ( r )
+        DROP
+        0b01000000 0 0  ( CMD0 )
+        SDCMDR1
+        DUP 0x01 = IF LEAVE THEN
+    LOOP
+    0x01 = NOT IF _err THEN
+
+    ( Then comes the CMD8. We send it with a 0x01aa argument
+      and expect a 0x01aa argument back, along with a 0x01 R1
+      response. )
+    0b01001000 0 0x1aa  ( CMD8 )
+    SDCMDR7                     ( r arg1 arg2 )
+    0x1aa = NOT IF _err THEN    ( arg2 check )
+    0 = NOT IF _err THEN        ( arg1 check )
+    0x01 = NOT IF _err THEN     ( r check )
+
+    ( Now we need to repeatedly run CMD55+CMD41 (0x40000000)
+      until the card goes out of idle mode, that is, when
+      it stops sending us 0x01 response and send us 0x00
+      instead. Any other response means that initialization
+      failed. )
+    BEGIN
+        0b01110111 0 0  ( CMD55 )
+        SDCMDR1
+        0x01 = NOT IF _err THEN
+        0b01101001 0x4000 0x0000  ( CMD41 )
+        SDCMDR1
+        DUP 0x01 > IF _err THEN
+    NOT UNTIL
+    ( Out of idle mode! Success! )
+;
+
+( dstaddr blkno -- )
+: _sdc@
+    _sdcSel
+    0x51    ( CMD17 )
+    0 ROT   ( a cmd 0 blkno )
+    _cmd
+    IF _err THEN
+    _wait
+    0xfe = NOT IF _err THEN
+    0 SWAP           ( crc a )
+    512 0 DO         ( crc a )
+        DUP          ( crc a a )
+        _idle        ( crc a a n )
+        DUP ROT      ( crc a n n a )
+        C!           ( crc a n )
+        ROT SWAP     ( a crc n )
+        _crc16       ( a crc )
+        SWAP 1+      ( crc a+1 )
+    LOOP
+    DROP             ( crc1 )
+    _idle 256 *
+    _idle +          ( crc2 )
+    _wait DROP
+    _sdcDesel
+    = NOT IF _err THEN
+;
+
+: SDC@
+    2 * DUP BLK( SWAP    ( b a b )
+    _sdc@
+    1+ BLK( 512 + SWAP
+    _sdc@
+;
+
+( srcaddr blkno -- )
+: _sdc!
+    _sdcSel
+    0x58    ( CMD24 )
+    0 ROT   ( a cmd 0 blkno )
+    _cmd
+    IF _err THEN
+    _idle DROP
+    0xfe _sdcSR DROP
+    0 SWAP           ( crc a )
+    512 0 DO         ( crc a )
+        C@+          ( crc a+1 n )
+        ROT OVER     ( a n crc n )
+        _crc16       ( a n crc )
+        SWAP         ( a crc n )
+        _sdcSR DROP  ( a crc )
+        SWAP         ( crc a )
+    LOOP
+    DROP             ( crc )
+    256 /MOD         ( lsb msb )
+    _sdcSR DROP      ( lsb )
+    _sdcSR DROP
+    _wait DROP
+    _sdcDesel
+;
+
+: SDC!
+    2 * DUP BLK( SWAP    ( b a b )
+    _sdc!
+    1+ BLK( 512 + SWAP
+    _sdc!
+;

emul/.gitignore

@@ -3,5 +3,6 @@
 /stage2
 /forth
 /*-bin.h
-/stage1.bin
+/core.bin
+/forth?.bin
 /blkfs

forth/README.md

@@ -0,0 +1,7 @@
+# Forth
+
+**WIP** A Forth interpreter. Far from complete, but you can do stuff like
+
+    KEY EMIT KEY EMIT
+
+See dictionary.txt for a word reference.

forth/adev.fs

@@ -0,0 +1,34 @@
+( Addressed devices.
+
+Abstractions to read and write to devices that allow addressed
+access. At all times, we have one active "fetch" device and
+one active "store" device, A@ and A!.
+
+Those words have the same signature as C@ and C!, and in fact,
+initially default to proxy of those words.
+)
+
+: ADEVMEM+ 0x55 RAM+ @ + ;
+: A@* 0 ADEVMEM+ ;
+: A!* 2 ADEVMEM+ ;
+
+: ADEV$
+    H@ 0x55 RAM+ !
+    4 ALLOT
+    ['] C@ A@* !
+    ['] C! A!* !
+;
+
+: A@ A@* @ EXECUTE ;
+: A! A!* @ EXECUTE ;
+
+( Same as MOVE, but with A@ and A! )
+( src dst u -- )
+: AMOVE
+    ( u ) 0 DO
+        SWAP DUP I + A@   ( dst src x )
+        ROT SWAP OVER I + ( src dst x dst )
+        A!                ( src dst )
+    LOOP
+    2DROP
+;

forth/blk.fs

@@ -0,0 +1,95 @@
+( I/O blocks )
+
+: BLKMEM+ 0x57 RAM+ @ + ;
+( n -- Fetches block n and write it to BLK( )
+: BLK@* 0 BLKMEM+ ;
+( n -- Write back BLK( to storage at block n )
+: BLK!* 2 BLKMEM+ ;
+( Current blk pointer in ( )
+: BLK> 4 BLKMEM+ ;
+( Whether buffer is dirty )
+: BLKDTY 6 BLKMEM+ ;
+: BLK( 8 BLKMEM+ ;
+
+: BLK$
+    H@ 0x57 RAM+ !
+    ( 1024 for the block, 8 for variables )
+    1032 ALLOT
+    ( LOAD detects end of block with ASCII EOT. This is why
+      we write it there. EOT == 0x04 )
+    4 C,
+    0 BLKDTY !
+    -1 BLK> !
+;
+
+( -- )
+: BLK!
+    BLK> @ BLK!* @ EXECUTE
+    0 BLKDTY !
+;
+
+( n -- )
+: BLK@
+    DUP BLK> @ = IF DROP EXIT THEN
+    BLKDTY @ IF BLK! THEN
+    DUP BLK> ! BLK@* @ EXECUTE
+;
+
+: BLK!! 1 BLKDTY ! ;
+
+: .2 DUP 10 < IF SPC THEN . ;
+
+: LIST
+    BLK@
+    16 0 DO
+        I 1+ .2 SPC
+        64 I * BLK( + (print)
+        CRLF
+    LOOP
+;
+
+: _
+    (boot<)
+    DUP 4 = IF
+        ( We drop our char, but also "a" from WORD: it won't
+          have the opportunity to balance PSP because we're
+          EXIT!ing. )
+        2DROP
+        ( We're finished interpreting )
+        EXIT!
+    THEN
+;
+
+: LOAD
+    ( save restorable variables to RSP )
+    BLK> @ >R
+    0x08 RAM+ @ >R
+    0x06 RAM+ @ >R  ( C<? )
+    0x2e RAM+ @ >R  ( boot ptr )
+    BLK@
+    ( Point to beginning of BLK )
+    BLK( 0x2e RAM+ !
+    ( 08 == C<* override )
+    ['] _ 0x08 RAM+ !
+    ( While we interpret, don't print "ok" after every word )
+    1 0x06 RAM+ !  ( 06 == C<? )
+    INTERPRET
+    R> 0x2e RAM+ !
+    R> 0x06 RAM+ !
+    ( Before we restore C<* are we restoring it to "_"?
+      if yes, it means we're in a nested LOAD which means we
+      should also load back the saved BLK>. Otherwise, we can
+      ignore the BLK> from RSP. )
+    I 0x08 RAM+ @ = IF
+        ( nested load )
+        R> DROP ( C<* )
+        R> BLK@
+    ELSE
+        ( not nested )
+        R> 0x08 RAM+ !
+        R> DROP ( BLK> )
+    THEN
+;
+
+( b1 b2 -- )
+: LOADR 1+ SWAP DO I DUP . CRLF LOAD LOOP ;

forth/cmp.fs

@@ -0,0 +1,42 @@
+( Words useful for complex comparison operations )
+
+: >= < NOT ;
+: <= > NOT ;
+: 0>= 0< NOT ;
+
+( n1 -- n1 true )
+: <>{ 1 ;
+
+( n1 f -- f )
+: <>} SWAP DROP ;
+
+
+: _|&
+    ( n1 n2 cell )
+    >R >R DUP R> R>          ( n1 n1 n2 cell )
+    @ EXECUTE                ( n1 f )
+;
+
+( n1 f n2 -- n1 f )
+: _|
+    CREATE , DOES>
+    ( n1 f n2 cell )
+    ROT IF 2DROP 1 EXIT THEN ( n1 true )
+    _|&
+;
+
+: _&
+    CREATE , DOES>
+    ( n1 f n2 cell )
+    ROT NOT IF 2DROP 0 EXIT THEN ( n1 true )
+    _|&
+;
+
+( All words below have this signature:
+  n1 f n2 -- n1 f )
+' = _| |=
+' = _& &=
+' > _| |>
+' > _& &>
+' < _| |<
+' < _& &<

forth/core.fs

@@ -0,0 +1,203 @@
+: H@ HERE @ ;
+: IMMEDIATE
+    CURRENT @ 1-
+    DUP C@ 128 OR SWAP C!
+;
+: [ INTERPRET ; IMMEDIATE
+: ] R> DROP ;
+: LITS 34 , SCPY ;
+: LIT< WORD LITS ; IMMEDIATE
+: LITA 36 , , ;
+: '
+    WORD (find) (?br) [ 4 , ] EXIT
+    LIT< (wnf) (find) DROP EXECUTE
+;
+: ['] ' LITA ; IMMEDIATE
+: COMPILE ' LITA ['] , , ; IMMEDIATE
+: [COMPILE] ' , ; IMMEDIATE
+: BEGIN H@ ; IMMEDIATE
+: AGAIN COMPILE (br) H@ - , ; IMMEDIATE
+: UNTIL COMPILE (?br) H@ - , ; IMMEDIATE
+: _ BEGIN LIT< ) WORD S= UNTIL ; IMMEDIATE
+40 CURRENT @ 4 - C!
+( Hello, hello, krkrkrkr... do you hear me?
+  Ah, voice at last! Some lines above need comments
+  BTW: Forth lines limited to 64 cols because of default
+  input buffer size in Collapse OS
+
+  "_": words starting with "_" are meant to be "private",
+  that is, only used by their immediate surrondings.
+
+  40 is ASCII for '('. We do this to simplify XPACK's task of
+  not mistakenly consider '(' definition as a comment.
+  LITS: 34 == litWord
+  LITA: 36 == addrWord
+  COMPILE: Tough one. Get addr of caller word (example above
+  (br)) and then call LITA on it. )
+
+: +! SWAP OVER @ + SWAP ! ;
+: -^ SWAP - ;
+: ALLOT HERE +! ;
+
+: IF                ( -- a | a: br cell addr )
+    COMPILE (?br)
+    H@              ( push a )
+    2 ALLOT         ( br cell allot )
+; IMMEDIATE
+
+: THEN              ( a -- | a: br cell addr )
+    DUP H@ -^ SWAP   ( a-H a )
+    !
+; IMMEDIATE
+
+: ELSE              ( a1 -- a2 | a1: IF cell a2: ELSE cell )
+    COMPILE (br)
+    2 ALLOT
+    DUP H@ -^ SWAP  ( a-H a )
+    !
+    H@ 2-          ( push a. -2 for allot offset )
+; IMMEDIATE
+
+( During a CASE, the stack grows by 1 at each ENDOF so that
+  we can fill all those ENDOF branching addrs. So that we
+  know when to stop, we put a 0 on PSP. That's our stopgap. )
+: CASE 0 COMPILE >R ; IMMEDIATE
+: OF
+    COMPILE I COMPILE =
+    [COMPILE] IF
+; IMMEDIATE
+: ENDOF [COMPILE] ELSE ; IMMEDIATE
+
+( At this point, we have something like "0 e1 e2 e3 val". We
+  want top drop val, and then call THEN as long as we don't
+  hit 0. )
+: ENDCASE
+    BEGIN
+        DUP NOT IF
+            DROP COMPILE R> COMPILE DROP EXIT
+        THEN
+        [COMPILE] THEN
+    AGAIN
+; IMMEDIATE
+
+: CREATE
+    (entry)            ( empty header with name )
+    11                 ( 11 == cellWord )
+    C,                 ( write it )
+;
+
+( We run this when we're in an entry creation context. Many
+  things we need to do.
+  1. Change the code link to doesWord
+  2. Leave 2 bytes for regular cell variable.
+  3. Write down RS' RTOS to entry.
+  4. exit parent definition
+)
+: DOES>
+    ( Overwrite cellWord in CURRENT )
+    ( 43 == doesWord )
+    43 CURRENT @ C!
+    ( When we have a DOES>, we forcefully place HERE to 4
+      bytes after CURRENT. This allows a DOES word to use ","
+      and "C," without messing everything up. )
+    CURRENT @ 3 + HERE !
+    ( HERE points to where we should write R> )
+    R> ,
+    ( We're done. Because we've popped RS, we'll exit parent
+      definition )
+;
+
+: VARIABLE CREATE 2 ALLOT ;
+: CONSTANT CREATE , DOES> @ ;
+: / /MOD SWAP DROP ;
+: MOD /MOD DROP ;
+
+( In addition to pushing H@ this compiles 2 >R so that loop
+  variables are sent to PS at runtime )
+: DO
+    COMPILE SWAP COMPILE >R COMPILE >R
+    H@
+; IMMEDIATE
+
+( Increase loop counter and returns whether we should loop. )
+: _
+    R>          ( IP, keep for later )
+    R> 1+       ( ip i+1 )
+    DUP >R      ( ip i )
+    I' =        ( ip f )
+    SWAP >R     ( f )
+;
+
+( One could think that we should have a sub word to avoid all
+  these COMPILE, but we can't because otherwise it messes with
+  the RS )
+: LOOP
+    COMPILE _ COMPILE (?br)
+    H@ - ,
+    COMPILE R> COMPILE DROP COMPILE R> COMPILE DROP
+; IMMEDIATE
+
+: LEAVE R> R> DROP I 1- >R >R ;
+
+: ROLL
+    DUP NOT IF EXIT THEN
+    1+ DUP PICK          ( n val )
+    SWAP 2 * (roll)      ( val )
+    SWAP DROP
+;
+
+: 2DUP OVER OVER ;
+: 2OVER 3 PICK 3 PICK ;
+: 2SWAP 3 ROLL 3 ROLL ;
+
+( a1 a2 u -- )
+: MOVE
+    ( u ) 0 DO
+        SWAP DUP I + C@   ( a2 a1 x )
+        ROT SWAP OVER I + ( a1 a2 x a2 )
+        C!                ( a1 a2 )
+    LOOP
+    2DROP
+;
+
+: DELW
+    1- 0 SWAP C!
+;
+
+: PREV
+    3 - DUP @                   ( a o )
+    -                           ( a-o )
+;
+
+: WORD(
+    DUP 1- C@   ( name len field )
+    127 AND     ( 0x7f. remove IMMEDIATE flag )
+    3 +         ( fixed header len )
+    -
+;
+
+: FORGET
+    ' DUP               ( w w )
+    ( HERE must be at the end of prev's word, that is, at the
+      beginning of w. )
+    WORD( HERE !  ( w )
+    PREV CURRENT !
+;
+
+: EMPTY
+    LIT< _sys (find) NOT IF ABORT THEN
+    DUP HERE ! CURRENT !
+;
+
+( Drop RSP until I-2 == INTERPRET. )
+: EXIT!
+    ['] INTERPRET       ( I )
+    BEGIN               ( I )
+    DUP                 ( I I )
+    R> DROP I 2- @     ( I I a )
+    = UNTIL
+    DROP
+;
+
+( a -- a+1 c )
+: C@+ DUP C@ SWAP 1+ SWAP ;

forth/fmt.fs

@@ -0,0 +1,73 @@
+( requires core, parse, cmp )
+
+: _
+    999 SWAP        ( stop indicator )
+    DUP 0 = IF '0' EXIT THEN    ( 0 is a special case )
+    BEGIN
+    DUP 0 = IF DROP EXIT THEN
+    10 /MOD         ( r q )
+    SWAP '0' + SWAP ( d q )
+    AGAIN
+;
+
+: .               ( n -- )
+    ( handle negative )
+    DUP 0< IF '-' EMIT -1 * THEN
+    _
+    BEGIN
+    DUP '9' > IF DROP EXIT THEN  ( stop indicator, we're done )
+    EMIT
+    AGAIN
+;
+
+: ? @ . ;
+
+: _
+    DUP 9 > IF 10 - 'a' +
+    ELSE '0' + THEN
+;
+
+( For hex display, there are no negatives )
+
+: .x
+    256 MOD     ( ensure < 0x100 )
+    16 /MOD     ( l h )
+    _ EMIT      ( l )
+    _ EMIT
+;
+
+: .X
+    256 /MOD    ( l h )
+    .x .x
+;
+
+( a -- a+8 )
+: _
+    DUP         ( save for 2nd loop )
+    ':' EMIT DUP .x SPC
+    4 0 DO
+        DUP @
+        256 /MOD SWAP
+        .x .x
+        SPC
+        2+
+    LOOP
+    DROP
+    8 0 DO
+        C@+
+        DUP <>{ 0x20 &< 0x7e |> <>}
+        IF DROP '.' THEN
+        EMIT
+    LOOP
+    CRLF
+;
+
+( n a -- )
+: DUMP
+    LF
+    BEGIN
+        OVER 1 < IF 2DROP EXIT THEN
+        _
+        SWAP 8 - SWAP
+    AGAIN
+;

forth/link.fs

@@ -0,0 +1,185 @@
+( depends: cmp, parse
+  Relink a dictionary by applying offsets to all word
+  references in words of the "compiled" type.
+
+  A typical usage of this unit would be to, right after a
+  bootstrap-from-icore-from-source operation, identify the
+  root word of the source part, probably "H@", and run
+  " ' thatword RLDICT ". Then, take the resulting relinked
+  binary, concatenate it to the boot binary, and write to
+  boot media.
+
+  LIMITATIONS
+
+  This unit can't automatically detect all offsets needing
+  relinking. This is a list of situations that aren't handled:
+
+  Cells: It's not possible to know for sure whether a cellWord
+  contains an address or a number. They are therefore not
+  automatically relinked. You have to manually relink each of
+  them with RLCELL. In the case of a DOES> word, PFA+2, which
+  is always an offset, is automatically relinked, but not
+  PFA+0.
+)
+
+( Skip atom, considering special atom types. )
+( a -- a+n )
+: ASKIP
+    DUP @       ( a n )
+    ( ?br or br or NUMBER )
+    DUP <>{ 0x67 &= 0x53 |= 0x20 |= 0x24 |= <>}
+    IF DROP 4 + EXIT THEN
+    ( regular word )
+    0x22 = NOT IF 2+ EXIT THEN
+    ( it's a lit, skip to null char )
+    ( a )
+    1+  ( we skip by 2, but the loop below is pre-inc... )
+    BEGIN 1+ DUP C@ NOT UNTIL
+    ( skip null char )
+    1+
+;
+
+( Relink atom at a, applying offset o with limit ol.
+  Returns a, appropriately skipped.
+)
+( a o ol -- a+n )
+: RLATOM
+    ROT             ( o ol a )
+    DUP @           ( o ol a n )
+    DUP 0x24 = IF
+        ( 0x24 is an addrWord, which should be offsetted in
+          the same way that a regular word would. To achieve
+          this, we skip ASKIP and instead of skipping 4 bytes
+          like a numberWord, we skip only 2, which means that
+          our number will be treated like a regular wordref.
+        )
+        DROP
+        2+          ( o ol a+2 )
+        ROT ROT 2DROP  ( a )
+        EXIT
+    THEN
+    ROT             ( o a n ol )
+    < IF  ( under limit, do nothing )
+        SWAP DROP    ( a )
+    ELSE
+        ( o a )
+        SWAP OVER @  ( a o n )
+        -^           ( a n-o )
+        OVER !       ( a )
+    THEN
+    ASKIP
+;
+
+( Relink a word with specified offset. If it's not of the type
+  "compiled word", ignore. If it is, advance in word until a2
+  is met, and for each word that is above ol, reduce that
+  reference by o.
+  Arguments: a1: wordref a2: word end addr o: offset to apply
+             ol: offset limit. don't apply on refs under it.
+)
+( ol o a1 a2 -- )
+: RLWORD
+    SWAP DUP C@             ( ol o a2 a1 n )
+    ( 0e == compiledWord, 2b == doesWord )
+    DUP <>{ 0x0e &= 0x2b |= <>} NOT IF
+        ( unwind all args )
+        2DROP 2DROP
+        EXIT
+    THEN
+    ( we have a compiled word or doesWord, proceed )
+    ( doesWord is processed exactly like a compiledWord, but
+      starts 2 bytes further. )
+    ( ol o a2 a1 n )
+    0x2b = IF 2+ THEN
+    ( ol o a2 a1 )
+    1+                          ( ol o a2 a1+1 )
+    BEGIN                       ( ol o a2 a1 )
+        2OVER                   ( ol o a2 a1 ol o )
+        SWAP                    ( ol o a2 a1 o ol )
+        RLATOM                  ( ol o a2 a+n )
+        2DUP < IF ABORT THEN    ( Something is very wrong )
+        2DUP =                  ( ol o a2 a+n f )
+        IF
+            ( unwind )
+            2DROP 2DROP
+            EXIT
+        THEN
+    AGAIN
+;
+
+( TODO implement RLCELL )
+
+( Copy dict from target wordref, including header, up to HERE.
+  We're going relocate those words by specified offset. To do
+  this, we're copying this whole memory area in HERE and then
+  iterate through that copied area and call RLWORD on each
+  word. That results in a dict that can be concatenated to
+  target's prev entry in a more compact way.
+
+  This copy of data doesn't allocate anything, so H@ doesn't
+  move. Moreover, we reserve 4 bytes at H@ to write our target
+  and offset because otherwise, things get too complicated
+  with the PSP.
+
+  The output of this word is 3 numbers: top copied address,
+  top copied CURRENT, and then the beginning of the copied dict
+  at the end to indicate that we're finished processing.
+
+  Note that the last word is always skipped because it's not
+  possible to reliably detect its end. If you need that last
+  word, define a dummy word before calling RLDICT.
+)
+( target offset -- )
+: RLDICT
+    ( First of all, let's get our offset. It's easy, it's
+      target's prev field, which is already an offset, minus
+      its name length. We expect, in RLDICT that a target's
+      prev word is a "hook word", that is, an empty word. )
+    ( H@+2 == offset )
+    H@ 2+ !                     ( target )
+    ( H@ == target )
+    H@ !                        ( )
+    ( We have our offset, now let's copy our memory chunk )
+    H@ @ WORD(                  ( src )
+    DUP H@ -^                   ( src u )
+    DUP ROT SWAP                ( u src u )
+    H@ 4 +                      ( u src u dst )
+    SWAP                        ( u src dst u )
+    MOVE                        ( u )
+    ( Now, let's iterate that dict down )
+    ( wr == wordref we == word end )
+    ( To get our wr and we, we use H@ and CURRENT, which we
+      offset by u+4. +4 before, remember, we're using 4 bytes
+      as variable space. )
+    4 +                         ( u+4 )
+    DUP CURRENT @ WORD( +       ( u we )
+    DUP .X CRLF
+    SWAP CURRENT @ PREV +       ( we wr )
+    DUP .X CRLF
+    BEGIN                       ( we wr )
+        DUP ROT                 ( wr wr we )
+        ( call RLWORD. we need a sig: ol o wr we )
+        H@ @                    ( wr wr we ol )
+        H@ 2+ @                 ( wr wr we ol o )
+        2SWAP                   ( wr ol o wr we )
+        RLWORD                  ( wr )
+        ( wr becomes wr's prev and we is wr-header )
+        DUP                     ( wr wr )
+        PREV                    ( oldwr newwr )
+        SWAP                    ( wr oldwr )
+        WORD(                   ( wr we )
+        SWAP                    ( we wr )
+        ( Are we finished? We're finished if wr-4 <= H@ )
+        DUP 4 - H@ <=
+    UNTIL
+    H@ 4 + .X CRLF
+;
+
+( Relink a regular Forth full interpreter. )
+: RLCORE
+    LIT< H@ (find) DROP         ( target )
+    DUP 3 - @                   ( t prevoff )
+    ( subtract H@ name length )
+    2-                          ( t o )
+    RLDICT
+;

forth/parse.fs

@@ -0,0 +1,76 @@
+( requires core, str )
+( string being sent to parse routines are always null
+  terminated )
+
+: (parsec)          ( a -- n f )
+    ( apostrophe is ASCII 39 )
+    DUP C@ 39 = NOT IF 0 EXIT THEN      ( a 0 )
+    DUP 2+ C@ 39 = NOT IF 0 EXIT THEN   ( a 0 )
+    ( surrounded by apos, good, return )
+    1+ C@ 1                             ( n 1 )
+;
+
+( returns negative value on error )
+: _            ( c -- n )
+    ( '0' is ASCII 48 )
+    48 -
+    DUP 0< IF EXIT THEN                 ( bad )
+    DUP 10 < IF EXIT THEN               ( good )
+    ( 'a' is ASCII 97. 59 = 97 - 48 )
+    49 -
+    DUP 0< IF EXIT THEN                 ( bad )
+    DUP 6 < IF 10 + EXIT THEN           ( good )
+    ( bad )
+    255 -
+;
+
+: (parseh)          ( a -- n f )
+    ( '0': ASCII 0x30 'x': 0x78 0x7830: 30768 )
+    DUP @ 30768 = NOT IF 0 EXIT THEN    ( a 0 )
+    ( We have "0x" prefix )
+    2+
+    0  ( a r )
+    BEGIN
+    SWAP C@+                            ( r a+1 c )
+    DUP NOT IF 2DROP 1 EXIT THEN        ( r, 1 )
+    _                                   ( r a n )
+    DUP 0< IF ROT 2DROP 0 EXIT THEN     ( a 0 )
+    ROT 16 * +                          ( a r*16+n )
+    AGAIN
+;
+
+( returns negative value on error )
+: _            ( c -- n )
+    ( '0' is ASCII 48 )
+    48 -
+    DUP 0< IF EXIT THEN                 ( bad )
+    DUP 2 < IF EXIT THEN                ( good )
+    ( bad )
+    255 -
+;
+
+: (parseb)          ( a -- n f )
+    ( '0': ASCII 0x30 'b': 0x62 0x6230: 25136 )
+    DUP @ 25136 = NOT IF 0 EXIT THEN    ( a 0 )
+    ( We have "0b" prefix )
+    2+
+    0  ( a r )
+    BEGIN
+    SWAP C@+                               ( r a+1 c )
+    DUP NOT IF 2DROP 1 EXIT THEN           ( r 1 )
+    _                                      ( r a n )
+    DUP 0< IF ROT 2DROP 0 EXIT THEN        ( a 0 )
+    ROT 2 * +                              ( a r*2+n )
+    AGAIN
+;
+
+: (parse)           ( a -- n )
+    (parsec) IF EXIT THEN
+    (parseh) IF EXIT THEN
+    (parseb) IF EXIT THEN
+    (parsed) IF EXIT THEN
+    ( nothing works )
+    LIT< (wnf) (find) IF EXECUTE ELSE ABORT THEN
+;
+
+' (parse) (parse*) !

forth/print.fs

@@ -0,0 +1,38 @@
+( Words allowing printing strings. Require core )
+( This used to be in core, but some drivers providing EMIT
+  are much much easier to write with access to core words,
+  and these words below need EMIT... )
+
+: (print)
+    BEGIN
+    C@+      ( a+1 c )
+    ( exit if null )
+    DUP NOT IF 2DROP EXIT THEN
+    EMIT     ( a )
+    AGAIN
+;
+
+: ,"
+    BEGIN
+        C<
+        ( 34 is ASCII for " )
+        DUP 34 = IF DROP EXIT THEN C,
+    AGAIN ;
+
+: ."
+    34 , ( 34 == litWord ) ," 0 C,
+    COMPILE (print)
+; IMMEDIATE
+
+: ABORT" [COMPILE] ." COMPILE ABORT ; IMMEDIATE
+
+: (uflw) ABORT" stack underflow" ;
+
+: BS 8 EMIT ;
+: LF 10 EMIT ;
+: CR 13 EMIT ;
+: CRLF CR LF ;
+: SPC 32 EMIT ;
+
+: (wnf) (print) SPC ABORT" word not found" ;
+: (ok) SPC ." ok" CRLF ;

forth/readln.fs

@@ -0,0 +1,87 @@
+( requires core, parse, print )
+
+( Managing variables in a core module is tricky. Sure, we
+  have (sysv), but here we need to allocate a big buffer, and
+  that cannot be done through (sysv). What we do is that we
+  allocate that buffer at runtime and use (sysv) to point to
+  it, a pointer that is set during the initialization
+  routine. )
+
+64 CONSTANT INBUFSZ
+: RDLNMEM+ 0x53 RAM+ @ + ;
+( current position in INBUF )
+: IN> 0 RDLNMEM+ ;
+( points to INBUF )
+: IN( 2 RDLNMEM+ ;
+( points to INBUF's end )
+: IN) INBUFSZ 2+ RDLNMEM+ ;
+
+( flush input buffer )
+( set IN> to IN( and set IN> @ to null )
+: (infl) 0 IN( DUP IN> ! ! ;
+
+( handle backspace: go back one char in IN>, if possible, then
+  emit SPC + BS )
+: (inbs)
+    ( already at IN( ? )
+    IN> @ IN( = IF EXIT THEN
+    IN> @ 1- IN> !
+    SPC BS
+;
+
+( read one char into input buffer and returns whether we
+  should continue, that is, whether CR was not met. )
+: (rdlnc)                   ( -- f )
+    ( buffer overflow? same as if we typed a newline )
+    IN> @ IN) = IF 0x0a ELSE KEY THEN     ( c )
+    ( del? same as backspace )
+    DUP 0x7f = IF DROP 0x8 THEN
+    ( lf? same as cr )
+    DUP 0x0a = IF DROP 0xd THEN
+    ( echo back )
+    DUP EMIT                    ( c )
+    ( bacspace? handle and exit )
+    DUP 0x8 = IF (inbs) EXIT THEN
+    ( write and advance )
+    DUP     ( keep as result )  ( c c )
+    ( Here, we take advantage of the fact that c's MSB is
+      always zero and thus ! automatically null-terminates
+      our string )
+    IN> @ ! 1 IN> +!            ( c )
+    ( if newline, replace with zero to indicate EOL )
+    DUP 0xd = IF DROP 0 THEN
+;
+
+( Read one line in input buffer and make IN> point to it )
+: (rdln)
+    (infl)
+    BEGIN (rdlnc) NOT UNTIL
+    LF IN( IN> !
+;
+
+( And finally, implement C<* )
+: RDLN<
+    IN> @ C@
+    DUP IF
+        ( not EOL? good, inc and return )
+        1 IN> +!
+    ELSE
+        ( EOL ? readline. we still return null though )
+        (rdln)
+    THEN
+    ( update C<? flag )
+    IN> @ C@ 0 > 0x06 RAM+ !  ( 06 == C<? )
+;
+
+( Initializes the readln subsystem )
+: RDLN$
+    ( 53 == rdln's memory )
+    H@ 0x53 RAM+ !
+    ( 2 for IN>, plus 2 for extra bytes after buffer: 1 for
+      the last typed 0x0a and one for the following NULL. )
+    INBUFSZ 4 + ALLOT
+    (infl)
+    ['] RDLN< 0x0c RAM+ !
+    1 0x06 RAM+ !  ( 06 == C<? )
+;
+

recipes/rc2014/Makefile

@@ -5,9 +5,24 @@ EDIR = $(BASEDIR)/emul
 STAGE2 = $(EDIR)/stage2
 EMUL = $(BASEDIR)/emul/hw/rc2014/classic
 
+PATHS = \
+	$(FDIR)/core.fs \
+	$(FDIR)/cmp.fs \
+	$(FDIR)/parse.fs \
+	$(BASEDIR)/drv/acia.fs \
+	$(FDIR)/print.fs \
+	$(FDIR)/fmt.fs \
+	$(FDIR)/link.fs \
+	run.fs
+STRIPFC = $(BASEDIR)/tools/stripfc
+
 .PHONY: all
 all: $(TARGET) 
-$(TARGET): xcomp.fs $(STAGE2)
+$(TARGET): z80c.bin $(PATHS)
+	cp z80c.bin $@
+	cat $(PATHS) | $(STRIPFC) >> $@
+
+z80c.bin: xcomp.fs
 	cat xcomp.fs | $(STAGE2) > $@
 
 $(SLATEST):

recipes/rc2014/README.md

@@ -64,10 +64,12 @@ We could have this recipe automate that 2 stage build process all automatically,
 but that would rob you of all your fun, right? Instead, we'll run that 2nd
 stage on the RC2014 itself!
 
-To build your stage 1, run `make` in this folder, this will yield `stage1.bin`.
+To build your stage 1, run `make` in this folder, this will yield `os.bin`.
 This will contain that tiny core and, appended to it, the Forth source code it
 needs to run to bootstrap itself. When it's finished bootstrapping, you will
-get a prompt to a full Forth interpreter.
+get a prompt to an almost-full Forth interpreter (there's not enough space in
+8K to fit both link.fs and readln.fs, so we ditch readln. Our prompt is raw. No
+backspace no buffer. Hardcore mode.)
 
 ### Emulate
 
@@ -120,18 +122,15 @@ Our stage 1 prompt is the result of Forth's inner core interpreting the source
 code of the Full Forth, which was appended to the binary inner core in ROM.
 This results in a compiled dictionary, in RAM, at address 0x8000+system RAM.
 
-Wouldn't it be great if we could save that compiled binary in ROM and save the
-system the trouble of recompiling itself on boot?
-
 Unfortunately, this compiled dictionary isn't usable as-is. Offsets compiled in
 there are compiled based on a 0x8000-or-so base offset. What we need is a
 0xa00-or-so base offset, that is, something suitable to be appended to the boot
 binary, in ROM, in binary form.
 
-Fortunately, inside the compiled source is the contents of the Linker (B120)
+Fortunately, inside the compiled source is the contents of link.fs which will
-which will allow us to relink our compiled dictionary so that in can be
+allow us to relink our compiled dictionary so that in can be relocated in ROM,
-relocated in ROM, next to our boot binary. I won't go into relinking details.
+next to our boot binary. I won't go into relinking details. Look at the source.
-Look at the source.  For now, let's just use it:
+For now, let's just use it:
 
     RLCORE
 
@@ -183,15 +182,9 @@ So, the end of our compiled dict is actually `99de`. Alright, let's extract it:
     dd if=memdump bs=1 skip=36192 count=3198 > dict.bin
 
 `36192` is `8d60` and `3198` is `99de-8d60`. This needs to be prepended by the
-boot binary. We already have `stage1.bin`, but this binary contains bootstrap
+boot binary. But that one, we already have. It's `z80c.bin`
-source code we don't need any more. To strip it, we'll need to `dd` it out to
-`LATEST`, in my case `098b`:
 
-    dd if=stage1.bin bs=1 count=2443 > s1pre.bin
+    cat z80c.bin dict.bin > stage2.bin
-
-Now we can combine our binaries:
-
-    cat s1pre.bin dict.bin > stage2.bin
 
 Is it ready to run yet? no. There are 3 adjustments we need to manually make
 using our hex editor.
@@ -209,12 +202,7 @@ using our hex editor.
 
 Now are we ready yet? ALMOST! There's one last thing we need to do: add runtime
 source. In our case, because we have a compiled dict, the only source we need
-to include is initialization code. We've stripped it from our stage1 earlier,
+to include is `run.fs`:
-we need to re-add it.
-
-Look at `xcomp.fs`. You see that `," bla bla bla"` line? That's initialization
-code. Copy it to a file like `run.fs` (without the `,"`) and build your final
-binary:
 
     cat stage2.bin run.fs > stage2r.bin
 
@@ -224,6 +212,48 @@ That's it! our binary is ready to run!
 
 And there you have it, a stage2 binary that you've assembled yourself.
 
+### Assembling stage 3
+
+Stage 2 gives you a useable prompt, but bare. Because 8K isn't a lot of space
+to cram source code, we're limited in what we can include for this stage.
+
+However, now that we have a usable prompt, we can do a lot (be cautious though:
+there is no `readln` yet, so you have no backspace), for example, build a
+stage 3 with `readln`.
+
+Copy the unit's source
+
+    cat ../../forth/readln.fs | ../../tools/stripfc | xclip
+
+and just paste it in your terminal. If you're doing the real thing and not
+using the emulator, pasting so much code at once might freeze up the RC2014, so
+it is recommended that you use `/tools/exec` that let the other side enough
+time to breathe.
+
+After your pasting, you'll have a compiled dict of that code in memory. You'll
+need to relocate it in the same way you did for stage 2, but instead of using
+`RLCORE`, which is a convenience word hardcoded for stage 1, we'll parametrize
+`RLDICT`, the word doing the real work.
+
+`RLDICT` takes 2 arguments, `target` and `offset`. `target` is the first word
+of your relocated dict. In our case, it's going to be `' INBUFSZ`. `offset` is
+the offset we'll apply to every eligible word references in our dict. In our
+case, that offset is the offset of the *beginning* of the `INBUFSZ` entry (that
+is, `' INBUFSZ WORD(` minus the offset of the last word (which should be a hook
+word) in the ROM binary.
+
+That offset can be conveniently fetched from code because it is the value of
+the `LATEST` constant in stable ABI, which is at offset `0x08`. Therefore, our
+offset value is:
+
+    ' INBUFSZ WORD( 0x08 @ -
+
+You can now run `RLDICT` and proceed with concatenation (and manual adjustments
+of course) as you did with stage 2. Don't forget to adjust `run.fs` so that it
+initializes `RDLN$` instead of creating a minimal `(c<)`.
+
+Keep that `stage3.bin` around, you will need it for further recipes.
+
 [rc2014]: https://rc2014.co.uk
 [romwrite]: https://github.com/hsoft/romwrite
 [stage2]: ../../emul

recipes/rc2014/eeprom/README.md

@@ -8,7 +8,7 @@ itself.
 ## Gathering parts
 
 * A RC2014 Classic
-* `stage2.bin` from the base recipe
+* `stage3.bin` from the base recipe
 * An extra AT28C64B
 * 1x 40106 inverter gates
 * Proto board, RC2014 header pins, wires, IC sockets, etc.
@@ -33,46 +33,11 @@ in write protection mode, but I preferred building my own module.
 
 I don't think you need a schematic. It's really simple.
 
-### Assembling stage 3
+## Building your stage 4
 
-Stage 2 gives you a full interpreter, but it's missing the "Addressed devices"
+Using the same technique as you used for building your stage 3, you can append
-module and the AT28 driver. We'll need to assemble a stage 3.
+required words to your boot binary. Required units are `forth/adev.fs` and
-
+`drv/at28.fs`.
-When you'll have a system with function disk block system, you'll be able to
-directly `LOAD` them, but for this recipe, we can't assume you have, so what
-you'll have to do is to manually paste the code from the appropriate blocks.
-
-Addressed devices are at B140. To know what you have to paste, open the loader
-block (B142) and see what blocks it loads. For each of the blocks, copy/paste
-the code in your interpreter.
-
-Do the same thing with the AT28 driver (B150)
-
-If you're doing the real thing and not using the emulator, pasting so much code
-at once might freeze up the RC2014, so it is recommended that you use
-`/tools/exec` that let the other side enough time to breathe.
-
-After your pasting, you'll have a compiled dict of that code in memory. You'll
-need to relocate it in the same way you did for stage 2, but instead of using
-`RLCORE`, which is a convenience word hardcoded for stage 1, we'll parametrize
-`RLDICT`, the word doing the real work.
-
-`RLDICT` takes 2 arguments, `target` and `offset`. `target` is the first word
-of your relocated dict. In our case, it's going to be `' ADEVMEM+`. `offset` is
-the offset we'll apply to every eligible word references in our dict. In our
-case, that offset is the offset of the *beginning* of the `ADEVMEM+` entry (that
-is, `' ADEVMEM+ WORD(` minus the offset of the last word (which should be a hook
-word) in the ROM binary.
-
-That offset can be conveniently fetched from code because it is the value of
-the `LATEST` constant in stable ABI, which is at offset `0x08`. Therefore, our
-offset value is:
-
-    ' ADEVMEM+ WORD( 0x08 @ -
-
-You can now run `RLDICT` and proceed with concatenation (and manual adjustments
-of course) as you did with stage 2. Don't forget to adjust `run.fs` so that it
-runs `ADEV$`.
 
 ## Writing contents to the AT28
 

recipes/rc2014/run.fs

@@ -0,0 +1,2 @@
+: x KEY DUP EMIT ;
+: _ ACIA$ (ok) ['] x 0x0c RAM+ ! ; _

recipes/rc2014/sdcard/README.md

@@ -19,7 +19,7 @@ design.
 ## Gathering parts
 
 * A RC2014 Classic
-* `stage2.bin` from the base recipe
+* `stage3.bin` from the base recipe
 * A MicroSD breakout board. I use Adafruit's.
 * A proto board + header pins with 39 positions so we can make a RC2014 card.
 * Diodes, resistors and stuff
@@ -69,20 +69,20 @@ matter. However, it *does* matter for the `SELECT` line, so I don't follow my
 own schematic with regards to the `M1` and `A2` lines and use two inverters
 instead.
 
-## Building your stage 3
+## Building your stage 4
 
-Using the same technique as you used in the `eeprom` recipe, you can append
+Using the same technique as you used for building your stage 3, you can append
-required words to your boot binary. Required units `blk` (B464) and the SD Card
+required words to your boot binary. Required units are `forth/blk.fs` and
-driver (B370). You only need the Forth part. You of course actually need
+`drv/sdc.fs`. You also need `drv/sdc.z80` but to save you the troubles of
-Z80 SDC words but to save you the troubles of rebuilding from stage 1 for this
+rebuilding from stage 1 for this recipe, we took the liberty of already having
-recipe, we took the liberty of already having included it in the base recipe.
+included it in the base recipe.
 
 ## Testing in the emulator
 
 The RC2014 emulator includes SDC emulation. You can attach a SD card image to
 it by invoking it with a second argument:
 
-    ../../../emul/hw/rc2014/classic stage3.bin ../../../emul/blkfs
+    ../../../emul/hw/rc2014/classic stage4.bin ../../../emul/blkfs
 
 You will then run with a SD card having the contents from `/blk`.
 

recipes/rc2014/selfhost/README.md

@@ -6,60 +6,31 @@ either for another RC2014 or for an OS upgrade.
 
 ## Gathering parts
 
-* stage3 from `sdcard` recipe. If you want to write to EEPROM as the final step,
+* stage4 from `sdcard` recipe. If you want to write to EEPROM as the final step,
-  you'll need a hybrid stage3 that also includes stuff from the `eeprom` recipe.
+  you'll need a hybrid stage4 that also includes stuff from the `eeprom` recipe.
 
 ## Building stage 1
 
-Build Collapse OS' stage 1 from within Collapse OS is very similar to how we do
+### Part 1
-it from the makefile. If you take the time to look at the base recipe
+
-`Makefile`, you'll see `cat xcomp.fs | $(STAGE2)`. That's the thing.  Open
+Building the first part of stage 1 (the binary part, before the inlined-source
+part) from within Collapse OS is actually very similar from building it from a
+modern environment. If you take the time to look at the base recipe `Makefile`,
+you'll see `cat xcomp.fs | $(STAGE2)`. That command builds part 1. Open
 `xcomp.fs` in a text editor and take a look at it.
 
 To assemble stage 1 from RC2014, all you need to do is to type those commands
 in the same order, and replace the `H@ 256 /MOD 2 PC! 2 PC!` lines with `H@ .X`.
 Those commands will inform you of the begin/end offsets of the assembled binary.
 
-I'm not going to explain in detail what each command do, but only give you an
+The meaning of these commands is not explained here. You are encouraged to read
-overview of what is happening.  You are encouraged to read the in-system
+the in-system documentation for more information.
-documentation for more information.
 
-The first part is configuration of your new system. When RAM starts, where RSP
+However, one thing you should know is that because the SD card driver is a bit
-starts, what ports to use for what device, etc. These configuration declarations
+slow, some of these commands take a long time. Multiple minutes. Be patient.
-are expected in the boot code and driver code.
-
-Then, we load the Z80 assembler and the cross compiler (xcomp for short), which
-we'll of course need for the task ahead.
-
-Then come xcomp overrides, which are needed for xcomp to be effective.
-
-At this point, we're about to begin spitting binary content, so we want to know
-where we're at. That's why you'll need to type `H@ .X` and write down the
-result. That's the starting offset.
-
-Then, we assemble the boot binary, drivers' native words, then inner core,
-close the binary with a hook word. We're finished with cross-compiling.
-
-We're at the offset that will be `CURRENT` on boot, so we update `LATEST`.
-
-Then, we spit the course code that will be interpreted by stage 1 on boot so
-that it bootstraps itself to a full interpreter. Not all units are there
-because they don't fit in 8K, but they're sufficient for our needs. We also
-need the linker so that we can relink ourselves to stage 2.
-
-Finally, we have initialization code, then a spit of the ending offset.
-
-Go ahead, run that.  However, one thing you should know is that because the SD
-card driver is a bit slow, some of these commands take a long time. Multiple
-minutes. Be patient.
 
 Once all your commands are run and that you have your begin/end offset (write
-them down somewhere), you're at the same point as you were after the `make`
+them down somewhere), you're ready to assemble part 2.
-part of the base recipe. The contents between your start and end offset is the
-exact same as the contents of `stage1.bin` when you run `make`. Continue your
-deployment from there.
-
-Good luck!
 
 ### What to do on SDerr?
 
@@ -77,3 +48,7 @@ You're looking at the offset of the last wordref of the *previous* LOAD
 operation. That offset is going in `XCURRENT`. Then, you're looking at the end
 of that word. That offset goes in `HERE`. Once you've done that, relaunch your
 LOAD.
+
+### Part 2
+
+TODO

recipes/rc2014/xcomp.fs

@@ -24,11 +24,4 @@ H@ XOFF !
 (entry) _
 ( Update LATEST )
 H@ XOFF @ - XOFF @ 8 + !
-422 441 XPACKR ( core cmp )
-446 452 XPACKR ( parse )
-358 360 XPACKR ( acia.fs )
-442 445 XPACKR ( print )
-453 463 XPACKR ( readln fmt )
-123 132 XPACKR ( linker )
-," : _ ACIA$ RDLN$ (ok) ; _ "
 H@ 256 /MOD 2 PC! 2 PC!

tools/Makefile

@@ -4,12 +4,13 @@ UPLOAD_TGT = upload
 FONTCOMPILE_TGT = fontcompile
 TTYSAFE_TGT = ttysafe
 PINGPONG_TGT = pingpong
+STRIPFC_TGT = stripfc
 BIN2C_TGT = bin2c
 EXEC_TGT = exec
 BLKPACK_TGT = blkpack
 BLKUNPACK_TGT = blkunpack
 TARGETS = $(MEMDUMP_TGT) $(BLKDUMP_TGT) $(UPLOAD_TGT) $(FONTCOMPILE_TGT) \
-	$(TTYSAFE_TGT) $(PINGPONG_TGT) \
+	$(TTYSAFE_TGT) $(PINGPONG_TGT) $(STRIPFC_TGT) \
 	$(BIN2C_TGT) $(EXEC_TGT) $(BLKPACK_TGT) $(BLKUNPACK_TGT)
 OBJS = common.o
 
@@ -25,6 +26,7 @@ $(UPLOAD_TGT): $(UPLOAD_TGT).c
 $(FONTCOMPILE_TGT): $(FONTCOMPILE_TGT).c
 $(TTYSAFE_TGT): $(TTYSAFE_TGT).c
 $(PINGPONG_TGT): $(PINGPONG_TGT).c
+$(STRIPFC_TGT): $(STRIPFC_TGT).c
 $(BIN2C_TGT): $(BIN2C_TGT).c
 $(EXEC_TGT): $(EXEC_TGT).c
 $(BLKPACK_TGT): $(BLKPACK_TGT).c

tools/stripfc.c

@@ -0,0 +1,57 @@
+#include <stdio.h>
+
+/* read stdin and strip Forth-style comments before spitting in stdout. This
+also deduplicate spaces and newlines.
+
+THIS PARSING IS IMPERFECT. Only a Forth interpreter can reliably detect
+comments. For example, a naive parser misinterprets the "(" word definition as
+a comment.
+
+We work around this by considering as a comment opener only "(" chars preceeded
+by more than once space or by a newline. Hackish, but works.
+*/
+
+int main()
+{
+    int spccnt = 1; // if the first char is a (, consider it a comment opener.
+    int incomment = 0;
+    int c;
+    c = getchar();
+    while ( c != EOF ) {
+        if (c == '\n') {
+            if (!incomment) {
+                // We still spit newlines whenever we see them, Forth interpreter
+                // doesn't like when they're not there...
+                putchar(c);
+            }
+            spccnt += 1;
+        } else if (c == ' ') {
+            spccnt++;
+        } else {
+            if (incomment) {
+                if ((c == ')') && spccnt) {
+                    incomment = 0;
+                }
+            } else {
+                if ((c == '(') && spccnt) {
+                    putchar(' ');
+                    spccnt = 0;
+                    int next = getchar();
+                    if (next <= ' ') {
+                        incomment = 1;
+                        continue;
+                    }
+                    putchar(c);
+                    c = next;
+                }
+                if (spccnt) {
+                    putchar(' ');
+                }
+                putchar(c);
+            }
+            spccnt = 0;
+        }
+        c = getchar();
+    }
+    return 0;
+}