Forth Block IO

Requires: 6502 Assembler, Disk-IO (SIO)

\ Forth Block IO

\needs code   INCLUDE" D1:TAS65.FS"
\needs block@ INCLUDE" D1:SIO.FS"

CR .( load Block Interface )

$40 ' C/L 2+ !  \ redefine char/line
$10 ' L/S 2+ !  \ redefine lines/scr
1 OFFSET !      \ offset for boot sec
HERE CONSTANT BUFMEM  \ start of buf
4 B/BUF * ALLOT \ allocate 8 buffer
HERE ' LIMIT 2+ ! \ patch limit
VARIABLE BUFFERS 0 BUFFERS ! \ semaph

: DRV? ( blk -- drv# ) DROP DRV @ ;

DEFER R/W
DEFER DISKERR

: (DISKERR
  ." ERROR! R to retry "
  KEY DUP ASCII R = SWAP ASCII R =
  OR NOT ABORT" Aborted" ;
' (DISKERR  IS DISKERR   

| : THIS? ( blk file bufadr -- flag )
    DUP 4 + @ SWAP 2+ @ D= ;

| : (CORE? ( blk file -- dataddr / blk free )
    BEGIN
     OVER OFFSET @ + OVER PREV @
     THIS? IF
       RDROP 2DROP PREV @ 8 + EXIT 
     THEN
     2DUP >R OFFSET @ + >R PREV @
     BEGIN
      DUP @ ?DUP
     0= IF RDROP RDROP DROP EXIT 
      THEN
      DUP R> R> 2DUP >R >R ROT THIS?
     0= WHILE
      NIP 
     REPEAT
     DUP @ ROT !  PREV @ OVER !  
     PREV !
     RDROP RDROP
    REPEAT
    ; -2 ALLOT \ never reached!

| : BACKUP ( buffaddr -- )
    DUP 6 + @ 0<
    IF 2+ DUP @ 1+
     IF INPUT PUSH OUTPUT PUSH 
        STANDARDI/O 
        BEGIN
          DUP 6 + OVER 2+ @ 2 PICK
          @ 0 R/W
        WHILE ." Write" DISKERR
        REPEAT
     THEN
     $80 OVER 5 + CTOGGLE
    THEN DROP ;

| : EMPTYBUF ( bufaddr -- )
    2+ DUP ON 4 + OFF ;

| : FILE@ FILE @ ;

| : READBLK ( BLK FILE ADDR -- BLK FILE ADDR )
    DUP EMPTYBUF 
    INPUT PUSH OUTPUT PUSH
    STANDARDI/O >R
    BEGIN
     OVER OFFSET @ + OVER R@ 8 +
     -ROT 1 R/W 
    WHILE ." READ " DISKERR
    REPEAT
    R> ;

| : TAKE ( -- bufaddr )
    PREV
    BEGIN 
     DUP @ 
    WHILE
     @ DUP 2+ @ -1 = UNTIL
    BUFFERS LOCK  DUP BACKUP ;

| : MARK ( BLK FILE BUFADDR -- BLK FILE )
    2+ >R 2DUP R@ ! 
    OFFSET @ + R@ 2+ !
    R> 4 + OFF BUFFERS UNLOCK ;

| : UPDATES? ( -- bufaddr / flag )
    PREV BEGIN
          @ DUP
         WHILE DUP 6 + @ 0<
         UNTIL ;

| : FULL? ( -- flag )
    PREV BEGIN
          @ DUP @
    0= UNTIL 
    6 + @ 0< ;

: CORE? ( blk file -- addr / false )
  (CORE? 2DROP FALSE ;

: (BUFFER ( blk file -- addr )
  BEGIN (CORE? TAKE MARK REPEAT ;
  -2 ALLOT \ never reached

: (BLOCK ( blk file -- addr )
  BEGIN 
   (CORE? TAKE READBLK MARK 
  REPEAT ; -2 ALLOT \ never reached

: BUFFER ( blk -- addr )
  FILE@ (BUFFER ;

: BLOCK  ( blk -- addr )
  FILE@ (BLOCK ;

: UPDATE 
  $80 PREV @ 7 + C! ;

: SAVE-BUFFERS
  BUFFERS LOCK 
  BEGIN
   UPDATES? ?DUP
  WHILE
   BACKUP
  REPEAT
  BUFFERS UNLOCK ;

: EMPTY-BUFFERS
  BUFFERS LOCK
  PREV
  BEGIN 
   @ ?DUP
  WHILE
   DUP EMPTYBUF
  REPEAT
  BUFFERS UNLOCK ;

: FLUSH
  SAVE-BUFFERS EMPTY-BUFFERS ;

: ALLOTBUFFER ( -- )
  FIRST @ BUFMEM - B/BUF 2+ U< ?EXIT
  B/BUF NEGATE FIRST +! 
  FIRST @ DUP EMPTYBUF 
  PREV @ OVER ! PREV ! ;

: FREEBUFFER ( -- )
  FIRST @ LIMIT B/BUF - U< IF
   FIRST @ BACKUP PREV
   BEGIN
    DUP @ FIRST @ -
   WHILE
    @
   REPEAT
   FIRST @ @ SWAP ! 
   B/BUF FIRST +!
  THEN ;

: ALL-BUFFERS ( -- )
  BEGIN
   FIRST @ ALLOTBUFFER FIRST @ = 
  UNTIL ;

: INIT-BUFFERS ( -- )
  PREV OFF LIMIT FIRST ! ALL-BUFFERS ;

INIT-BUFFERS 
 
: LOAD ( blk -- )
  ?DUP 0= ?EXIT BLK PUSH BLK !
  >IN PUSH >IN OFF .STATUS INTERPRET ;

: +LOAD ( offset -- ) BLK @ + LOAD ;

: THRU  ( from to -- ) 
  1+ SWAP DO I LOAD LOOP ;

: +THRU ( off0 off1 -- )
  1+ SWAP DO I +LOAD LOOP ;

: --> ( -- ) 
  1 BLK +! >IN OFF .STATUS ; IMMEDIATE

: LIST ( blk -- )
  SCR ! ." SCR " SCR @ DUP u.
        ." DR " DRV? .
  L/S 0 DO
    CR I 2 .R SPACE SCR @ BLOCK 
    I C/L * + C/L -TRAILING TYPE
  LOOP CR ;

: (R/W ( addr block file rwf -- ior )
  SWAP ABORT" NO FILE BLOCK SUPPORT"
  IF BLOCK@ ELSE BLOCK! THEN
;

' (R/W IS R/W

| : NSRC ( -- addr len ) \ new SOURCE
    BLK @ ?DUP IF BLOCK B/BLK EXIT THEN
    TIB TIB# @ ;

\ patch "SOURCE" in Kernel
' NEWSRC ' SOURCE >BODY !

| : INIT INIT-BUFFERS PAGE
    ." Block Interface for SIO" CR
  ;

' INIT IS 'COLD

\ : .BUFFER ( addr -- )
\   CR DUP ." Next link:" @ U. CR
\   2+ DUP ." File     :" @ U. CR
\   2+ DUP ." Block num:" @ U. CR
\   2+ DUP ." Status   :" @ U. CR
\   2+ B/BUF DUMP ;

CR .( Block Interface loaded ) CR

\ LABEL THISBUFFER
\      2 # LDY         \ LDY #2
\      [[ 
\        N 4 + )Y LDA  \ LDA (N+4),Y  
\        N 2- ,Y  CMP  \ CMP N-2,Y
\      0= ?[[
\        INY           \ INY
\        6 # CPY       \ CPY #6
\      0= ]?
\      RTS