emul: merge pre.fs and emul.fs into stage1.fs

blk/001

@@ -5,7 +5,7 @@ MASTER INDEX
 200 Z80 assembler             260 Cross compilation
 280 Z80 boot code             350 ACIA driver
 370 SD Card driver            390 Inner core
-
+420 Core words
 
 
 

blk/269

@@ -0,0 +1,3 @@
+( b1 b2 -- )
+: XPACKR 1+ SWAP DO I DUP . CRLF XPACK LOOP ;
+

blk/420

@@ -0,0 +1,14 @@
+Core words
+
+These words follow Inner core words, but unlike them, these are
+self-bootstrapping and don't depend on the Cross Compiler. They
+will typically be included in source form right after a stage1
+binary which will interpret it on boot and bootstrap itself to
+a full intepreter, which can then be relinked with the
+Relinker. There is no loader for these libraries because you
+will typically XPACK (B267) them.
+
+422 core                       438 cmp
+442 print                      446 parse
+453 readln                     459 fmt
+464 blk

blk/422

@@ -0,0 +1,16 @@
+: 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
+

blk/423

@@ -0,0 +1,5 @@
+: COMPILE ' LITA ['] , , ; IMMEDIATE
+: [COMPILE] ' , ; IMMEDIATE
+: BEGIN H@ ; IMMEDIATE
+: AGAIN COMPILE (br) H@ - , ; IMMEDIATE
+: UNTIL COMPILE (?br) H@ - , ; IMMEDIATE

blk/424

@@ -0,0 +1,13 @@
+: _ 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
+
+  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. )

blk/425

@@ -0,0 +1,15 @@
+: +! 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
+

blk/426

@@ -0,0 +1,8 @@
+: 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
+

blk/427

