\*
 *   ZEN 1.10  File extension
 *     C 1990  by Martin Tracy
 *             Last modified  1.1.90
 *\

26 EQU EOF#  \ control-Z marks the end of older text files.
52 EQU FCB#  \ Size of fcb: 0-1: handle; 2-51: ASCIIZ name.

4 CELLS FCB# + EQU EVWID   \ width of EVAL stack.
4 EQU EVDEPTH              \ depth of EVAL stack.

| VARIABLE EV   \ EVAL stack.
EVWID EVDEPTH 1+ * ALLOT

\ Default system FCB for opening and making files.
| : SYS
   EV [ EVWID FCB# - ] LITERAL + ;

\ Create file control block.
: FILE ( - fcb)
   VARIABLE  [ FCB# CELL - ] LITERAL ALLOT ;

| VARIABLE SYS2   \ RENAME-FILE and DIR first buffer.
  FCB# CELL - ALLOT
| VARIABLE SYS3   \ RENAME-FILE and DIR second buffer.
  FCB# CELL - ALLOT


\ Move file name into fcb as ASCIIZ string.
: N>FCB ( a u fcb)
   CELL+  2DUP + 0 SWAP C!  SWAP CMOVE ;

\ Recover file name from fcb.
: FCB>N ( fcb - a u)
   CELL+ [ FCB# CELL - ] LITERAL  2DUP 0 SCAN  NIP - ;

HEX
\ Generic call to MS-DOS
CODE FDOS ( DX CX handle function# - AX ior)
        mov   ax,bx
        pop   bx
        pop   cx
        pop   dx
        int   21h
FDOS1:  push  ax
FDOS2:  xchg  ax,bx
        jc    FDOS3
        xor   bx,bx
FDOS3:  NEXT
END-CODE

\ Rename file FDOS call.
| CODE RDOS ( a a2 function# - ior)
        xchg  ax,bx
        pop   di
        pop   dx
        int   21h
        jmp   FDOS2
END-CODE

\ Seek FDOS call.
| CODE SDOS ( DX CX handle function# - AX DX ior)
        xchg  ax,bx
        pop   bx
        pop   cx
        pop   dx
        int   21h
        push  ax
        xchg  ax,dx
        jmp   FDOS1
END-CODE


0 CONSTANT R/O   \ read  only file access
1 CONSTANT W/O   \ write only file access
2 CONSTANT R/W   \ read/write file access

\ Factor of FOPEN and FMAKE
| : FCMD ( a u w fcb - fcb ior)
   2>R  R@ N>FCB  R@ CELL+ 0 0 2R> >R FDOS  SWAP R@ !  R> SWAP ;

\ Open file by name with mode w.  Save name and handle in fcb.
: FOPEN ( a u w fcb - fcb ior)
   SWAP 3D00 + SWAP FCMD ;

\ Make new file by name with mode w.  Save name and handle in fcb.
: FMAKE ( a u w fcb - fcb ior)
   SWAP 3C00 + SWAP FCMD ;


\ Open file by name with mode w.  Return fcb and ior = 0
: OPEN-FILE ( a u w - fcb ior) \ FILE
   SYS FOPEN ;

\ Make new file by name with mode w.  Return fcb.
: CREATE-FILE ( a u w - fcb ior) \ FILE
   SYS FMAKE ;

\ Delete file by name.  Return handle.
: DELETE-FILE ( a u - ior) \ FILE
   SYS2 N>FCB  SYS2 CELL+ 0 0 4100 FDOS  NIP ;

\ Close file.
: CLOSE-FILE ( fcb - ior) \ FILE
   @ DUP DUP  3E00 FDOS  NIP ;

\ Rename file to be file2.
: RENAME-FILE ( a u a2 u2 - ior) \ FILE
   SYS2 N>FCB  SYS3 N>FCB
   SYS3 CELL+ SYS2 CELL+ 5600 RDOS ;


\ Read u bytes to address a from file.
: READ-FILE ( a u fcb - u2 ior) \ FILE
   @ 3F00 FDOS ;

\ Write u bytes from address a to file.
\ Disk full leaves "general failure" return code.
: WRITE-FILE ( a u fcb - u2 ior) \ FILE
   OVER >R  @ 4000 FDOS  OVER R> - IF  DUP 0= 1F AND OR  THEN ;

\ Add an offset to file:
\ n neg: to start; n pos: to end; n zero: to current.
: SEEK-FILE ( doff n fcb - dpos ior) \ FILE
   @ SWAP DUP IF  0< CELLS 1+  THEN  4201 + SDOS ;

\ Return file position.
: FILEPOS ( w - d) \ FILE
   >R  0 0 0 R> SEEK-FILE  0= HUH? ;

\ Return file size.
: FILESIZE ( w - d) \ FILE
   >R  0 0 1 R> SEEK-FILE  0= HUH? ;


\ Write end-of-line sequence to file.
: WRITE-CR ( fcb - ior) \ FILE
   CRLF COUNT ROT WRITE-FILE  NIP ;

\ Read line from file into buffer.
\ u2 bytes are actually read.  False on end-of-file.
: READ-LINE ( a u fcb - 0 0 ior | u2 t ior) \ FILE
   >R  2DUP 1+ R@ READ-FILE  ?DUP
   IF  NIP  R> DROP  EXIT THEN                ( a u u2)
   DUP 0= IF  R> 2DROP 2DROP  0 0 0 EXIT THEN ( end of file)
   >R OVER R> TUCK [ EOL# ] LITERAL SCAN  NIP ( a u u2 u3)  ?DUP
   IF    2 ( byte CRLF) OVER - >R -
   ELSE  2DUP U< >R  THEN  MIN R>             ( a u4 #seek) ?DUP
   IF  S>D 0 R@ SEEK-FILE  >R  2DROP  R> ?DUP
       IF   R> DROP  EXIT THEN
   THEN  TUCK [ EOF# ] LITERAL SCAN  NIP - ( just THEN NIP if no EOFs)
   R> DROP  TRUE 0 ;


\ Display the disk directory.  Allow wild cards.
: DIR ( | " <name> ")
   BL WORD COUNT  DUP 0= IF  2DROP " *.*"  THEN
   2DUP [CHAR] . SCAN 0= IF  " \*.*" ROT SWAP MOVE  4 + DUP THEN
   DROP SYS3 N>FCB  SYS2 0 0 1A00 FDOS 2DROP
   SYS3 CELL+ 11 0 4E00 ( firstf) FDOS  DROP 0=
   IF  0 BEGIN  DUP 5 MOD 0= IF  CR  THEN  1+
                SYS2 1E + 0C  2DUP 0 SCAN  NIP - TUCK TYPE
                0F SWAP - SPACES   0 11 0 4F00 ( nextf ) FDOS  NIP
         UNTIL  DROP
   THEN ;
DECIMAL


80 EQU EVL#   \ EVAL maximum line size.

| VARIABLE EVLINE    \ EVAL line buffer.  Max packed string = EVL# bytes.
EVL# ALLOT

\ EVAL line position pointer.
| : EVPOS ( - a)    EV EVCTR @ + ;

\ EVAL line number counter.
| : EVLINE# ( - a)   EVPOS [ 2 CELLS ] LITERAL + ;

\ EVAL old error handler.
| : EVERR ( - a)   EVPOS [ 3 CELLS ] LITERAL + ;

\ EVAL fcb.
| : EVFCB ( - a)   EVPOS [ 4 CELLS ] LITERAL + ;


\ Pop one level of EVAL stack.
| : EVPOP
    EVERR @ 'ERR !  EVFCB CLOSE-FILE DROP
  [ EVWID NEGATE ] LITERAL EVCTR +! ;

\ File evaluation error handler.
| : FERR ( a u)
   CR SOURCE TYPE  CR THERE COUNT 1+ TYPE ( msg) TYPE
   ."  in line " EVLINE# ? ." of "   EVFCB FCB>N TYPE
   BEGIN  EVPOS EV -
   WHILE  EVPOP  REPEAT   ABORT ;

| : ERR? ( f)
   ABORT" ?" ;

\ Push one level on EVAL stack and prepare to evaluate file by name.
| : EVPUSH ( a u)
  [ EVWID ] LITERAL EVCTR +! ( push)
   'ERR @ EVERR !  R/O EVFCB FOPEN  NIP IF  EVPOP  TRUE ERR?  THEN
  ['] FERR 'ERR !  1 EVLINE# ! ;

\ Read next line into EVLINE .  True if not end of file.
| : EVQUERY ( - a u f)
   EVLINE  DUP [ EVL# ] LITERAL EVFCB READ-LINE  ERR? ;


\ Evaluate a file by name.
: INCLUDE-FILE ( a u)
   EVPUSH  BEGIN  EVFCB FILEPOS EVPOS 2!   EVQUERY
           WHILE  EVALUATE   1 EVLINE# +!  REPEAT  2DROP
   EVPOP  EVCTR @ IF  EVPOS 2@ 0 SEEK-FILE  ERR?  THEN ;


\ Add file extension a2 u2 if none present in file a u.
: +EXT ( a u a2 u2 - a3 u3)
   2OVER [CHAR] . SCAN NIP IF  2DROP  ELSE  STRCAT  THEN ;

\ Remove file extension, if any, by shortening string.
: -EXT ( a u - a2 u2)
   2DUP  [CHAR] . SCAN IF  NIP OVER -  0 THEN  DROP ;

\ Evaluate the following file.
: INCLUDING ( " <name> ")
   BL WORD COUNT " .SRC" +EXT INCLUDE-FILE ;


\ Treat the rest of the line as a comment, like this one.
: \ ( " ccc")
    #TIB @ >IN ! ;
IMMEDIATE


\ Force next line of evaluation file.
: INQUIRE ( - f)
  EVQUERY ( eof) >R  #TIB 2!  >IN OFF  1 EVLINE# +!   R> ;

\ Skip lines between \* and *\'s as comments.
: \* ( " ...")
   BEGIN BEGIN BL WORD COUNT  DUP
         WHILE 2 = DUP IF  OVER @ " *\" DROP @ = AND  THEN  NIP
           IF  EXIT  THEN
         REPEAT  2DROP
         INQUIRE NOT IF  EXIT  THEN
   AGAIN ;
IMMEDIATE
