From f023f9bcb4f62f6bf5e20a237e1f772859fcda49 Mon Sep 17 00:00:00 2001 From: Virgil Dupras Date: Sat, 2 May 2020 21:47:32 -0400 Subject: [PATCH] Pack core words blks a bit tighter With all this recent movements, we had a bit of a fragmentation issue. --- blk/420 | 7 +++---- blk/438 | 13 +++++++++++++ blk/439 | 16 ++++++++++++++++ blk/440 | 9 +++++++++ blk/442 | 27 +++++++++++++++------------ blk/443 | 32 ++++++++++++++++---------------- blk/444 | 25 ++++++++++++++++--------- blk/{462 => 445} | 0 blk/447 | 13 +++++++++++++ blk/448 | 16 ++++++++++++++++ blk/449 | 16 ++++++++++++++++ blk/450 | 16 ++++++++++++++++ blk/451 | 12 ++++++++++++ blk/453 | 22 +++++++++++----------- blk/454 | 22 +++++++++------------- blk/455 | 29 +++++++++++++---------------- blk/456 | 23 +++++++++-------------- blk/457 | 24 ++++++++++++++---------- blk/{469 => 458} | 0 blk/459 | 18 ++---------------- blk/460 | 16 ---------------- blk/461 | 16 ---------------- blk/464 | 13 ------------- blk/465 | 12 ------------ blk/466 | 13 ------------- blk/467 | 11 ----------- blk/468 | 16 ---------------- blk/470 | 2 -- emul/forth.bin | Bin 5642 -> 5642 bytes emul/xcomp.fs | 2 +- recipes/rc2014/xcomp.fs | 6 ++---- recipes/trs80/xcomp.fs | 2 +- 32 files changed, 223 insertions(+), 226 deletions(-) create mode 100644 blk/438 create mode 100644 blk/439 create mode 100644 blk/440 rename blk/{462 => 445} (100%) create mode 100644 blk/447 create mode 100644 blk/448 create mode 100644 blk/449 create mode 100644 blk/450 create mode 100644 blk/451 rename blk/{469 => 458} (100%) delete mode 100644 blk/460 delete mode 100644 blk/461 delete mode 100644 blk/464 delete mode 100644 blk/465 delete mode 100644 blk/466 delete mode 100644 blk/467 delete mode 100644 blk/468 delete mode 100644 blk/470 diff --git a/blk/420 b/blk/420 index 1c4f0ca..991ea67 100644 --- a/blk/420 +++ b/blk/420 @@ -8,7 +8,6 @@ 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 +422 core 438 print +442 fmt 447 readln +453 blk diff --git a/blk/438 b/blk/438 new file mode 100644 index 0000000..0da95a7 --- /dev/null +++ b/blk/438 @@ -0,0 +1,13 @@ +: EMIT + ( 0x53==(emit) override ) + 83 RAM+ @ DUP IF EXECUTE ELSE DROP (emit) THEN ; + +: (print) + BEGIN + C@+ ( a+1 c ) + ( exit if null ) + DUP NOT IF 2DROP EXIT THEN + EMIT ( a ) + AGAIN +; + diff --git a/blk/439 b/blk/439 new file mode 100644 index 0000000..6abc49d --- /dev/null +++ b/blk/439 @@ -0,0 +1,16 @@ +: ," + 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" ; + diff --git a/blk/440 b/blk/440 new file mode 100644 index 0000000..d4bad68 --- /dev/null +++ b/blk/440 @@ -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 ; + diff --git a/blk/442 b/blk/442 index 0da95a7..f3850c0 100644 --- a/blk/442 +++ b/blk/442 @@ -1,13 +1,16 @@ -: EMIT - ( 0x53==(emit) override ) - 83 RAM+ @ DUP IF EXECUTE ELSE DROP (emit) THEN ; - -: (print) +: _ + 999 SWAP ( stop indicator ) + DUP 0 = IF '0' EXIT THEN ( 0 is a special case ) BEGIN - C@+ ( a+1 c ) - ( exit if null ) - DUP NOT IF 2DROP EXIT THEN - EMIT ( a ) - AGAIN -; - + 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 ; diff --git a/blk/443 b/blk/443 index 6abc49d..e5f9b51 100644 --- a/blk/443 +++ b/blk/443 @@ -1,16 +1,16 @@ -: ," - 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" ; - +: ? @ . ; +: _ + 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/444 b/blk/444 index d4bad68..cbc4472 100644 --- a/blk/444 +++ b/blk/444 @@ -1,9 +1,16 @@ -: 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 ; - +: _ ( 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 < OVER 0x7e > OR + IF DROP '.' THEN + EMIT + LOOP + CRLF +; diff --git a/blk/462 b/blk/445 similarity index 100% rename from blk/462 rename to blk/445 diff --git a/blk/447 b/blk/447 new file mode 100644 index 0000000..f436650 --- /dev/null +++ b/blk/447 @@ -0,0 +1,13 @@ +64 CONSTANT INBUFSZ +: RDLNMEM+ 0x57 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> ! ! ; + diff --git a/blk/448 b/blk/448 new file mode 100644 index 0000000..f3eb716 --- /dev/null +++ b/blk/448 @@ -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 +; + +: KEY + 85 RAM+ @ ( (key) override ) + DUP IF EXECUTE ELSE DROP (key) THEN ; + + +( cont.: read one char into input buffer and returns whether we + should continue, that is, whether CR was not met. ) diff --git a/blk/449 b/blk/449 new file mode 100644 index 0000000..2412b93 --- /dev/null +++ b/blk/449 @@ -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 ; diff --git a/blk/450 b/blk/450 new file mode 100644 index 0000000..949c155 --- /dev/null +++ b/blk/450 @@ -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 @ C@ 0 > 0x06 RAM+ ! ( 06 == C, 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 0 RDLNMEM+ ; -( points to INBUF ) -: IN( 2 RDLNMEM+ ; -( points to INBUF's end ) -: IN) INBUFSZ 2+ RDLNMEM+ ; +: BLKMEM+ 0x59 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) BLK( 1024 + ; -( flush input buffer ) -( set IN> to IN( and set IN> @ to null ) -: (infl) 0 IN( DUP IN> ! ! ; diff --git a/blk/454 b/blk/454 index f3eb716..2ba2b0a 100644 --- a/blk/454 +++ b/blk/454 @@ -1,16 +1,12 @@ -( 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 +: BLK$ + H@ 0x59 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> ! ; -: KEY - 85 RAM+ @ ( (key) override ) - DUP IF EXECUTE ELSE DROP (key) THEN ; - -( cont.: read one char into input buffer and returns whether we - should continue, that is, whether CR was not met. ) diff --git a/blk/455 b/blk/455 index 2412b93..6b1063e 100644 --- a/blk/455 +++ b/blk/455 @@ -1,16 +1,13 @@ -: (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! ( -- ) + BLK> @ BLK!* @ EXECUTE + 0 BLKDTY ! +; +: FLUSH BLKDTY @ IF BLK! THEN ; +: BLK@ ( n -- ) + FLUSH + DUP BLK> @ = IF DROP EXIT THEN + DUP BLK> ! BLK@* @ EXECUTE +; + +: BLK!! 1 BLKDTY ! ; + diff --git a/blk/456 b/blk/456 index 949c155..5378b08 100644 --- a/blk/456 +++ b/blk/456 @@ -1,16 +1,11 @@ -( Read one line in input buffer and make IN> point to it ) -: (rdln) - (infl) BEGIN (rdlnc) NOT UNTIL - LF IN( IN> ! ; +: .2 DUP 10 < IF SPC THEN . ; -( 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, 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 IF DROP EXIT THEN ( stop indicator ) - EMIT - AGAIN ; +( b1 b2 -- ) +: LOADR 1+ SWAP DO I DUP . CRLF LOAD LOOP ; diff --git a/blk/460 b/blk/460 deleted file mode 100644 index e5f9b51..0000000 --- a/blk/460 +++ /dev/null @@ -1,16 +0,0 @@ -: ? @ . ; -: _ - 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/461 b/blk/461 deleted file mode 100644 index cbc4472..0000000 --- a/blk/461 +++ /dev/null @@ -1,16 +0,0 @@ -: _ ( 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 < OVER 0x7e > OR - IF DROP '.' THEN - EMIT - LOOP - CRLF -; diff --git a/blk/464 b/blk/464 deleted file mode 100644 index a7f9e3a..0000000 --- a/blk/464 +++ /dev/null @@ -1,13 +0,0 @@ -: BLKMEM+ 0x59 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) BLK( 1024 + ; - - diff --git a/blk/465 b/blk/465 deleted file mode 100644 index 2ba2b0a..0000000 --- a/blk/465 +++ /dev/null @@ -1,12 +0,0 @@ -: BLK$ - H@ 0x59 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> ! -; - - diff --git a/blk/466 b/blk/466 deleted file mode 100644 index 6b1063e..0000000 --- a/blk/466 +++ /dev/null @@ -1,13 +0,0 @@ -: BLK! ( -- ) - BLK> @ BLK!* @ EXECUTE - 0 BLKDTY ! -; -: FLUSH BLKDTY @ IF BLK! THEN ; -: BLK@ ( n -- ) - FLUSH - DUP BLK> @ = IF DROP EXIT THEN - DUP BLK> ! BLK@* @ EXECUTE -; - -: BLK!! 1 BLKDTY ! ; - diff --git a/blk/467 b/blk/467 deleted file mode 100644 index 5378b08..0000000 --- a/blk/467 +++ /dev/null @@ -1,11 +0,0 @@ -: .2 DUP 10 < IF SPC THEN . ; - -: LIST - BLK@ - 16 0 DO - I 1+ .2 SPC - 64 I * BLK( + (print) - CRLF - LOOP -; - diff --git a/blk/468 b/blk/468 deleted file mode 100644 index e53efae..0000000 --- a/blk/468 +++ /dev/null @@ -1,16 +0,0 @@ -: _ - (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. ) diff --git a/blk/470 b/blk/470 deleted file mode 100644 index 29bb9b5..0000000 --- a/blk/470 +++ /dev/null @@ -1,2 +0,0 @@ -( b1 b2 -- ) -: LOADR 1+ SWAP DO I DUP . CRLF LOAD LOOP ; diff --git a/emul/forth.bin b/emul/forth.bin index fd113c766b6500f8decb09ab0f8f9aee64ba5c50..6a5486e510d971ac87803631db4539bdd1157c07 100644 GIT binary patch delta 438 zcmX9*Jxc>Y5S`sSHAKDLIgOwe9;leppiQs{+8inv6AKeRuu&u$6tPgelmR)L2o~8w z2sS~qu@Nj%=`Ya2!pcqrOM4N{*`!!z-|XA>-t1NqmBhoV;9EkSW1hbW^?^fNO7(}c zOBq?W^zvYGqaV2C0I(14OJ91hWdXBl%z+ftsrvFlIAB8BY_O_PHEK*4Eqa5_e5nHa zVBkhJ=t2bUc!TBOEA(J-*;`%6ZH}vV5#KDJZp5QtkQ0X%bh`-V@zT^VzJIiL=n81J z(q@1)R>F{nyxHG5abwgkp)dl>wiPLh2O5>l5~_8X?9)IskD}l}6mmrQL{*o`-6zu4 zYQhNl8u4E`^<>?kb=u*crA_iUE*u`Yr{r;q9rhV7!f&`O0@N8iSeeT#&kR6YGr$y$ zUxY4bNok+5O(9Y^n#iMmr7Ql^d5a@(Z97DJFtw{gPI~8oms!frXD6l~BRzwR{^Dk| QR~I!Fd**Mp`i>3%1LFB)#Q*>R delta 417 zcmX9)J4gdT6nwjP`H;lhz0(UA!5nDxPR~z~N)%+#Kw^?2iDJ?yVhl=1p;!wxLJFHL zgmgi$u?bkDv$XQl2q|oZl=j!0yGgOUoj0>H!?xYF+xsBlY?19}$~BXhbh|br46;Q# z0*Yn(q!We=!)qY zyhjtNk?=zM6-{R6gJ BVy6HA diff --git a/emul/xcomp.fs b/emul/xcomp.fs index 9cb12d2..dced41e 100644 --- a/emul/xcomp.fs +++ b/emul/xcomp.fs @@ -17,6 +17,6 @@ H@ 256 /MOD 2 PC! 2 PC! PC ORG @ 8 + ! ," CURRENT @ HERE ! " ," : (emit) 0 PC! ; : (key) 0 PC@ ; " -422 470 XPACKR +422 459 XPACKR ," ' (key) 12 RAM+ ! " H@ 256 /MOD 2 PC! 2 PC! diff --git a/recipes/rc2014/xcomp.fs b/recipes/rc2014/xcomp.fs index 0dce60c..87271db 100644 --- a/recipes/rc2014/xcomp.fs +++ b/recipes/rc2014/xcomp.fs @@ -23,11 +23,9 @@ H@ 256 /MOD 2 PC! 2 PC! (entry) _ ( Update LATEST ) PC ORG @ 8 + ! -422 441 XPACKR ( core ) -446 452 XPACKR ( parse ) +422 437 XPACKR ( core ) 358 360 XPACKR ( acia.fs ) -442 445 XPACKR ( print ) -453 463 XPACKR ( readln fmt ) +438 452 XPACKR ( print fmt readln ) 123 132 XPACKR ( linker ) ," : _ ACIA$ RDLN$ (ok) ; _ " H@ 256 /MOD 2 PC! 2 PC! diff --git a/recipes/trs80/xcomp.fs b/recipes/trs80/xcomp.fs index e76d983..f2b0330 100644 --- a/recipes/trs80/xcomp.fs +++ b/recipes/trs80/xcomp.fs @@ -18,7 +18,7 @@ H@ 256 /MOD 2 PC! 2 PC! ( Update LATEST ) PC ORG @ 8 + ! ," CURRENT @ HERE ! " -422 470 XPACKR ( core cmp print parse readln fmt blk ) +422 459 XPACKR ( core print readln fmt blk ) 499 500 XPACKR ( trs80.fs ) ," : _ BLK$ FD$ (ok) RDLN$ ; _ " H@ 256 /MOD 2 PC! 2 PC!