izaya/collapseos
1
0
Fork 0
mirror of https://github.com/hsoft/collapseos.git synced 2024-11-23 12:58:06 +11:00
Code Issues Releases Wiki Activity

Add BS, CR, LF, SPC ASCII consts

Browse Source 
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.
This commit is contained in:
Virgil Dupras 2021-01-02 10:19:42 -05:00
parent cbf9ecfb1e
commit 527f5977d7
5 changed files with 45 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
arch/z80/trs80/xcomp.fs
View File

@ -15,6 +15,6 @@ RS_ADDR 0x80 - CONSTANT SYSVARS
( Update LATEST ) ( Update LATEST )
PC ORG @ 8 + ! PC ORG @ 8 + !
( TRS-80 wants CR-only newlines ) ( 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! ORG @ |M 2 PC! 2 PC!
H@ |M 2 PC! 2 PC! H@ |M 2 PC! 2 PC!

74
blk.fs
View File

@ -450,7 +450,7 @@ VARIABLE L1 VARIABLE L2 VARIABLE L3 VARIABLE L4
( We divide by 2 because each PC represents a word. ) ( We divide by 2 because each PC represents a word. )
: PC H@ ORG @ - 1 RSHIFT ; : PC H@ ORG @ - 1 RSHIFT ;
( ----- 052 ) ( ----- 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 ; : _r8c DUP 7 > IF _oor THEN ;
: _r32c DUP 31 > IF _oor THEN ; : _r32c DUP 31 > IF _oor THEN ;
: _r16+c _r32c DUP 16 < IF _oor THEN ; : _r16+c _r32c DUP 16 < IF _oor THEN ;
@ -624,13 +624,13 @@ CREATE FBUF 64 ALLOT0
: _pln ( lineno -- ) : _pln ( lineno -- )
DUP _lpos DUP 64 + SWAP DO ( lno ) DUP _lpos DUP 64 + SWAP DO ( lno )
I EDPOS @ _cpos = IF '^' EMIT THEN I EDPOS @ _cpos = IF '^' EMIT THEN
I C@ DUP 0x20 < IF DROP 0x20 THEN I C@ DUP SPC < IF DROP SPC THEN
EMIT EMIT
LOOP ( lno ) 1+ . ; LOOP ( lno ) 1+ . ;
: _zbuf 64 0 FILL ; ( buf -- ) : _zbuf 64 0 FILL ; ( buf -- )
( ----- 108 ) ( ----- 108 )
: _type ( buf -- ) : _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! ; BEGIN ( c a ) C!+ C< TUCK 0x0d = UNTIL ( c a ) C! ;
( user-facing lines are 1-based ) ( user-facing lines are 1-based )
: T 1- DUP 64 * EDPOS ! _pln ; : T 1- DUP 64 * EDPOS ! _pln ;
@ -654,19 +654,19 @@ CREATE FBUF 64 ALLOT0
BEGIN BEGIN
C@+ ROT ( a2+1 c2 a1 ) C@+ ROT ( a2+1 a1+1 c1 c2 ) C@+ ROT ( a2+1 c2 a1 ) C@+ ROT ( a2+1 a1+1 c1 c2 )
= NOT IF DROP FBUF THEN ( a2 a1 ) = 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 ) OVER BLK) = OR ( a1 a2 f1|f2 )
UNTIL ( a1 a2 ) UNTIL ( a1 a2 )
DUP BLK) < IF BLK( - FBUF + -^ EDPOS ! ELSE DROP THEN ; DUP BLK) < IF BLK( - FBUF + -^ EDPOS ! ELSE DROP THEN ;
: F FBUF _type _F EDPOS @ 64 / _pln ; : F FBUF _type _F EDPOS @ 64 / _pln ;
( ----- 111 ) ( ----- 111 )
: _blen ( buf -- length of str in buf ) : _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 ) : _rbufsz ( size of linebuf to the right of curpos )
EDPOS @ 64 MOD 63 -^ ; EDPOS @ 64 MOD 63 -^ ;
: _lnfix ( --, ensure no ctl chars in line before EDPOS ) : _lnfix ( --, ensure no ctl chars in line before EDPOS )
EDPOS @ DUP 0xffc0 AND 2DUP = IF 2DROP EXIT THEN DO 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 ) : _i ( i without _pln and _type. used in VE )
_rbufsz IBUF _blen 2DUP > IF _rbufsz IBUF _blen 2DUP > IF
_lnfix TUCK - ( ilen chars-to-move ) _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 ; : width large? IF 64 ELSE COLS THEN ;
: acc@ ACC @ 1 MAX ; : pos@ ( x y -- ) EDPOS @ 64 /MOD ; : acc@ ACC @ 1 MAX ; : pos@ ( x y -- ) EDPOS @ 64 /MOD ;
: num ACC @ SWAP _pdacc IF ACC ! ELSE DROP THEN ; : 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 ; : 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 ; : gutter ( ln n ) OVER + SWAP DO 67 I AT-XY '|' EMIT LOOP ;
: status 0 aty ." BLK" SPC BLK> ? SPC ACC ? : status 0 aty ." BLK" SPC> BLK> ? SPC> ACC ?
SPC pos@ . ',' EMIT . xoff @ IF '>' EMIT THEN SPC SPC> pos@ . ',' EMIT . xoff @ IF '>' EMIT THEN SPC>
BLKDTY @ IF '*' EMIT THEN 4 nspcs ; 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 ) ( ----- 127 )
: mode! ( c -- ) 4 col- CELL! ; : mode! ( c -- ) 4 col- CELL! ;
: @emit C@ 0x20 MAX 0x7f MIN EMIT ; : @emit C@ SPC MAX 0x7f MIN EMIT ;
: contents : contents
16 0 DO 16 0 DO
large? IF 3 ELSE 0 THEN I 3 + AT-XY 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! ; : cmv ( n -- , char movement ) acc@ * EDPOS @ + pos! ;
: buftype ( buf ln -- ) : buftype ( buf ln -- )
3 OVER AT-XY KEY DUP EMIT 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 ) ( buf ln c ) 4 col- nspcs SWAP 4 SWAP AT-XY ( buf c )
SWAP C!+ IN( _zbuf (rdln) IN( SWAP 63 MOVE ; SWAP C!+ IN( _zbuf (rdln) IN( SWAP 63 MOVE ;
: bufp ( buf -- ) : bufp ( buf -- )
@ -824,8 +824,8 @@ CREATE PREVPOS 0 , CREATE PREVBLK 0 , CREATE xoff 0 ,
: $[ BLK> @ acc@ - selblk ; : $[ BLK> @ acc@ - selblk ;
: $] BLK> @ acc@ + selblk ; : $] BLK> @ acc@ + selblk ;
: $t PREVBLK @ selblk ; : $t PREVBLK @ selblk ;
: $I 'I' mode! IBUF 1 buftype _i bufs contents 0x20 mode! ; : $I 'I' mode! IBUF 1 buftype _i bufs contents SPC mode! ;
: $F 'F' mode! FBUF 2 buftype _F bufs setpos 0x20 mode! ; : $F 'F' mode! FBUF 2 buftype _F bufs setpos SPC mode! ;
: $Y Y bufs ; : $Y Y bufs ;
: $E _E bufs contents ; : $E _E bufs contents ;
: $X acc@ _X bufs contents ; : $X acc@ _X bufs contents ;
@ -855,9 +855,9 @@ CREATE PREVPOS 0 , CREATE PREVBLK 0 , CREATE xoff 0 ,
: $R ( replace mode ) : $R ( replace mode )
'R' mode! 'R' mode!
BEGIN setpos KEY DUP BS? IF -1 EDPOS +! DROP 0 THEN 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 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 _U EDPOS @ 0x3c0 AND DUP pos! _cpos _zbuf BLK!! contents ;
: $o EDPOS @ 0x3c0 < IF EDPOS @ 64 + EDPOS ! $O THEN ; : $o EDPOS @ 0x3c0 < IF EDPOS @ 64 + EDPOS ! $O THEN ;
: $D $H 64 icpy : $D $H 64 icpy
@ -927,7 +927,7 @@ VARIABLE aspprevx
ROT TUCK + 0x10 - ( sz a end ) ROT TUCK + 0x10 - ( sz a end )
TUCK SWAP 0 ROT> ( sz end sum end a ) DO ( sz end sum ) TUCK SWAP 0 ROT> ( sz end sum end a ) DO ( sz end sum )
I C@ + LOOP ( sz end sum ) SWAP ( sz sum end ) 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!+^ 'E' C!+^ 'G' C!+^ 'A' C!+^ 0 C!+^ 0 C!+^
( sum's LSB ) OVER C!+^ ( MSB ) SWAP 8 RSHIFT OVER C! 1+ ( sum's LSB ) OVER C!+^ ( MSB ) SWAP 8 RSHIFT OVER C! 1+
( sz end ) 0 C!+^ 0 C!+^ 0 C!+^ SWAP 0x4a + SWAP C! ; ( sz end ) 0 C!+^ 0 C!+^ 0 C!+^ SWAP 0x4a + SWAP C! ;
@ -1717,7 +1717,7 @@ with "390 LOAD"
( ----- 356 ) ( ----- 356 )
SYSVARS 0x53 + :** EMIT SYSVARS 0x53 + :** EMIT
: STYPE C@+ ( a len ) 0 DO C@+ EMIT LOOP DROP ; : 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 ; : NL> 0x50 RAM+ C@ ?DUP IF EMIT ELSE 13 EMIT 10 EMIT THEN ;
: ERR STYPE ABORT ; : ERR STYPE ABORT ;
: (uflw) LIT" stack underflow" ERR ; : (uflw) LIT" stack underflow" ERR ;
@ -1962,11 +1962,11 @@ SYSVARS 0x0c + :** C<*
( ----- 377 ) ( ----- 377 )
: _ ( a -- a+8 ) : _ ( a -- a+8 )
DUP ( a a ) DUP ( a a )
':' EMIT DUP .x SPC ':' EMIT DUP .x SPC>
4 0 DO DUP @ |L .x .x SPC 2+ LOOP 4 0 DO DUP @ |L .x .x SPC> 2+ LOOP
DROP ( a ) DROP ( a )
8 0 DO 8 0 DO
C@+ DUP 0x20 0x7e =><= NOT IF DROP '.' THEN EMIT C@+ DUP SPC 0x7e =><= NOT IF DROP '.' THEN EMIT
LOOP NL> ; LOOP NL> ;
: DUMP ( n a -- ) : DUMP ( n a -- )
SWAP 8 /MOD SWAP IF 1+ THEN SWAP 8 /MOD SWAP IF 1+ THEN
@ -1978,10 +1978,10 @@ SYSVARS 0x0c + :** C<*
( already at IN( ? ) ( already at IN( ? )
IN> @ IN( = IF EXIT THEN IN> @ IN( = IF EXIT THEN
IN> @ 1- IN> ! IN> @ 1- IN> !
BS SPC BS BS EMIT SPC> BS EMIT
; ;
( del is same as backspace ) ( del is same as backspace )
: BS? DUP 0x7f = SWAP 0x8 = OR ; : BS? DUP 0x7f = SWAP BS = OR ;
SYSVARS 0x55 + :** KEY? SYSVARS 0x55 + :** KEY?
: KEY BEGIN KEY? UNTIL ; : KEY BEGIN KEY? UNTIL ;
( cont.: read one char into input buffer and returns whether we ( cont.: read one char into input buffer and returns whether we
@ -1989,8 +1989,8 @@ SYSVARS 0x55 + :** KEY?
( ----- 379 ) ( ----- 379 )
: (rdlnc) ( -- c ) : (rdlnc) ( -- c )
( buffer overflow? same as if we typed a newline ) ( buffer overflow? same as if we typed a newline )
IN> @ IN) = IF 0x0a ELSE KEY THEN ( c ) IN> @ IN) = IF LF ELSE KEY THEN ( c )
DUP 0x0a = IF DROP 0xd THEN ( lf? same as cr ) DUP LF = IF DROP CR THEN ( lf? same as cr )
( backspace? handle and exit ) ( backspace? handle and exit )
DUP BS? IF _bs EXIT THEN DUP BS? IF _bs EXIT THEN
( echo back ) ( echo back )
@ -2001,7 +2001,7 @@ SYSVARS 0x55 + :** KEY?
thus ! automatically null-terminates our string ) thus ! automatically null-terminates our string )
IN> @ ! 1 IN> +! ( c ) IN> @ ! 1 IN> +! ( c )
( if newline, replace with zero to indicate EOL ) ( if newline, replace with zero to indicate EOL )
DUP 0xd = IF DROP 0 THEN ; DUP CR = IF DROP 0 THEN ;
( ----- 380 ) ( ----- 380 )
( Read one line in input buffer and make IN> point to it ) ( Read one line in input buffer and make IN> point to it )
: (rdln) : (rdln)
@ -2023,7 +2023,7 @@ SYSVARS 0x55 + :** KEY?
: RDLN$ : RDLN$
H@ 0x32 ( IN(* ) RAM+ ! H@ 0x32 ( IN(* ) RAM+ !
( plus 2 for extra bytes after buffer: 1 for ( 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 IN) IN( - ALLOT
(infl) (infl)
['] RDLN< ['] C<* **! ['] RDLN< ['] C<* **!
@ -2033,7 +2033,7 @@ SYSVARS 0x55 + :** KEY?
: LIST : LIST
BLK@ BLK@
16 0 DO 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 64 I * BLK( + DUP 64 + SWAP DO
I C@ DUP 0x1f > IF EMIT ELSE DROP LEAVE THEN I C@ DUP 0x1f > IF EMIT ELSE DROP LEAVE THEN
LOOP LOOP
@ -2044,7 +2044,7 @@ SYSVARS 0x55 + :** KEY?
BEGIN BEGIN
WORD DUP @ 0x0401 = ( EOT ) IF DROP EXIT THEN WORD DUP @ 0x0401 = ( EOT ) IF DROP EXIT THEN
FIND NOT IF (parse) ELSE EXECUTE THEN FIND NOT IF (parse) ELSE EXECUTE THEN
C<? NOT IF SPC LIT" ok" STYPE NL> THEN C<? NOT IF SPC> LIT" ok" STYPE NL> THEN
AGAIN ; AGAIN ;
( Read from BOOT C< PTR and inc it. ) ( Read from BOOT C< PTR and inc it. )
: (boot<) : (boot<)
@ -2075,7 +2075,7 @@ SYSVARS 0x55 + :** KEY?
( ----- 385 ) ( ----- 385 )
: LOAD+ BLK> @ + LOAD ; : LOAD+ BLK> @ + LOAD ;
( b1 b2 -- ) ( 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 ; : LOADR+ BLK> @ + SWAP BLK> @ + SWAP LOADR ;
( ----- 390 ) ( ----- 390 )
( xcomp core high ) ( xcomp core high )
@ -2168,17 +2168,17 @@ Load range: B402-B403
: XYPOS! COLS LINES * MOD DUP XYPOS @ CURSOR! XYPOS ! ; : XYPOS! COLS LINES * MOD DUP XYPOS @ CURSOR! XYPOS ! ;
: AT-XY ( x y -- ) COLS * + XYPOS! ; : AT-XY ( x y -- ) COLS * + XYPOS! ;
'? NEWLN NIP NOT [IF] '? 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] [THEN]
: _lf XYMODE C@ IF EXIT THEN : _lf XYMODE C@ IF EXIT THEN
XYPOS @ COLS / 1+ LINES MOD DUP NEWLN XYPOS @ COLS / 1+ LINES MOD DUP NEWLN
COLS * XYPOS! ; COLS * XYPOS! ;
: _bs 0x20 ( blank ) XYPOS @ TUCK CELL! ( pos ) 1- XYPOS! ; : _bs SPC XYPOS @ TUCK CELL! ( pos ) 1- XYPOS! ;
( ----- 403 ) ( ----- 403 )
: (emit) : (emit)
DUP 0x08 = IF DROP _bs EXIT THEN DUP BS? IF DROP _bs EXIT THEN
DUP 0x0d = IF DROP _lf EXIT THEN DUP CR = IF DROP _lf EXIT THEN
DUP 0x20 < IF DROP EXIT THEN DUP SPC < IF DROP EXIT THEN
XYPOS @ CELL! XYPOS @ CELL!
XYPOS @ 1+ DUP COLS MOD IF XYPOS! ELSE DROP _lf THEN ; XYPOS @ 1+ DUP COLS MOD IF XYPOS! ELSE DROP _lf THEN ;
: GRID$ 0 XYPOS ! 0 XYMODE C! ; : 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 ; ( blank row ) 0xff _data ;
: CELL! ( c pos ) : CELL! ( c pos )
0x7800 OR _ctl ( tilenum ) 0x7800 OR _ctl ( tilenum )
0x20 - ( glyph ) 0x5f MOD _data ; SPC - ( glyph ) 0x5f MOD _data ;
( ----- 472 ) ( ----- 472 )
: CURSOR! ( new old -- ) : CURSOR! ( new old -- )
DUP 0x3800 OR _ctl [ TMS_DATAPORT LITN ] PC@ DUP 0x3800 OR _ctl [ TMS_DATAPORT LITN ] PC@

BIN
cvm/stage.bin
View File

Binary file not shown.

5
doc/dict.txt
View File

@ -256,12 +256,15 @@ KEY -- c Get char c from direct input
NL> -- Emit newline NL> -- Emit newline
PC! c a -- Spit c to port a PC! c a -- Spit c to port a
PC@ a -- c Fetch c from 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 WORD -- a Read one word from buffered input and push its
addr. Always null terminated. If ASCII EOT is addr. Always null terminated. If ASCII EOT is
encountered, a will point to it (it is cons- encountered, a will point to it (it is cons-
idered a word). idered a word).
These ASCII consts are defined:
BS CR LF SPC
KEY? and EMIT are ialiases to (key?) and (emit) (see TTY proto- KEY? and EMIT are ialiases to (key?) and (emit) (see TTY proto-
col in protocol.txt). KEY is a loop over KEY?. col in protocol.txt). KEY is a loop over KEY?.

6
tests/harness.fs
View File

@ -2,8 +2,8 @@
"#" means "assert". We stop at first failure, indicating "#" means "assert". We stop at first failure, indicating
the failure through IO on port 1 ) 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 = # ;