1
0
mirror of https://github.com/hsoft/collapseos.git synced 2024-12-25 05:18:06 +11:00

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.
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

View File

@ -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!

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. )
: 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<? NOT IF SPC LIT" ok" STYPE NL> THEN
C<? NOT IF SPC> 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@

Binary file not shown.

View File

@ -256,12 +256,15 @@ KEY -- c Get char c from direct input
NL> -- 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?.

View File

@ -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 = # ;