home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / zen / files.src < prev    next >
Text File  |  1990-01-11  |  7KB  |  253 lines
  1. \*
  2.  *   ZEN 1.10  File extension
  3.  *     C 1990  by Martin Tracy
  4.  *             Last modified  1.1.90
  5.  *\
  6.  
  7. 26 EQU EOF#  \ control-Z marks the end of older text files.
  8. 52 EQU FCB#  \ Size of fcb: 0-1: handle; 2-51: ASCIIZ name.
  9.  
  10. 4 CELLS FCB# + EQU EVWID   \ width of EVAL stack.
  11. 4 EQU EVDEPTH              \ depth of EVAL stack.
  12.  
  13. | VARIABLE EV   \ EVAL stack.
  14. EVWID EVDEPTH 1+ * ALLOT
  15.  
  16. \ Default system FCB for opening and making files.
  17. | : SYS
  18.    EV [ EVWID FCB# - ] LITERAL + ;
  19.  
  20. \ Create file control block.
  21. : FILE ( - fcb)
  22.    VARIABLE  [ FCB# CELL - ] LITERAL ALLOT ;
  23.  
  24. | VARIABLE SYS2   \ RENAME-FILE and DIR first buffer.
  25.   FCB# CELL - ALLOT
  26. | VARIABLE SYS3   \ RENAME-FILE and DIR second buffer.
  27.   FCB# CELL - ALLOT
  28.  
  29.  
  30. \ Move file name into fcb as ASCIIZ string.
  31. : N>FCB ( a u fcb)
  32.    CELL+  2DUP + 0 SWAP C!  SWAP CMOVE ;
  33.  
  34. \ Recover file name from fcb.
  35. : FCB>N ( fcb - a u)
  36.    CELL+ [ FCB# CELL - ] LITERAL  2DUP 0 SCAN  NIP - ;
  37.  
  38. HEX
  39. \ Generic call to MS-DOS
  40. CODE FDOS ( DX CX handle function# - AX ior)
  41.         mov   ax,bx
  42.         pop   bx
  43.         pop   cx
  44.         pop   dx
  45.         int   21h
  46. FDOS1:  push  ax
  47. FDOS2:  xchg  ax,bx
  48.         jc    FDOS3
  49.         xor   bx,bx
  50. FDOS3:  NEXT
  51. END-CODE
  52.  
  53. \ Rename file FDOS call.
  54. | CODE RDOS ( a a2 function# - ior)
  55.         xchg  ax,bx
  56.         pop   di
  57.         pop   dx
  58.         int   21h
  59.         jmp   FDOS2
  60. END-CODE
  61.  
  62. \ Seek FDOS call.
  63. | CODE SDOS ( DX CX handle function# - AX DX ior)
  64.         xchg  ax,bx
  65.         pop   bx
  66.         pop   cx
  67.         pop   dx
  68.         int   21h
  69.         push  ax
  70.         xchg  ax,dx
  71.         jmp   FDOS1
  72. END-CODE
  73.  
  74.  
  75. 0 CONSTANT R/O   \ read  only file access
  76. 1 CONSTANT W/O   \ write only file access
  77. 2 CONSTANT R/W   \ read/write file access
  78.  
  79. \ Factor of FOPEN and FMAKE
  80. | : FCMD ( a u w fcb - fcb ior)
  81.    2>R  R@ N>FCB  R@ CELL+ 0 0 2R> >R FDOS  SWAP R@ !  R> SWAP ;
  82.  
  83. \ Open file by name with mode w.  Save name and handle in fcb.
  84. : FOPEN ( a u w fcb - fcb ior)
  85.    SWAP 3D00 + SWAP FCMD ;
  86.  
  87. \ Make new file by name with mode w.  Save name and handle in fcb.
  88. : FMAKE ( a u w fcb - fcb ior)
  89.    SWAP 3C00 + SWAP FCMD ;
  90.  
  91.  
  92. \ Open file by name with mode w.  Return fcb and ior = 0
  93. : OPEN-FILE ( a u w - fcb ior) \ FILE
  94.    SYS FOPEN ;
  95.  
  96. \ Make new file by name with mode w.  Return fcb.
  97. : CREATE-FILE ( a u w - fcb ior) \ FILE
  98.    SYS FMAKE ;
  99.  
  100. \ Delete file by name.  Return handle.
  101. : DELETE-FILE ( a u - ior) \ FILE
  102.    SYS2 N>FCB  SYS2 CELL+ 0 0 4100 FDOS  NIP ;
  103.  
  104. \ Close file.
  105. : CLOSE-FILE ( fcb - ior) \ FILE
  106.    @ DUP DUP  3E00 FDOS  NIP ;
  107.  
  108. \ Rename file to be file2.
  109. : RENAME-FILE ( a u a2 u2 - ior) \ FILE
  110.    SYS2 N>FCB  SYS3 N>FCB
  111.    SYS3 CELL+ SYS2 CELL+ 5600 RDOS ;
  112.  
  113.  
  114. \ Read u bytes to address a from file.
  115. : READ-FILE ( a u fcb - u2 ior) \ FILE
  116.    @ 3F00 FDOS ;
  117.  
  118. \ Write u bytes from address a to file.
  119. \ Disk full leaves "general failure" return code.
  120. : WRITE-FILE ( a u fcb - u2 ior) \ FILE
  121.    OVER >R  @ 4000 FDOS  OVER R> - IF  DUP 0= 1F AND OR  THEN ;
  122.  
  123. \ Add an offset to file:
  124. \ n neg: to start; n pos: to end; n zero: to current.
  125. : SEEK-FILE ( doff n fcb - dpos ior) \ FILE
  126.    @ SWAP DUP IF  0< CELLS 1+  THEN  4201 + SDOS ;
  127.  
  128. \ Return file position.
  129. : FILEPOS ( w - d) \ FILE
  130.    >R  0 0 0 R> SEEK-FILE  0= HUH? ;
  131.  
  132. \ Return file size.
  133. : FILESIZE ( w - d) \ FILE
  134.    >R  0 0 1 R> SEEK-FILE  0= HUH? ;
  135.  
  136.  
  137. \ Write end-of-line sequence to file.
  138. : WRITE-CR ( fcb - ior) \ FILE
  139.    CRLF COUNT ROT WRITE-FILE  NIP ;
  140.  
  141. \ Read line from file into buffer.
  142. \ u2 bytes are actually read.  False on end-of-file.
  143. : READ-LINE ( a u fcb - 0 0 ior | u2 t ior) \ FILE
  144.    >R  2DUP 1+ R@ READ-FILE  ?DUP
  145.    IF  NIP  R> DROP  EXIT THEN                ( a u u2)
  146.    DUP 0= IF  R> 2DROP 2DROP  0 0 0 EXIT THEN ( end of file)
  147.    >R OVER R> TUCK [ EOL# ] LITERAL SCAN  NIP ( a u u2 u3)  ?DUP
  148.    IF    2 ( byte CRLF) OVER - >R -
  149.    ELSE  2DUP U< >R  THEN  MIN R>             ( a u4 #seek) ?DUP
  150.    IF  S>D 0 R@ SEEK-FILE  >R  2DROP  R> ?DUP
  151.        IF   R> DROP  EXIT THEN
  152.    THEN  TUCK [ EOF# ] LITERAL SCAN  NIP - ( just THEN NIP if no EOFs)
  153.    R> DROP  TRUE 0 ;
  154.  
  155.  
  156. \ Display the disk directory.  Allow wild cards.
  157. : DIR ( | " <name> ")
  158.    BL WORD COUNT  DUP 0= IF  2DROP " *.*"  THEN
  159.    2DUP [CHAR] . SCAN 0= IF  " \*.*" ROT SWAP MOVE  4 + DUP THEN
  160.    DROP SYS3 N>FCB  SYS2 0 0 1A00 FDOS 2DROP
  161.    SYS3 CELL+ 11 0 4E00 ( firstf) FDOS  DROP 0=
  162.    IF  0 BEGIN  DUP 5 MOD 0= IF  CR  THEN  1+
  163.                 SYS2 1E + 0C  2DUP 0 SCAN  NIP - TUCK TYPE
  164.                 0F SWAP - SPACES   0 11 0 4F00 ( nextf ) FDOS  NIP
  165.          UNTIL  DROP
  166.    THEN ;
  167. DECIMAL
  168.  
  169.  
  170. 80 EQU EVL#   \ EVAL maximum line size.
  171.  
  172. | VARIABLE EVLINE    \ EVAL line buffer.  Max packed string = EVL# bytes.
  173. EVL# ALLOT
  174.  
  175. \ EVAL line position pointer.
  176. | : EVPOS ( - a)    EV EVCTR @ + ;
  177.  
  178. \ EVAL line number counter.
  179. | : EVLINE# ( - a)   EVPOS [ 2 CELLS ] LITERAL + ;
  180.  
  181. \ EVAL old error handler.
  182. | : EVERR ( - a)   EVPOS [ 3 CELLS ] LITERAL + ;
  183.  
  184. \ EVAL fcb.
  185. | : EVFCB ( - a)   EVPOS [ 4 CELLS ] LITERAL + ;
  186.  
  187.  
  188. \ Pop one level of EVAL stack.
  189. | : EVPOP
  190.     EVERR @ 'ERR !  EVFCB CLOSE-FILE DROP
  191.   [ EVWID NEGATE ] LITERAL EVCTR +! ;
  192.  
  193. \ File evaluation error handler.
  194. | : FERR ( a u)
  195.    CR SOURCE TYPE  CR THERE COUNT 1+ TYPE ( msg) TYPE
  196.    ."  in line " EVLINE# ? ." of "   EVFCB FCB>N TYPE
  197.    BEGIN  EVPOS EV -
  198.    WHILE  EVPOP  REPEAT   ABORT ;
  199.  
  200. | : ERR? ( f)
  201.    ABORT" ?" ;
  202.  
  203. \ Push one level on EVAL stack and prepare to evaluate file by name.
  204. | : EVPUSH ( a u)
  205.   [ EVWID ] LITERAL EVCTR +! ( push)
  206.    'ERR @ EVERR !  R/O EVFCB FOPEN  NIP IF  EVPOP  TRUE ERR?  THEN
  207.   ['] FERR 'ERR !  1 EVLINE# ! ;
  208.  
  209. \ Read next line into EVLINE .  True if not end of file.
  210. | : EVQUERY ( - a u f)
  211.    EVLINE  DUP [ EVL# ] LITERAL EVFCB READ-LINE  ERR? ;
  212.  
  213.  
  214. \ Evaluate a file by name.
  215. : INCLUDE-FILE ( a u)
  216.    EVPUSH  BEGIN  EVFCB FILEPOS EVPOS 2!   EVQUERY
  217.            WHILE  EVALUATE   1 EVLINE# +!  REPEAT  2DROP
  218.    EVPOP  EVCTR @ IF  EVPOS 2@ 0 SEEK-FILE  ERR?  THEN ;
  219.  
  220.  
  221. \ Add file extension a2 u2 if none present in file a u.
  222. : +EXT ( a u a2 u2 - a3 u3)
  223.    2OVER [CHAR] . SCAN NIP IF  2DROP  ELSE  STRCAT  THEN ;
  224.  
  225. \ Remove file extension, if any, by shortening string.
  226. : -EXT ( a u - a2 u2)
  227.    2DUP  [CHAR] . SCAN IF  NIP OVER -  0 THEN  DROP ;
  228.  
  229. \ Evaluate the following file.
  230. : INCLUDING ( " <name> ")
  231.    BL WORD COUNT " .SRC" +EXT INCLUDE-FILE ;
  232.  
  233.  
  234. \ Treat the rest of the line as a comment, like this one.
  235. : \ ( " ccc")
  236.     #TIB @ >IN ! ;
  237. IMMEDIATE
  238.  
  239.  
  240. \ Force next line of evaluation file.
  241. : INQUIRE ( - f)
  242.   EVQUERY ( eof) >R  #TIB 2!  >IN OFF  1 EVLINE# +!   R> ;
  243.  
  244. \ Skip lines between \* and *\'s as comments.
  245. : \* ( " ...")
  246.    BEGIN BEGIN BL WORD COUNT  DUP
  247.          WHILE 2 = DUP IF  OVER @ " *\" DROP @ = AND  THEN  NIP
  248.            IF  EXIT  THEN
  249.          REPEAT  2DROP
  250.          INQUIRE NOT IF  EXIT  THEN
  251.    AGAIN ;
  252. IMMEDIATE
  253.