From 705d68deec47672c6726f3e63ea4d01469112e10 Mon Sep 17 00:00:00 2001 From: Virgil Dupras Date: Wed, 28 Oct 2020 18:06:58 -0400 Subject: [PATCH] Move most of the high layer of comp core into the low one With KEY and EMIT being switch words, most of the high layer can be defined before drivers. In addition to this change, I've compacted core blocks which were becoming quite sparse. --- blk/001 | 1 + blk/352 | 2 +- blk/353 | 2 +- blk/357 | 14 ++++++++++++++ blk/358 | 28 ++++++++++++++-------------- blk/359 | 24 ++++++++++-------------- blk/360 | 24 +++++++++++++++--------- blk/361 | 13 ++++++------- blk/362 | 21 +++++++-------------- blk/363 | 19 +++++++++++-------- blk/364 | 19 ++++++++----------- blk/365 | 21 +++++++++++++-------- blk/366 | 26 +++++++++++++------------- blk/367 | 14 ++++++++++++++ blk/368 | 10 ++++++++++ blk/369 | 27 ++++++++++++++------------- blk/370 | 27 +++++++++++++-------------- blk/371 | 14 ++++---------- blk/372 | 24 ++++++++++-------------- blk/373 | 20 ++++++++------------ blk/374 | 18 ++++++++++++++---- blk/375 | 16 ++++++++++++++++ blk/376 | 26 ++++++++++++++++---------- blk/377 | 20 ++++++++++++-------- blk/378 | 27 +++++++++++++-------------- blk/{388 => 379} | 0 blk/380 | 17 ++++++++++++++++- blk/381 | 10 ++++++++++ blk/382 | 11 +++++++++++ blk/383 | 27 +++++++++++++-------------- blk/384 | 32 ++++++++++++++++---------------- blk/385 | 28 +++++++++++++++------------- blk/{395 => 386} | 0 blk/387 | 13 ------------- blk/389 | 16 ---------------- blk/390 | 26 ++++++++++++++++---------- blk/391 | 15 ++++----------- blk/392 | 25 ++++++++++++------------- blk/393 | 32 ++++++++++++++++---------------- blk/394 | 28 +++++++++++++--------------- blk/396 | 16 ---------------- blk/397 | 4 ---- blk/398 | 14 -------------- blk/399 | 16 ---------------- blk/400 | 13 ------------- cvm/forth.bin | Bin 5237 -> 5237 bytes cvm/xcomp.fs | 4 ++-- emul/8086/xcomp.fs | 2 +- emul/z80/xcomp.fs | 2 +- recipes/pcat/blk/612 | 2 +- recipes/rc2014/blk/619 | 2 +- recipes/sms/xcomp.fs | 2 +- recipes/ti84/xcomp.fs | 2 +- recipes/trs80/xcomp.fs | 2 +- recipes/z80mbc2/xcomp.fs | 2 +- 55 files changed, 410 insertions(+), 410 deletions(-) create mode 100644 blk/357 create mode 100644 blk/367 create mode 100644 blk/368 create mode 100644 blk/375 rename blk/{388 => 379} (100%) create mode 100644 blk/381 create mode 100644 blk/382 rename blk/{395 => 386} (100%) delete mode 100644 blk/387 delete mode 100644 blk/389 delete mode 100644 blk/396 delete mode 100644 blk/397 delete mode 100644 blk/398 delete mode 100644 blk/399 delete mode 100644 blk/400 diff --git a/blk/001 b/blk/001 index 7b63637..d5cbb0c 100644 --- a/blk/001 +++ b/blk/001 @@ -6,6 +6,7 @@ MASTER INDEX 160 AVR SPI programmer 170-259 unused 260 Cross compilation 280 Z80 boot code 350 Core words +400-410 unused 410 PS/2 keyboard subsystem 418 Z80 SPI Relay driver 420 SD Card subsystem 440 8086 boot code 470-519 unused 520 Fonts diff --git a/blk/352 b/blk/352 index f80571b..2e2c3a0 100644 --- a/blk/352 +++ b/blk/352 @@ -6,4 +6,4 @@ impossible. The gap between these 2 parts is the ideal place to put device driver code. Load the low part with "353 LOAD", the high part -with "380 LOAD" +with "390 LOAD" diff --git a/blk/353 b/blk/353 index dc2d8ed..6c38024 100644 --- a/blk/353 +++ b/blk/353 @@ -11,4 +11,4 @@ (resRS) 0 0x08 RAM+ ! ( C<* override ) (infl) LIT" (main)" FIND DROP EXECUTE ; -1 25 LOADR+ ( xcomp core low ) +1 33 LOADR+ diff --git a/blk/357 b/blk/357 new file mode 100644 index 0000000..00037e1 --- /dev/null +++ b/blk/357 @@ -0,0 +1,14 @@ +( r c -- r f ) +( Parse digit c and accumulate into result r. + Flag f is 0 when c was a valid digit, 1 when c was WS, + -1 when c was an invalid digit. ) +: _pdacc + DUP 0x21 < IF DROP 1 EXIT THEN + ( parse char ) + ( if bad, return "r -1" ) + '0' - + DUP 10 < NOT IF DROP -1 EXIT THEN + ( good, add to running result ) + SWAP 10 * + ( r*10+n ) + 0 ( good ) +; diff --git a/blk/358 b/blk/358 index 00037e1..2830d62 100644 --- a/blk/358 +++ b/blk/358 @@ -1,14 +1,14 @@ -( r c -- r f ) -( Parse digit c and accumulate into result r. - Flag f is 0 when c was a valid digit, 1 when c was WS, - -1 when c was an invalid digit. ) -: _pdacc - DUP 0x21 < IF DROP 1 EXIT THEN - ( parse char ) - ( if bad, return "r -1" ) - '0' - - DUP 10 < NOT IF DROP -1 EXIT THEN - ( good, add to running result ) - SWAP 10 * + ( r*10+n ) - 0 ( good ) -; +: _pd ( a -- n f, parse decimal ) +( We read the first char outside of the loop because it *has* + to be nonzero, which means _pdacc *has* to return 0. ) + C@+ OVER C@ 0 ( a len firstchar startat ) +( if we have '-', we only advance. more processing later. ) + SWAP '-' = IF 1+ THEN ( a len startat ) +( We loop until _pdacc is nonzero, which means either WS or + non-digit. 1 means WS, which means parsing was a success. + -1 means non-digit, which means we have a non-decimal. ) + 0 ROT ROT ( len ) ( startat ) DO ( a r ) + OVER I + C@ ( a r c ) _pdacc ( a r f ) + IF DROP 1- 0 UNLOOP EXIT THEN LOOP ( a r ) +( if we had '-', we need to invert result. ) + SWAP C@ '-' = IF 0 -^ THEN 1 ( r 1 ) ; diff --git a/blk/359 b/blk/359 index 2830d62..0665b8b 100644 --- a/blk/359 +++ b/blk/359 @@ -1,14 +1,10 @@ -: _pd ( a -- n f, parse decimal ) -( We read the first char outside of the loop because it *has* - to be nonzero, which means _pdacc *has* to return 0. ) - C@+ OVER C@ 0 ( a len firstchar startat ) -( if we have '-', we only advance. more processing later. ) - SWAP '-' = IF 1+ THEN ( a len startat ) -( We loop until _pdacc is nonzero, which means either WS or - non-digit. 1 means WS, which means parsing was a success. - -1 means non-digit, which means we have a non-decimal. ) - 0 ROT ROT ( len ) ( startat ) DO ( a r ) - OVER I + C@ ( a r c ) _pdacc ( a r f ) - IF DROP 1- 0 UNLOOP EXIT THEN LOOP ( a r ) -( if we had '-', we need to invert result. ) - SWAP C@ '-' = IF 0 -^ THEN 1 ( r 1 ) ; +( strings being sent to parse routines are always null + terminated ) + +: _pc ( a -- n f, parse character ) + ( apostrophe is ASCII 39 ) + DUP 1+ C@ 39 = OVER 3 + C@ 39 = AND ( a f ) + NOT IF 0 EXIT THEN ( a 0 ) + ( surrounded by apos, good, return ) + 2+ C@ 1 ( n 1 ) +; diff --git a/blk/360 b/blk/360 index 0665b8b..d56e25a 100644 --- a/blk/360 +++ b/blk/360 @@ -1,10 +1,16 @@ -( strings being sent to parse routines are always null - terminated ) - -: _pc ( a -- n f, parse character ) - ( apostrophe is ASCII 39 ) - DUP 1+ C@ 39 = OVER 3 + C@ 39 = AND ( a f ) - NOT IF 0 EXIT THEN ( a 0 ) - ( surrounded by apos, good, return ) - 2+ C@ 1 ( n 1 ) +( returns negative value on error ) +: _ ( c -- n ) + DUP '0' '9' =><= IF '0' - EXIT THEN + DUP 'a' 'f' =><= IF 0x57 ( 'a' - 10 ) - EXIT THEN + DROP -1 ( bad ) ; +: _ph ( a -- n f, parse hex ) + ( '0': ASCII 0x30 'x': 0x78 0x7830 ) + DUP 1+ @ 0x7830 = NOT IF 0 EXIT THEN ( a 0 ) + ( We have "0x" prefix ) + DUP C@ ( a len ) + 0 SWAP 1+ ( len+1 ) 3 DO ( a r ) + OVER I + C@ ( a r c ) _ ( a r n ) + DUP 0< IF 2DROP 0 UNLOOP EXIT THEN + SWAP 4 LSHIFT + ( a r*16+n ) LOOP + NIP 1 ; diff --git a/blk/361 b/blk/361 index d56e25a..05b9772 100644 --- a/blk/361 +++ b/blk/361 @@ -1,16 +1,15 @@ ( returns negative value on error ) : _ ( c -- n ) - DUP '0' '9' =><= IF '0' - EXIT THEN - DUP 'a' 'f' =><= IF 0x57 ( 'a' - 10 ) - EXIT THEN + DUP '0' '1' =><= IF '0' - EXIT THEN DROP -1 ( bad ) ; -: _ph ( a -- n f, parse hex ) - ( '0': ASCII 0x30 'x': 0x78 0x7830 ) - DUP 1+ @ 0x7830 = NOT IF 0 EXIT THEN ( a 0 ) - ( We have "0x" prefix ) +: _pb ( a -- n f, parse binary ) + ( '0': ASCII 0x30 'b': 0x62 0x6230 ) + DUP 1+ @ 0x6230 = NOT IF 0 EXIT THEN ( a 0 ) + ( We have "0b" prefix ) DUP C@ ( a len ) 0 SWAP 1+ ( len+1 ) 3 DO ( a r ) OVER I + C@ ( a r c ) _ ( a r n ) DUP 0< IF 2DROP 0 UNLOOP EXIT THEN - SWAP 4 LSHIFT + ( a r*16+n ) LOOP + SWAP 1 LSHIFT + ( a r*2+n ) LOOP NIP 1 ; diff --git a/blk/362 b/blk/362 index 05b9772..2a1e2d3 100644 --- a/blk/362 +++ b/blk/362 @@ -1,15 +1,8 @@ -( returns negative value on error ) -: _ ( c -- n ) - DUP '0' '1' =><= IF '0' - EXIT THEN - DROP -1 ( bad ) +: (parse) ( a -- n ) + _pc IF EXIT THEN + _ph IF EXIT THEN + _pb IF EXIT THEN + _pd IF EXIT THEN + ( nothing works ) + (wnf) ; -: _pb ( a -- n f, parse binary ) - ( '0': ASCII 0x30 'b': 0x62 0x6230 ) - DUP 1+ @ 0x6230 = NOT IF 0 EXIT THEN ( a 0 ) - ( We have "0b" prefix ) - DUP C@ ( a len ) - 0 SWAP 1+ ( len+1 ) 3 DO ( a r ) - OVER I + C@ ( a r c ) _ ( a r n ) - DUP 0< IF 2DROP 0 UNLOOP EXIT THEN - SWAP 1 LSHIFT + ( a r*2+n ) LOOP - NIP 1 ; diff --git a/blk/363 b/blk/363 index 2a1e2d3..7369907 100644 --- a/blk/363 +++ b/blk/363 @@ -1,8 +1,11 @@ -: (parse) ( a -- n ) - _pc IF EXIT THEN - _ph IF EXIT THEN - _pb IF EXIT THEN - _pd IF EXIT THEN - ( nothing works ) - (wnf) -; +: C + ( Overwrite cellWord in CURRENT ) + 3 ( does ) 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 ) +; +: CONSTANT CREATE , DOES> @ ; diff --git a/blk/371 b/blk/371 index d1532ba..5919535 100644 --- a/blk/371 +++ b/blk/371 @@ -1,10 +1,4 @@ -: [entry] ( w -- ) - C@+ ( w+1 len ) TUCK MOVE, ( len ) - ( write prev value ) - H@ CURRENT @ - , - C, ( write size ) - H@ CURRENT ! -; -: (entry) WORD [entry] ; -: CREATE (entry) 2 ( cellWord ) C, ; -: VARIABLE CREATE 2 ALLOT ; +: [IF] + IF EXIT THEN + LIT" [THEN]" BEGIN DUP WORD S= UNTIL DROP ; +: [THEN] ; diff --git a/blk/372 b/blk/372 index 20860d1..180249e 100644 --- a/blk/372 +++ b/blk/372 @@ -1,14 +1,10 @@ -: 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 IF DUP HERE ! CURRENT ! THEN ; +( n -- Fetches block n and write it to BLK( ) +: BLK@* 0x34 RAM+ ; +( n -- Write back BLK( to storage at block n ) +: BLK!* 0x36 RAM+ ; +( Current blk pointer in ( ) +: BLK> 0x38 RAM+ ; +( Whether buffer is dirty ) +: BLKDTY 0x3a RAM+ ; +: BLK( 0x3c RAM+ @ ; +: BLK) BLK( 1024 + ; diff --git a/blk/373 b/blk/373 index dc2b3bf..89f4193 100644 --- a/blk/373 +++ b/blk/373 @@ -1,13 +1,9 @@ -: DOES> - ( Overwrite cellWord in CURRENT ) - 3 ( does ) 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$ + H@ 0x3c ( BLK(* ) RAM+ ! + 1024 ALLOT + ( LOAD detects end of block with ASCII EOT. This is why + we write it there. ) + EOT, + 0 BLKDTY ! + -1 BLK> ! ; -: CONSTANT CREATE , DOES> @ ; diff --git a/blk/374 b/blk/374 index 5919535..9cd31f9 100644 --- a/blk/374 +++ b/blk/374 @@ -1,4 +1,14 @@ -: [IF] - IF EXIT THEN - LIT" [THEN]" BEGIN DUP WORD S= UNTIL DROP ; -: [THEN] ; +: BLK! ( -- ) + BLK> @ BLK!* @ EXECUTE + 0 BLKDTY ! ; +: FLUSH BLKDTY @ IF BLK! THEN ; +: BLK@ ( n -- ) + DUP BLK> @ = IF DROP EXIT THEN + FLUSH DUP BLK> ! BLK@* @ EXECUTE ; +: BLK!! 1 BLKDTY ! ; +: WIPE BLK( 1024 0 FILL BLK!! ; +: WIPED? ( -- f ) + 1 ( f ) BLK) BLK( DO + I C@ IF DROP 0 ( f ) LEAVE THEN LOOP ; +: COPY ( src dst -- ) + FLUSH SWAP BLK@ BLK> ! BLK! ; diff --git a/blk/375 b/blk/375 new file mode 100644 index 0000000..514c5bd --- /dev/null +++ b/blk/375 @@ -0,0 +1,16 @@ +: _ + 999 SWAP ( stop indicator ) + BEGIN + ?DUP NOT IF EXIT THEN + 10 /MOD ( r q ) + SWAP '0' + SWAP ( d q ) + AGAIN ; +: . ( n -- ) + ?DUP NOT IF '0' EMIT EXIT THEN ( 0 is a special case ) + ( handle negative ) + DUP 0< IF '-' EMIT -1 * THEN + _ + BEGIN + DUP '9' > IF DROP EXIT THEN ( stop indicator ) + EMIT + AGAIN ; diff --git a/blk/376 b/blk/376 index 180249e..e5f9b51 100644 --- a/blk/376 +++ b/blk/376 @@ -1,10 +1,16 @@ -( n -- Fetches block n and write it to BLK( ) -: BLK@* 0x34 RAM+ ; -( n -- Write back BLK( to storage at block n ) -: BLK!* 0x36 RAM+ ; -( Current blk pointer in ( ) -: BLK> 0x38 RAM+ ; -( Whether buffer is dirty ) -: BLKDTY 0x3a RAM+ ; -: BLK( 0x3c RAM+ @ ; -: BLK) BLK( 1024 + ; +: ? @ . ; +: _ + 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 +; diff --git a/blk/377 b/blk/377 index 89f4193..31b564d 100644 --- a/blk/377 +++ b/blk/377 @@ -1,9 +1,13 @@ -: BLK$ - H@ 0x3c ( BLK(* ) RAM+ ! - 1024 ALLOT - ( LOAD detects end of block with ASCII EOT. This is why - we write it there. ) - EOT, - 0 BLKDTY ! - -1 BLK> ! +: _ ( a -- a+8 ) + DUP ( a a ) + ':' EMIT DUP .x SPC + 4 0 DO DUP @ 256 /MOD SWAP .x .x SPC 2+ LOOP + DROP ( a ) + 8 0 DO + C@+ DUP 0x20 0x7e =><= NOT IF DROP '.' THEN EMIT + LOOP NL ; +: DUMP ( n a -- ) + LF + SWAP 8 /MOD SWAP IF 1+ THEN + 0 DO _ LOOP ; diff --git a/blk/378 b/blk/378 index 9cd31f9..e88f70c 100644 --- a/blk/378 +++ b/blk/378 @@ -1,14 +1,13 @@ -: BLK! ( -- ) - BLK> @ BLK!* @ EXECUTE - 0 BLKDTY ! ; -: FLUSH BLKDTY @ IF BLK! THEN ; -: BLK@ ( n -- ) - DUP BLK> @ = IF DROP EXIT THEN - FLUSH DUP BLK> ! BLK@* @ EXECUTE ; -: BLK!! 1 BLKDTY ! ; -: WIPE BLK( 1024 0 FILL BLK!! ; -: WIPED? ( -- f ) - 1 ( f ) BLK) BLK( DO - I C@ IF DROP 0 ( f ) LEAVE THEN LOOP ; -: COPY ( src dst -- ) - FLUSH SWAP BLK@ BLK> ! BLK! ; +( handle backspace: go back one char in IN>, if possible, then + emit BS + SPC + BS ) +: _bs + ( already at IN( ? ) + IN> @ IN( = IF EXIT THEN + IN> @ 1- IN> ! + BS SPC BS +; +( del is same as backspace ) +: BS? DUP 0x7f = SWAP 0x8 = OR ; +SYSVARS 0x55 + :** KEY +( cont.: read one char into input buffer and returns whether we + should continue, that is, whether CR was not met. ) diff --git a/blk/388 b/blk/379 similarity index 100% rename from blk/388 rename to blk/379 diff --git a/blk/380 b/blk/380 index 171c335..96de653 100644 --- a/blk/380 +++ b/blk/380 @@ -1 +1,16 @@ -1 20 LOADR+ ( xcomp core high ) +( Read one line in input buffer and make IN> point to it ) +: (rdln) + ( EOT or less triggers line flush ) + (infl) BEGIN (rdlnc) 5 < 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 @ C@ 0 > 0x06 RAM+ ! ( 06 == C IF DROP EXIT THEN ( stop indicator ) - EMIT + WORD DUP @ 0x0401 = ( EOT ) IF DROP EXIT THEN + FIND NOT IF (parse) ELSE EXECUTE THEN + C 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 -; +: LOAD + BLK> @ >R ( save restorable variables to RSP ) + 0x08 RAM+ @ >R ( 08 == C<* override ) + 0x06 RAM+ @ >R ( CR ( boot ptr ) + BLK@ + BLK( 0x2e RAM+ ! ( Point to beginning of BLK ) + ['] (boot<) 0x08 RAM+ ! + 1 0x06 RAM+ ! ( 06 == C 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 ; diff --git a/blk/385 b/blk/385 index 31b564d..2bc6057 100644 --- a/blk/385 +++ b/blk/385 @@ -1,13 +1,15 @@ -: _ ( a -- a+8 ) - DUP ( a a ) - ':' EMIT DUP .x SPC - 4 0 DO DUP @ 256 /MOD SWAP .x .x SPC 2+ LOOP - DROP ( a ) - 8 0 DO - C@+ DUP 0x20 0x7e =><= NOT IF DROP '.' THEN EMIT - LOOP NL ; -: DUMP ( n a -- ) - LF - SWAP 8 /MOD SWAP IF 1+ THEN - 0 DO _ LOOP -; +: LOAD+ BLK> @ + LOAD ; +( b1 b2 -- ) +: LOADR 1+ SWAP DO I DUP . NL LOAD LOOP ; +: LOADR+ BLK> @ + SWAP BLK> @ + SWAP LOADR ; +( Now, adev stuff ) +SYSVARS 0x3e + :** A@ +SYSVARS 0x40 + :** A! + +( src dst u -- ) +: AMOVE + ( u ) 0 DO + SWAP DUP I + A@ ( dst src x ) + ROT TUCK I + ( src dst x dst ) + A! ( src dst ) + LOOP 2DROP ; diff --git a/blk/395 b/blk/386 similarity index 100% rename from blk/395 rename to blk/386 diff --git a/blk/387 b/blk/387 deleted file mode 100644 index e88f70c..0000000 --- a/blk/387 +++ /dev/null @@ -1,13 +0,0 @@ -( handle backspace: go back one char in IN>, if possible, then - emit BS + SPC + BS ) -: _bs - ( already at IN( ? ) - IN> @ IN( = IF EXIT THEN - IN> @ 1- IN> ! - BS SPC BS -; -( del is same as backspace ) -: BS? DUP 0x7f = SWAP 0x8 = OR ; -SYSVARS 0x55 + :** KEY -( cont.: read one char into input buffer and returns whether we - should continue, that is, whether CR was not met. ) diff --git a/blk/389 b/blk/389 deleted file mode 100644 index 96de653..0000000 --- a/blk/389 +++ /dev/null @@ -1,16 +0,0 @@ -( Read one line in input buffer and make IN> point to it ) -: (rdln) - ( EOT or less triggers line flush ) - (infl) BEGIN (rdlnc) 5 < 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 @ C@ 0 > 0x06 RAM+ ! ( 06 == C IF LIT" br ovfl" (print) ABORT THEN ; +: DO COMPILE 2>R H@ ; IMMEDIATE +: LOOP COMPILE (loop) H@ - _bchk C, ; IMMEDIATE +( LEAVE is implemented in low xcomp ) +: LITN COMPILE (n) , ; +( gets its name at the very end. can't comment afterwards ) +: _ BEGIN LIT" )" WORD S= UNTIL ; IMMEDIATE +: _ ( : will get its name almost at the very end ) + (entry) 1 ( compiled ) C, BEGIN - WORD DUP @ 0x0401 = ( EOT ) IF DROP EXIT THEN - FIND NOT IF (parse) ELSE EXECUTE THEN - C @ >R ( save restorable variables to RSP ) - 0x08 RAM+ @ >R ( 08 == C<* override ) - 0x06 RAM+ @ >R ( CR ( boot ptr ) - BLK@ - BLK( 0x2e RAM+ ! ( Point to beginning of BLK ) - ['] (boot<) 0x08 RAM+ ! - 1 0x06 RAM+ ! ( 06 == C 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 ; +: IF ( -- a | a: br cell addr ) + COMPILE (?br) H@ 1 ALLOT ( br cell allot ) +; IMMEDIATE +: THEN ( a -- | a: br cell addr ) + DUP H@ -^ _bchk SWAP ( a-H a ) C! +; IMMEDIATE +: ELSE ( a1 -- a2 | a1: IF cell a2: ELSE cell ) + COMPILE (br) + 1 ALLOT + [COMPILE] THEN + H@ 1- ( push a. 1- for allot offset ) +; IMMEDIATE +: LIT" + COMPILE (s) H@ 0 C, ," + DUP H@ -^ 1- ( a len ) SWAP C! +; IMMEDIATE diff --git a/blk/394 b/blk/394 index 2bc6057..6bc303f 100644 --- a/blk/394 +++ b/blk/394 @@ -1,15 +1,13 @@ -: LOAD+ BLK> @ + LOAD ; -( b1 b2 -- ) -: LOADR 1+ SWAP DO I DUP . NL LOAD LOOP ; -: LOADR+ BLK> @ + SWAP BLK> @ + SWAP LOADR ; -( Now, adev stuff ) -SYSVARS 0x3e + :** A@ -SYSVARS 0x40 + :** A! - -( src dst u -- ) -: AMOVE - ( u ) 0 DO - SWAP DUP I + A@ ( dst src x ) - ROT TUCK I + ( src dst x dst ) - A! ( src dst ) - LOOP 2DROP ; +( We don't use ." and ABORT in core, they're not xcomp-ed ) +: ." [COMPILE] LIT" COMPILE (print) ; IMMEDIATE +: ABORT" [COMPILE] ." COMPILE ABORT ; IMMEDIATE +: BEGIN H@ ; IMMEDIATE +: AGAIN COMPILE (br) H@ - _bchk C, ; IMMEDIATE +: UNTIL COMPILE (?br) H@ - _bchk C, ; IMMEDIATE +: [ INTERPRET ; IMMEDIATE +: ] R> DROP ; +: COMPILE ' LITN ['] , , ; IMMEDIATE +: [COMPILE] ' , ; IMMEDIATE +: ['] ' LITN ; IMMEDIATE +':' X' _ 4 - C! ( give : its name ) +'(' X' _ 4 - C! diff --git a/blk/396 b/blk/396 deleted file mode 100644 index ecf67a3..0000000 --- a/blk/396 +++ /dev/null @@ -1,16 +0,0 @@ -: (main) INTERPRET BYE ; -: BOOT - 0x02 RAM+ CURRENT* ! - CURRENT @ 0x2e RAM+ ! ( 2e == BOOT C< PTR ) - 0 0x08 RAM+ ! ( 08 == C<* override ) - ['] (emit) ['] EMIT **! - ['] (key) ['] KEY **! - ['] CRLF ['] NL **! - ( 0c == C<* ) - ['] (boot<) ['] C<* **! - ['] C@ ['] A@ ! ['] C! ['] A! **! - ( boot< always has a char waiting. 06 == C IF LIT" br ovfl" (print) ABORT THEN ; -: DO COMPILE 2>R H@ ; IMMEDIATE -: LOOP COMPILE (loop) H@ - _bchk C, ; IMMEDIATE -( LEAVE is implemented in low xcomp ) -: LITN COMPILE (n) , ; -( gets its name at the very end. can't comment afterwards ) -: _ BEGIN LIT" )" WORD S= UNTIL ; IMMEDIATE -: _ ( : will get its name almost at the very end ) - (entry) 1 ( compiled ) C, - BEGIN - WORD DUP LIT" ;" S= IF DROP COMPILE EXIT EXIT THEN - FIND IF ( is word ) DUP IMMED? IF EXECUTE ELSE , THEN - ELSE ( maybe number ) (parse) LITN THEN - AGAIN ; diff --git a/blk/399 b/blk/399 deleted file mode 100644 index 8afba32..0000000 --- a/blk/399 +++ /dev/null @@ -1,16 +0,0 @@ -: IF ( -- a | a: br cell addr ) - COMPILE (?br) H@ 1 ALLOT ( br cell allot ) -; IMMEDIATE -: THEN ( a -- | a: br cell addr ) - DUP H@ -^ _bchk SWAP ( a-H a ) C! -; IMMEDIATE -: ELSE ( a1 -- a2 | a1: IF cell a2: ELSE cell ) - COMPILE (br) - 1 ALLOT - [COMPILE] THEN - H@ 1- ( push a. 1- for allot offset ) -; IMMEDIATE -: LIT" - COMPILE (s) H@ 0 C, ," - DUP H@ -^ 1- ( a len ) SWAP C! -; IMMEDIATE diff --git a/blk/400 b/blk/400 deleted file mode 100644 index 6bc303f..0000000 --- a/blk/400 +++ /dev/null @@ -1,13 +0,0 @@ -( We don't use ." and ABORT in core, they're not xcomp-ed ) -: ." [COMPILE] LIT" COMPILE (print) ; IMMEDIATE -: ABORT" [COMPILE] ." COMPILE ABORT ; IMMEDIATE -: BEGIN H@ ; IMMEDIATE -: AGAIN COMPILE (br) H@ - _bchk C, ; IMMEDIATE -: UNTIL COMPILE (?br) H@ - _bchk C, ; IMMEDIATE -: [ INTERPRET ; IMMEDIATE -: ] R> DROP ; -: COMPILE ' LITN ['] , , ; IMMEDIATE -: [COMPILE] ' , ; IMMEDIATE -: ['] ' LITN ; IMMEDIATE -':' X' _ 4 - C! ( give : its name ) -'(' X' _ 4 - C! diff --git a/cvm/forth.bin b/cvm/forth.bin index a9e9fe2e8264ba2deb5514b696432fcd88eb38b1..a7ccd5b1f4925fb39072d0b08bcfa32dd9abf8bf 100644 GIT binary patch delta 447 zcmYk2JxBvV5QS$pIg=c>w-@oB3!)N}SR_OVViY8Y8o{5Sg$5g=pb#*EkkT^P>w*%S zU}Yzw5D>viEVQ!_TLTsff{mSuv;Kg^!nezNJMYa~_$_=~Fk~;E?$|I&;J^TQT`|yh z!G>#h5MFE;P6A>V?i=!e502H0YqvT!M6<2H&;h_^)Va=WSTsqgK1q_d1Ue6C4!A*L z4ocAVE3MGGE<4Q`?3YEeV83(a(BYNEz_UxpN&LVm!#S59W*mJoCgN<>l*^)zZJBaU z1Q~_75H0M>KN^<3oj(=JXZDqkt1^o`Zb46{mpM<7JRXFk}ic^JcOHmI| UndpD1GxKz){stL+>T6j00vGXSNdN!< delta 414 zcmYk2JxBvV5QS&fyTqT{y*-T)%M1_PP5s5Y)Vif=IhbV$Z3yX+nB{mVUh>h)n zkV4X#E{fI>(xixBAcd8cU}s^IE}(ls!D5z=$Gm-ysR!%9dq?vI51iD=aJOjiC*f$z zWSokkW|1TnZ`$N+o>mlhObBiD0zn%9d$3BY)Py7h#0=OFgNl-YDh;SMC?IeTGBEhN znv;4}?9f$gh&$?-CFVNX;fsX9do7X5fhuxw895kn3cJnCi%Gd)|ad_m)@1>nKcfoG~{3p z;<9y;M%6SIDc(;kLtOEImN3rXp(Tz4cMVbG1A~7;7Hds02JdAsA?WO