@@ -0,0 +1,10 @@
+( 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
+

blk/428

@@ -0,0 +1,13 @@
+( 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
+
+

blk/429

@@ -0,0 +1,7 @@
+: CREATE
+    (entry)            ( empty header with name )
+    11                 ( 11 == cellWord )
+    C,                 ( write it )
+;
+
+

blk/430

@@ -0,0 +1,14 @@
+: 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 )
+;
+

blk/431

@@ -0,0 +1,13 @@
+: 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
+
+

blk/432

@@ -0,0 +1,16 @@
+( 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

blk/433

@@ -0,0 +1,14 @@
+: 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 ;
+
+

blk/434

@@ -0,0 +1,16 @@
+( 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 )
+;

blk/435

@@ -0,0 +1,16 @@
+: 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 ! ;

blk/436

@@ -0,0 +1,12 @@
+( 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 ;

blk/438

@@ -0,0 +1,13 @@
+( Words useful for complex comparison operations )
+
+: >= < NOT ;
+: <= > NOT ;
+: 0>= 0< NOT ;
+
+( n1 -- n1 true )
+: <>{ 1 ;
+
+( n1 f -- f )
+: <>} SWAP DROP ;
+
+

blk/439

@@ -0,0 +1,15 @@
+
+: _|&
+    ( 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 )
+    _|&
+;
+

blk/440

@@ -0,0 +1,15 @@
+: _&
+    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 )
+' = _| |=
+' = _& &=
+' > _| |>
+' > _& &>
+' < _| |<
+' < _& &<

blk/442

@@ -0,0 +1,11 @@
+( EMIT is needed for this unit to compile )
+
+: (print)
+    BEGIN
+    C@+      ( a+1 c )
+    ( exit if null )
+    DUP NOT IF 2DROP EXIT THEN
+    EMIT     ( a )
+    AGAIN
+;
+

blk/443

@@ -0,0 +1,15 @@
+: ."
+    34 ,        ( 34 == litWord )
+    BEGIN
+        C<
+        ( 34 is ASCII for " )
+        DUP 34 = IF DROP 0 THEN
+        DUP C,
+    NOT UNTIL
+    COMPILE (print)
+; IMMEDIATE
+
+: ABORT" [COMPILE] ." COMPILE ABORT ; IMMEDIATE
+
+: (uflw) ABORT" stack underflow" ;
+

blk/444

@@ -0,0 +1,9 @@
+: 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 ;
+

blk/446

@@ -0,0 +1,11 @@
+( strings 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 )
+;
+

blk/447

@@ -0,0 +1,15 @@
+( 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 -
+;
+
+

blk/448

@@ -0,0 +1,15 @@
+: (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
+;
+

blk/449

@@ -0,0 +1,11 @@
+( 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 -
+;
+
+

blk/450

@@ -0,0 +1,16 @@
+: (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
+;
+
+

blk/451

@@ -0,0 +1,10 @@
+: (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*) !

blk/453

@@ -0,0 +1,13 @@
+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> ! ! ;
+

blk/454

@@ -0,0 +1,16 @@
+( 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
+;
+
+
+
+
+
+
+( cont.: read one char into input buffer and returns whether we
+  should continue, that is, whether CR was not met. )

blk/455

@@ -0,0 +1,16 @@
+: (rdlnc)                   ( -- f )
+    ( buffer overflow? same as if we typed a newline )
+    IN> @ IN) = IF 0x0a ELSE KEY THEN     ( c )
+    DUP 0x7f = IF DROP 0x8 THEN ( del? same as backspace )
+    DUP 0x0a = IF DROP 0xd THEN ( lf? same as cr )
+    ( echo back )
+    DUP EMIT                    ( c )
+    ( bacspace? handle and exit )
+    DUP 0x8 = IF (inbs) EXIT THEN
+    ( write and advance )
+    DUP     ( keep as result )  ( c c )
+( 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 ;

blk/456

@@ -0,0 +1,16 @@
+( 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<? )
+;

blk/457

@@ -0,0 +1,12 @@
+( 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<? )
+;
+

blk/459

@@ -0,0 +1,16 @@
+: _
+    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 )
+        EMIT
+    AGAIN ;

blk/460

@@ -0,0 +1,16 @@
+: ? @ . ;
+: _
+    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
+;

blk/461

@@ -0,0 +1,16 @@
+: _ ( 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
+;

blk/462

@@ -0,0 +1,9 @@
+: DUMP ( n a -- )
+    LF
+    BEGIN
+        OVER 1 < IF 2DROP EXIT THEN
+        _
+        SWAP 8 - SWAP
+    AGAIN
+;
+

blk/464

@@ -0,0 +1,12 @@
+: 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/465

@@ -0,0 +1,12 @@
+: 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/466

@@ -0,0 +1,13 @@
+: BLK! ( -- )
+    BLK> @ BLK!* @ EXECUTE
+    0 BLKDTY !
+;
+
+: BLK@ ( n -- )
+    DUP BLK> @ = IF DROP EXIT THEN
+    BLKDTY @ IF BLK! THEN
+    DUP BLK> ! BLK@* @ EXECUTE
+;
+
+: BLK!! 1 BLKDTY ! ;
+

blk/467

@@ -0,0 +1,11 @@
+: .2 DUP 10 < IF SPC THEN . ;
+
+: LIST
+    BLK@
+    16 0 DO
+        I 1+ .2 SPC
+        64 I * BLK( + (print)
+        CRLF
+    LOOP
+;
+

blk/468

@@ -0,0 +1,16 @@
+: _
+    (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
+;
+
+( pre-comment for tight LOAD: The 0x08==I check after INTERPRET
+  is to check whether we're restoring to "_", the word above.
+  if yes, then we're in a nested load. Also, the 1 in 0x06 is
+  to avoid tons of "ok" displays. )

blk/469

@@ -0,0 +1,16 @@
+: LOAD
+    BLK> @ >R ( save restorable variables to RSP )
+    0x08 RAM+ @ >R
+    0x06 RAM+ @ >R  ( C<? )
+    0x2e RAM+ @ >R  ( boot ptr )
+    BLK@
+    BLK( 0x2e RAM+ ! ( Point to beginning of BLK )
+    ['] _ 0x08 RAM+ ! ( 08 == C<* override )
+    1 0x06 RAM+ !  ( 06 == C<? )
+    INTERPRET
+    R> 0x2e RAM+ ! R> 0x06 RAM+ !
+    I 0x08 RAM+ @ = IF ( nested load )
+        R> DROP ( C<* ) R> BLK@
+    ELSE ( not nested )
+        R> 0x08 RAM+ ! R> DROP ( BLK> )
+    THEN ;

blk/470

@@ -0,0 +1,2 @@
+( b1 b2 -- )
+: LOADR 1+ SWAP DO I DUP . CRLF LOAD LOOP ;

emul/Makefile

@@ -23,10 +23,9 @@ $(BLKUNPACK): $(BLKPACK)
 
 # z80c.bin is not in the prerequisites because it's a bootstrap
 # binary that should be updated manually through make updatebootstrap.
-forth0.bin: $(SLATEST)
+forth0.bin:
 	cp z80c.bin $@
-	$(SLATEST) $@
+	cat stage1.fs >> $@
-	cat pre.fs emul.fs >> $@
 
 forth0-bin.h: forth0.bin $(BIN2C)
 	$(BIN2C) KERNEL < forth0.bin | tee $@ > /dev/null

emul/pre.fs

@@ -1,2 +0,0 @@
-CURRENT @ HERE !
-

emul/stage1.fs

@@ -1,3 +1,4 @@
+CURRENT @ HERE !
 HERE @ 256 /MOD 2 PC! 2 PC!
 : EMIT 0 PC! ;
 : KEY 0 PC@ ;

emul/xcomp.fs

@@ -14,4 +14,6 @@ H@ XOFF !
 282 LOAD  ( boot.z80 )
 393 LOAD  ( icore )
 (entry) _
+( Update LATEST )
+H@ XOFF @ - XOFF @ 8 + !
 H@ 256 /MOD 2 PC! 2 PC!