From 527f5977d711b637b2b73945b7c99b99ef27699f Mon Sep 17 00:00:00 2001 From: Virgil Dupras Date: Sat, 2 Jan 2021 10:19:42 -0500 Subject: [PATCH] Add BS, CR, LF, SPC ASCII consts Previously, these words would be ascii emitters, but seldom used except for the SPC emitter. However, I would often end up hardcoding these constants. With useless emitters removed and ASCII constants added, we have a more usable system. Also, fix broken test harness. --- arch/z80/trs80/xcomp.fs | 2 +- blk.fs | 74 ++++++++++++++++++++-------------------- cvm/stage.bin | Bin 4962 -> 4988 bytes doc/dict.txt | 5 ++- tests/harness.fs | 6 ++-- 5 files changed, 45 insertions(+), 42 deletions(-) diff --git a/arch/z80/trs80/xcomp.fs b/arch/z80/trs80/xcomp.fs index ee37f89..f0d37ec 100644 --- a/arch/z80/trs80/xcomp.fs +++ b/arch/z80/trs80/xcomp.fs @@ -15,6 +15,6 @@ RS_ADDR 0x80 - CONSTANT SYSVARS ( Update LATEST ) PC ORG @ 8 + ! ( TRS-80 wants CR-only newlines ) -," 13 0x50 RAM+ C! BLK$ FD$ " EOT, +," CR 0x50 RAM+ C! BLK$ FD$ " EOT, ORG @ |M 2 PC! 2 PC! H@ |M 2 PC! 2 PC! diff --git a/blk.fs b/blk.fs index 78ddd74..32e2727 100644 --- a/blk.fs +++ b/blk.fs @@ -450,7 +450,7 @@ VARIABLE L1 VARIABLE L2 VARIABLE L3 VARIABLE L4 ( We divide by 2 because each PC represents a word. ) : PC H@ ORG @ - 1 RSHIFT ; ( ----- 052 ) -: _oor ." arg out of range: " .X SPC ." PC: " PC .X NL> ABORT ; +: _oor ." arg out of range: " .X SPC> ." PC: " PC .X NL> ABORT ; : _r8c DUP 7 > IF _oor THEN ; : _r32c DUP 31 > IF _oor THEN ; : _r16+c _r32c DUP 16 < IF _oor THEN ; @@ -624,13 +624,13 @@ CREATE FBUF 64 ALLOT0 : _pln ( lineno -- ) DUP _lpos DUP 64 + SWAP DO ( lno ) I EDPOS @ _cpos = IF '^' EMIT THEN - I C@ DUP 0x20 < IF DROP 0x20 THEN + I C@ DUP SPC < IF DROP SPC THEN EMIT LOOP ( lno ) 1+ . ; : _zbuf 64 0 FILL ; ( buf -- ) ( ----- 108 ) : _type ( buf -- ) - C< DUP 0xd = IF 2DROP EXIT THEN SWAP DUP _zbuf ( c a ) + C< DUP CR = IF 2DROP EXIT THEN SWAP DUP _zbuf ( c a ) BEGIN ( c a ) C!+ C< TUCK 0x0d = UNTIL ( c a ) C! ; ( user-facing lines are 1-based ) : T 1- DUP 64 * EDPOS ! _pln ; @@ -654,19 +654,19 @@ CREATE FBUF 64 ALLOT0 BEGIN C@+ ROT ( a2+1 c2 a1 ) C@+ ROT ( a2+1 a1+1 c1 c2 ) = NOT IF DROP FBUF THEN ( a2 a1 ) - TUCK C@ 0xd = ( a1 a2 f1 ) + TUCK C@ CR = ( a1 a2 f1 ) OVER BLK) = OR ( a1 a2 f1|f2 ) UNTIL ( a1 a2 ) DUP BLK) < IF BLK( - FBUF + -^ EDPOS ! ELSE DROP THEN ; : F FBUF _type _F EDPOS @ 64 / _pln ; ( ----- 111 ) : _blen ( buf -- length of str in buf ) - DUP BEGIN C@+ 0x20 < UNTIL -^ 1- ; + DUP BEGIN C@+ SPC < UNTIL -^ 1- ; : _rbufsz ( size of linebuf to the right of curpos ) EDPOS @ 64 MOD 63 -^ ; : _lnfix ( --, ensure no ctl chars in line before EDPOS ) EDPOS @ DUP 0xffc0 AND 2DUP = IF 2DROP EXIT THEN DO - I _cpos DUP C@ 0x20 < IF 0x20 SWAP C! ELSE DROP THEN LOOP ; + I _cpos DUP C@ SPC < IF SPC SWAP C! ELSE DROP THEN LOOP ; : _i ( i without _pln and _type. used in VE ) _rbufsz IBUF _blen 2DUP > IF _lnfix TUCK - ( ilen chars-to-move ) @@ -781,17 +781,17 @@ CREATE PREVPOS 0 , CREATE PREVBLK 0 , CREATE xoff 0 , : width large? IF 64 ELSE COLS THEN ; : acc@ ACC @ 1 MAX ; : pos@ ( x y -- ) EDPOS @ 64 /MOD ; : num ACC @ SWAP _pdacc IF ACC ! ELSE DROP THEN ; -: nspcs ( n -- , spit n space ) 0 DO SPC LOOP ; +: nspcs ( n -- , spit n space ) 0 DO SPC> LOOP ; : aty 0 SWAP AT-XY ; -: clrscr COLS LINES * 0 DO 0x20 I CELL! LOOP ; +: clrscr COLS LINES * 0 DO SPC I CELL! LOOP ; : gutter ( ln n ) OVER + SWAP DO 67 I AT-XY '|' EMIT LOOP ; -: status 0 aty ." BLK" SPC BLK> ? SPC ACC ? - SPC pos@ . ',' EMIT . xoff @ IF '>' EMIT THEN SPC +: status 0 aty ." BLK" SPC> BLK> ? SPC> ACC ? + SPC> pos@ . ',' EMIT . xoff @ IF '>' EMIT THEN SPC> BLKDTY @ IF '*' EMIT THEN 4 nspcs ; -: nums 17 1 DO 2 I + aty I . SPC SPC LOOP ; +: nums 17 1 DO 2 I + aty I . SPC> SPC> LOOP ; ( ----- 127 ) : mode! ( c -- ) 4 col- CELL! ; -: @emit C@ 0x20 MAX 0x7f MIN EMIT ; +: @emit C@ SPC MAX 0x7f MIN EMIT ; : contents 16 0 DO large? IF 3 ELSE 0 THEN I 3 + AT-XY @@ -810,7 +810,7 @@ CREATE PREVPOS 0 , CREATE PREVBLK 0 , CREATE xoff 0 , : cmv ( n -- , char movement ) acc@ * EDPOS @ + pos! ; : buftype ( buf ln -- ) 3 OVER AT-XY KEY DUP EMIT - DUP 0x20 < IF 2DROP DROP EXIT THEN + DUP SPC < IF 2DROP DROP EXIT THEN ( buf ln c ) 4 col- nspcs SWAP 4 SWAP AT-XY ( buf c ) SWAP C!+ IN( _zbuf (rdln) IN( SWAP 63 MOVE ; : bufp ( buf -- ) @@ -824,8 +824,8 @@ CREATE PREVPOS 0 , CREATE PREVBLK 0 , CREATE xoff 0 , : $[ BLK> @ acc@ - selblk ; : $] BLK> @ acc@ + selblk ; : $t PREVBLK @ selblk ; -: $I 'I' mode! IBUF 1 buftype _i bufs contents 0x20 mode! ; -: $F 'F' mode! FBUF 2 buftype _F bufs setpos 0x20 mode! ; +: $I 'I' mode! IBUF 1 buftype _i bufs contents SPC mode! ; +: $F 'F' mode! FBUF 2 buftype _F bufs setpos SPC mode! ; : $Y Y bufs ; : $E _E bufs contents ; : $X acc@ _X bufs contents ; @@ -855,9 +855,9 @@ CREATE PREVPOS 0 , CREATE PREVBLK 0 , CREATE xoff 0 , : $R ( replace mode ) 'R' mode! BEGIN setpos KEY DUP BS? IF -1 EDPOS +! DROP 0 THEN - DUP 0x20 >= IF + DUP SPC >= IF DUP EMIT EDPOS @ _cpos C! 1 EDPOS +! BLK!! 0 - THEN UNTIL 0x20 mode! contents ; + THEN UNTIL SPC mode! contents ; : $O _U EDPOS @ 0x3c0 AND DUP pos! _cpos _zbuf BLK!! contents ; : $o EDPOS @ 0x3c0 < IF EDPOS @ 64 + EDPOS ! $O THEN ; : $D $H 64 icpy @@ -927,7 +927,7 @@ VARIABLE aspprevx ROT TUCK + 0x10 - ( sz a end ) TUCK SWAP 0 ROT> ( sz end sum end a ) DO ( sz end sum ) I C@ + LOOP ( sz end sum ) SWAP ( sz sum end ) - 'T' C!+^ 'M' C!+^ 'R' C!+^ 0x20 C!+^ 'S' C!+^ + 'T' C!+^ 'M' C!+^ 'R' C!+^ SPC C!+^ 'S' C!+^ 'E' C!+^ 'G' C!+^ 'A' C!+^ 0 C!+^ 0 C!+^ ( sum's LSB ) OVER C!+^ ( MSB ) SWAP 8 RSHIFT OVER C! 1+ ( sz end ) 0 C!+^ 0 C!+^ 0 C!+^ SWAP 0x4a + SWAP C! ; @@ -1717,7 +1717,7 @@ with "390 LOAD" ( ----- 356 ) SYSVARS 0x53 + :** EMIT : STYPE C@+ ( a len ) 0 DO C@+ EMIT LOOP DROP ; -: BS 8 EMIT ; : SPC 32 EMIT ; +: BS 0x8 ; : LF 0xa ; : CR 0xd ; : SPC 0x20 ; : SPC> SPC EMIT ; : NL> 0x50 RAM+ C@ ?DUP IF EMIT ELSE 13 EMIT 10 EMIT THEN ; : ERR STYPE ABORT ; : (uflw) LIT" stack underflow" ERR ; @@ -1962,11 +1962,11 @@ SYSVARS 0x0c + :** C<* ( ----- 377 ) : _ ( a -- a+8 ) DUP ( a a ) - ':' EMIT DUP .x SPC - 4 0 DO DUP @ |L .x .x SPC 2+ LOOP + ':' EMIT DUP .x SPC> + 4 0 DO DUP @ |L .x .x SPC> 2+ LOOP DROP ( a ) 8 0 DO - C@+ DUP 0x20 0x7e =><= NOT IF DROP '.' THEN EMIT + C@+ DUP SPC 0x7e =><= NOT IF DROP '.' THEN EMIT LOOP NL> ; : DUMP ( n a -- ) SWAP 8 /MOD SWAP IF 1+ THEN @@ -1978,10 +1978,10 @@ SYSVARS 0x0c + :** C<* ( already at IN( ? ) IN> @ IN( = IF EXIT THEN IN> @ 1- IN> ! - BS SPC BS + BS EMIT SPC> BS EMIT ; ( del is same as backspace ) -: BS? DUP 0x7f = SWAP 0x8 = OR ; +: BS? DUP 0x7f = SWAP BS = OR ; SYSVARS 0x55 + :** KEY? : KEY BEGIN KEY? UNTIL ; ( cont.: read one char into input buffer and returns whether we @@ -1989,8 +1989,8 @@ SYSVARS 0x55 + :** KEY? ( ----- 379 ) : (rdlnc) ( -- c ) ( buffer overflow? same as if we typed a newline ) - IN> @ IN) = IF 0x0a ELSE KEY THEN ( c ) - DUP 0x0a = IF DROP 0xd THEN ( lf? same as cr ) + IN> @ IN) = IF LF ELSE KEY THEN ( c ) + DUP LF = IF DROP CR THEN ( lf? same as cr ) ( backspace? handle and exit ) DUP BS? IF _bs EXIT THEN ( echo back ) @@ -2001,7 +2001,7 @@ SYSVARS 0x55 + :** KEY? thus ! automatically null-terminates our string ) IN> @ ! 1 IN> +! ( c ) ( if newline, replace with zero to indicate EOL ) - DUP 0xd = IF DROP 0 THEN ; + DUP CR = IF DROP 0 THEN ; ( ----- 380 ) ( Read one line in input buffer and make IN> point to it ) : (rdln) @@ -2023,7 +2023,7 @@ SYSVARS 0x55 + :** KEY? : RDLN$ H@ 0x32 ( IN(* ) RAM+ ! ( plus 2 for extra bytes after buffer: 1 for - the last typed 0x0a and one for the following NULL. ) + the last typed LF and one for the following NULL. ) IN) IN( - ALLOT (infl) ['] RDLN< ['] C<* **! @@ -2033,7 +2033,7 @@ SYSVARS 0x55 + :** KEY? : LIST BLK@ 16 0 DO - I 1+ DUP 10 < IF SPC THEN . SPC + I 1+ DUP 10 < IF SPC> THEN . SPC> 64 I * BLK( + DUP 64 + SWAP DO I C@ DUP 0x1f > IF EMIT ELSE DROP LEAVE THEN LOOP @@ -2044,7 +2044,7 @@ SYSVARS 0x55 + :** KEY? BEGIN WORD DUP @ 0x0401 = ( EOT ) IF DROP EXIT THEN FIND NOT IF (parse) ELSE EXECUTE THEN - C THEN + C LIT" ok" STYPE NL> THEN AGAIN ; ( Read from BOOT C< PTR and inc it. ) : (boot<) @@ -2075,7 +2075,7 @@ SYSVARS 0x55 + :** KEY? ( ----- 385 ) : LOAD+ BLK> @ + LOAD ; ( b1 b2 -- ) -: LOADR 1+ SWAP DO I DUP . SPC LOAD LOOP ; +: LOADR 1+ SWAP DO I DUP . SPC> LOAD LOOP ; : LOADR+ BLK> @ + SWAP BLK> @ + SWAP LOADR ; ( ----- 390 ) ( xcomp core high ) @@ -2168,17 +2168,17 @@ Load range: B402-B403 : XYPOS! COLS LINES * MOD DUP XYPOS @ CURSOR! XYPOS ! ; : AT-XY ( x y -- ) COLS * + XYPOS! ; '? NEWLN NIP NOT [IF] -: NEWLN ( ln -- ) COLS * DUP COLS + SWAP DO 0x20 I CELL! LOOP ; +: NEWLN ( ln -- ) COLS * DUP COLS + SWAP DO SPC I CELL! LOOP ; [THEN] : _lf XYMODE C@ IF EXIT THEN XYPOS @ COLS / 1+ LINES MOD DUP NEWLN COLS * XYPOS! ; -: _bs 0x20 ( blank ) XYPOS @ TUCK CELL! ( pos ) 1- XYPOS! ; +: _bs SPC XYPOS @ TUCK CELL! ( pos ) 1- XYPOS! ; ( ----- 403 ) : (emit) - DUP 0x08 = IF DROP _bs EXIT THEN - DUP 0x0d = IF DROP _lf EXIT THEN - DUP 0x20 < IF DROP EXIT THEN + DUP BS? IF DROP _bs EXIT THEN + DUP CR = IF DROP _lf EXIT THEN + DUP SPC < IF DROP EXIT THEN XYPOS @ CELL! XYPOS @ 1+ DUP COLS MOD IF XYPOS! ELSE DROP _lf THEN ; : GRID$ 0 XYPOS ! 0 XYMODE C! ; @@ -2750,7 +2750,7 @@ them. We insert a blank one at the end of those 7. ) ( blank row ) 0xff _data ; : CELL! ( c pos ) 0x7800 OR _ctl ( tilenum ) - 0x20 - ( glyph ) 0x5f MOD _data ; + SPC - ( glyph ) 0x5f MOD _data ; ( ----- 472 ) : CURSOR! ( new old -- ) DUP 0x3800 OR _ctl [ TMS_DATAPORT LITN ] PC@ diff --git a/cvm/stage.bin b/cvm/stage.bin index 0d09fdcffa883437c38ad4e8466568c01e7eb609..8f91e1550e44adbaf7fff9dcdfddaaf890d8a078 100644 GIT binary patch delta 1853 zcmYjRZD>Ak`&IA3OPO{-5Q2N-d zlgu8;dD*1C#BL{lASVK?ib)NVM<-4<`pM3E$TdAPmN_1nJauI1=)~mdR=!^euvR{$ zjIb+wRr#K!`3Ls*`~iE2Y$h#~{(dX{-BK*!EbmocV)J}f-R50TvlOKoT9-nkTtXTv z{A+cae?>JZojjOKbs31t*(DN+f2c)TqNm)@f`bvw&mx*hLdS!&BU+wq(X#YZ4UzgS zC2_SxO)SqA)Fnh{p(0zCmf&KILiB5nBAUjo!m5c03wu(lC0m5gYtf2~HYu4@uMuMp zwIZ}_v;1c*p=pjN*+_HnR>#S}u*0O`BPV92&W!j-Wd$3zec>3B2Bjd=SV3LkD-K^< zMq7niXDZf_j+Fz)6L^qFU^~!}ig!d4u?o_d;uO+x6umo{+7nBAgeEtfuWv6vvoqN@ zknZS9*ISweb>10d2p#VpF@V~tXAjwj(|comBU#Gu&zv)CCvVWV%o!SIb-JHjVLrS~ ziY9uu)WXK62bqlD43+K?H!(P{_XSd*9uzLm>(AM=Z-Pyhgw_8|x~vOmf21{N+feOCEwL8ajYv+34n`iufCH%)cyKpJx9yB@OGYi%k~G_ z$^;{JQKfBz5qY_mem5x+Mni&ZoL?w=Wv)<`m&MPdmZ55J`!Ty+cDu}^!%ip(`!MC@ zEZr_E%2AR5bd<6bWNVgMQU08T>Ca10)2yq4ElZD}I7=sNqT#BzYJrC^J#c{kU4#4j z4**QgvZ!J?U9ch#UXIc_?=7#J%gaUirZqUxfk-`OO5`vHR_ExZye_SwM!m5^kt&jv zJOAQjhsure5EU_8Q{xjSGK~gUbPnvfB8e*7?*O#zoANB(fw@(P`@r)dOqA2*Ccp@I zLf?;4p4%*$_`Ls2m8091+r|`1eO>yISGq#1na5l^l(;KO7(G{2!!laqw(#%4n23a( zq@n1xqC9TZt)2ET7s&LLtEtkVgz36T@xF8{)t`!`Gvr_yUUXGgCskxRL#HsCA%a~G zNt4H~$qt3L7&|1N&c}_Kt;@O~f*3+S*3CgfR9>7H@nyG8K7)T`G>$FnwPXxgbr$zS zBz8g~+0oVfF6bplD6z9fNtAL!lt))ak!Y4g(r1k@{k?J9Yyy1AB4^Q8f~ueIaBl~u zWA1Huzwd6A5coUy%X2@tqo`>cSnw)NH_F9Hfs7#oIL}Lpcu`?3!bYCS{7)5momg9ypdJ8L=HD`zSg=Wr`d zLS%}S#D3FvnfA*@Ow48^i!M_WWBi0uWB8y8k;L#pNZ<<^GmRg}K%e&th)u5d-2420 ze!u5kZ@k{v0QmdKx7E2f$Rzu>_tSH863ob5U|f&cCSnYXEv!gHP~Sd zjZ8*$aFGls6XjC>aL9UPaC~UQnzYrEV?)u$z)6<)45*<=YkVLyW|c!j)~T@pg-$zr z$XUAP{DJJEU%TGb?>Xb(&|uVMzrLxzKCT}gr=!9yGDt57t$|UY0tSTPE*A&q3}`S* zZwRgWte}CJKbkLes8|psGr$Zl3+u1|*J!I4>C#1==%NP9#t%Ho^W-12xhBLxSb=6# zEkKOSlTl#-Gqk`uxyvnJh}#f{n{%LxB3VSQ7-1f+W^p?>bo!BK1e2o0Y0xABA>WDX zXze&o?}=IQrf7fzZi=+vK50GU)}VWEtUP|YrvU_V(Lo*Wxl3FZ7a=043bO)}b%JBH zjiO;RN{Wl<)m}&?&6F40T6G)10c-X7WFeh2vZ)}5o#Zx8?G$U=B`c0sOmvnN0tf58&BYSAub{x=}Cqk~{ zQ--=8<7c~y2R9?6yc8kWW}ozk&%TZ5Qvv4n5Sud+JJ89Gc9?o-jO`>fJ0pUT?hIpV zJZX>&0G^U@{wv8oPIa_xz(#7MQEH&FtV?I4IhdAMv_869K0>z8^YT_=&=2Kjr>gQi z&mIk0j%@*s{7IJNC0T=B4`Rajl0f=aU`f8p8^B{feNcf2xow+WM%o@qz0kG=c;}USD7nz6=8eNT!aqJRGS(ke5&qYa8y7e>OeB&A zkZ&J&StyT9e!C_w_VF4zI*)oa6j_tZOQ*8p)(r4ISQE;K#Ue*v#Gx*8%QUXUiJ$f= zyY;wYz@V^)ui=`zkoAlM*>us2V}sN56J@iCQ?ng|ka94V<-Z9dsi@FA_{5r{r45~qYoN@@cBy06`- zVc&I+Ih&&#nmTCC_Z0SX&ew|n%f6i)CivC&^whG?z*+7=vg|{t=4BGA=l^56qnuDO z!1qp^o>+8eKx(%}MoK3q21EHGYweOxgGB6Aq$Ar~9`}~*VQ7dH<;QME^^} z0W81H6OPdL{gJ6E-UzJte5VQ(oJRuKiAYZQ*#(eIo4E}Lkb!)t+JSe-@CM$*B$^b@ z;Bx+rsZ?bDs=G#J1%?dj_Arga$gH841{QKFP=U`ygs992Rz;kg&BBU*dlOtnboaNx zIm{8abJqyFWXyx9To5a&K#7}koT8;buvitCt}RgF7H#sF;Z1hU8QYIy0gHIkGW$gw zdkk$_!jEHQD`3D9&nih8`GOht!+G)!o~?0J`fWge^3jgFa%MWa5#D-O&Vx~O2e5Gj r&KKMqT@_dS4+hfRo -- Emit newline PC! c a -- Spit c to port a PC@ a -- c Fetch c from port a -SPC -- Emit space character +SPC> -- Emit space character WORD -- a Read one word from buffered input and push its addr. Always null terminated. If ASCII EOT is encountered, a will point to it (it is cons- idered a word). +These ASCII consts are defined: +BS CR LF SPC + KEY? and EMIT are ialiases to (key?) and (emit) (see TTY proto- col in protocol.txt). KEY is a loop over KEY?. diff --git a/tests/harness.fs b/tests/harness.fs index f94bc16..ffeae0d 100644 --- a/tests/harness.fs +++ b/tests/harness.fs @@ -2,8 +2,8 @@ "#" means "assert". We stop at first failure, indicating the failure through IO on port 1 ) -: fail SPC ." failed" LF 1 1 PC! BYE ; +: fail SPC> ." failed" NL> 1 1 PC! BYE ; -: # IF SPC ." pass" LF ELSE fail THEN ; +: # IF SPC> ." pass" NL> ELSE fail THEN ; -: #eq 2DUP SWAP . SPC '=' EMIT SPC . '?' EMIT = # ; +: #eq 2DUP SWAP . SPC> '=' EMIT SPC> . '?' EMIT = # ;