collapseos/arch/z80/trs80/blk.fs

( ----- 600 )
TRS-80 Recipe

Support code for the TRS-80 recipe. Contains drivers for the
keyboard, video and floppy. At the moment, they are thin layer
over the drivers provided by TRSDOS' SVC.

Load with "602 LOAD".

There is also the RECV program at B612.
( ----- 602 )
1 8 LOADR+
( ----- 603 )
CODE (key)
    A 0x01 LDri, ( @KEY )
    0x28 RST,
    PUSHA,
;CODE
CODE (emit) EXX, ( protect BC )
    BC POP, ( c == @DSP arg ) chkPS,
    A 0x02 LDri, ( @DSP )
    0x28 RST,
EXX, ( unprotect BC ) ;CODE
CODE AT-XY EXX, ( protect BC )
    DE POP, H E LDrr, ( Y )
    DE POP, L E LDrr, ( X ) chkPS,
    A 0x0f LDri, ( @VDCTL ) B 3 LDri, ( setcur )
    0x28 RST,
EXX, ( unprotect BC ) ;CODE
( ----- 604 )
: LINES 24 ; : COLS 80 ;
CODE BYE
    HL 0 LDdi,
    A 0x16 LDri, ( @EXIT )
    0x28 RST,
CODE @DCSTAT ( drv -- f ) EXX, ( protect BC )
    BC POP,
    chkPS,
    A 0x28 LDri, ( @DCSTAT )
    0x28 RST,
    PUSHZ,
EXX, ( unprotect BC ) ;CODE
( ----- 605 )
CODE @RDSEC ( drv cylsec addr -- f ) EXX, ( protect BC )
    HL POP,
    DE POP,
    BC POP,
    chkPS,
    A 0x31 LDri, ( @RDSEC )
    0x28 RST,
    PUSHZ,
EXX, ( unprotect BC ) ;CODE
( ----- 606 )
CODE @WRSEC ( drv cylsec addr -- f ) EXX, ( protect BC )
    HL POP,
    DE POP,
    BC POP,
    chkPS,
    A 0x35 LDri, ( @WRSEC )
    0x28 RST,
    PUSHZ,
EXX, ( unprotect BC ) ;CODE
CODE @GET ( a -- c f )
    DE POP,
    chkPS,
    A 0x03 LDri, ( @GET )
    0x28 RST,
    PUSHA, PUSHZ,
;CODE
( ----- 607 )
CODE @PUT ( c a -- f ) EXX, ( protect BC )
    DE POP,
    BC POP,
    chkPS,
    A 0x04 LDri, ( @PUT )
    0x28 RST,
    PUSHZ,
EXX, ( unprotect BC ) ;CODE
( ----- 609 )
: _err LIT" FDerr" ERR ;
: _cylsec ( sec -- cs, return sector/cylinder for given secid )
    ( 4 256b sectors per block, 10 sec per cyl, 40 cyl max )
    10 /MOD ( sec cyl )
    DUP 39 > IF _err THEN
    8 LSHIFT + ( cylsec )
;
: FD@! ( wref blk -- )
    1 @DCSTAT NOT IF _err THEN
    2 LSHIFT ( 4 * -- wr sec )
    4 0 DO ( wr sec )
        DUP I + _cylsec ( wr sec cs )
        I 8 LSHIFT BLK( + ( wr sec cs addr )
        1 ROT ROT ( wr sec drv cs addr )
        4 PICK EXECUTE NOT IF _err THEN
    LOOP 2DROP ;
( ----- 610 )
: FD@ ['] @RDSEC SWAP FD@! ;
: FD! ['] @WRSEC SWAP FD@! ;
: FD$ ['] FD@ BLK@* ! ['] FD! BLK!* ! ;

: _err LIT" *CLerr" ERR ;
: *CL< 0 BEGIN DROP 0x0238 @GET UNTIL ;
: *CL> 0x0238 @PUT NOT IF _err THEN ;
( ----- 612 )
( We process the 0x20 exception by pre-putting a mask in the
  (HL) we're going to write to. If it wasn't a 0x20, we put a
  0xff mask. If it was a 0x20, we put a 0x7f mask. )
: @GET,
    A 0x03 LDri, ( @GET )
    DE COM_DRV_ADDR LDdi,
    0x28 RST, JRNZ, L2 FWR ( maybeerror )
    A ORr,
    CZ RETc, ( Sending a straight NULL ends the comm. ) ;
: @PUT, ( @PUT that char back )
        C A LDrr,
        A 0x04 LDri, ( @PUT )
        0x28 RST, JRNZ, L3 FWR ( error )
        A C LDrr, ;
H@ ORG !
HL DEST_ADDR LDdi,                                    ( cont. )
( ----- 613 )
BEGIN,
    A 0xff LDri, (HL) A LDrr, ( default mask )
    L1 BSET ( loop2 ) @GET, @PUT,
    0x20 CPi, JRZ, L4 FWR ( escapechar )
	( not an escape char, just apply the mask and write )
    (HL) ANDr, (HL) A LDrr,
    HL INCd,
JR, AGAIN,
L4 FSET ( escapechar, adjust by setting (hl) to 0x7f )
7 (HL) RES, JR, L1 BWR ( loop2 )
L2 FSET ( maybeerror, was it an error? )
A ORr, JRZ, L1 BWR ( loop2, not an error )
L3 FSET ( error )
C A LDrr, ( error code from @GET/@PUT )
A 0x1a LDri, ( @ERROR ) 0x28 RST, RET,