|
- ( ----- 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,
|