~vdupras/collapseos

527f5977d711b637b2b73945b7c99b99ef27699f — Virgil Dupras 1 year, 5 months ago cbf9ecf
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.
5 files changed, 45 insertions(+), 42 deletions(-)

M arch/z80/trs80/xcomp.fs
M blk.fs
M cvm/stage.bin
M doc/dict.txt
M tests/harness.fs
M arch/z80/trs80/xcomp.fs => arch/z80/trs80/xcomp.fs +1 -1
@@ 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!

M blk.fs => blk.fs +37 -37
@@ 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@

M cvm/stage.bin => cvm/stage.bin +0 -0
M doc/dict.txt => doc/dict.txt +4 -1
@@ 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?.


M tests/harness.fs => tests/harness.fs +3 -3
@@ 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 = # ;