home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PROGRAMS / UTILS / LASER / FPC35_5.ZIP / FPCSRC.ZIP / HANDLES.SEQ < prev    next >
Encoding:
Text File  |  1989-09-21  |  9.9 KB  |  296 lines
  1. \ HANDLES.SEQ   Handle impementation file               by Tom Zimmer
  2.  
  3. \ Link this file into the FILELIST chain.
  4.  
  5. FILES DEFINITIONS
  6.  
  7. VARIABLE HANDLES.SEQ
  8.  
  9. FORTH DEFINITIONS
  10.  
  11. \ This file contains the code to talk to a file with the
  12. \ DOS 2.00+ handle routines.
  13.  
  14. DECIMAL
  15.  
  16. 70 CONSTANT B/HCB  68 CONSTANT HNDLOFFSET
  17. VARIABLE RWERR
  18.  
  19.                 \ Attrib is normally  zero (0) for Read/Write.
  20.                 \ Attrib may be set to one (1) for Write ONLY.
  21.                 \ Attrib may be set to two (2) for Read  ONLY.
  22. : >ATTRIB       ( handle --- attrib-addr )      66 + ;
  23.  
  24. : >HNDLE        ( handle --- handle-addr )      HNDLOFFSET + ;
  25. : >NAM          ( handle --- name-string-addr ) 1+   ;
  26. : CLR-HCB       ( HANDLE - ) DUP B/HCB ERASE -1 SWAP >HNDLE ! ;
  27.  
  28.                 \  defining    running
  29. : HANDLE        ( name ---  |  --- addr )
  30.                  CREATE HERE B/HCB ALLOT CLR-HCB ;
  31.  
  32.         \       The HANDLE memory data structure is as shown here.
  33.  
  34.         \         1byte    65 bytes      2 bytes    2 bytes
  35.         \       [ count  ] [ name....0 ] [ attrib ] [ handle > -1 ]
  36.         \         addr       addr+1        addr+66    addr+68
  37.         \          |          |             |          |
  38.         \          |          |_>NAM        |_>ATTRIB  |_>HNDLE
  39.         \          |
  40.         \          |_Address of the array returned by a word
  41.         \            defined with HANDLE.
  42.  
  43. CREATE DEFEXT 3 C,-T ASCII S C,-T ASCII E C,-T ASCII Q C,-T 4 ALLOT
  44.  
  45. : ?DEF.EXT      ( handle --- )    \ maybe add an extension to file
  46.                  dup c@ 60 > if drop exit then
  47.                  >r true r@ count bounds
  48.                ?do      i c@ ASCII . =
  49.                         if      drop false leave
  50.                         then
  51.                 loop      \ returns true if no decimal point found
  52.                 if      defext c@
  53.                         if      defext count r@ count + 1+ swap cmove
  54.                                 ASCII . r@ count + c!
  55.                                 defext c@ 1+ r@ c@ + r@ c!
  56.                         then
  57.                 then    r>drop ;
  58.  
  59. : $>HANDLE       ( a1 a2 --- )
  60.                  dup>r CLR-HCB
  61.                  count 64 min dup r@ c! r@ 1+ swap
  62.                  0MAX cmove 0 r@ count + c!
  63.                  r> ?DEF.EXT ;
  64.  
  65. : !HCB          ( handle --- )
  66.                  BL WORD CAPS @
  67.                  IF      DUP COUNT UPPER
  68.                  THEN    SWAP $>HANDLE ;
  69.  
  70. : FCB>HANDLE    ( A1 A2 --- )
  71.                 DUP CLR-HCB
  72.                 1+ dup>r SWAP 1+ dup>r 8 OVER + SWAP
  73.                 DO      I C@ BL = ?LEAVE
  74.                         I C@ OVER C! 1+
  75.                 LOOP    ASCII . OVER C! 1+
  76.                 R> 8 + 3 OVER + SWAP
  77.                 DO      I C@ BL = ?LEAVE
  78.                         I C@ OVER C! 1+
  79.                 LOOP    0 OVER C! R@ - R> 1- C! ;
  80.  
  81. : HANDLE>EXT    ( handle -- a1 )
  82.                 count + dup dup 4 -
  83.                 do      i c@ ASCII . =
  84.                         if      drop i leave  then
  85.                 loop    ; \ points to final decimal point if present
  86.  
  87. : $>EXT         ( string-extension handle --- )
  88.                 dup c@ 60 > if 2drop exit then
  89.                 dup>r handle>ext
  90.                 ASCII . over c! 1+ >r count r@ over >r
  91.                 swap cmove r> r> + 0 over c! r@ - 1- r> c! ;
  92.  
  93. CODE HDOS1      ( cx dx fun -- ax cf | error-code 1 )
  94.                 pop ax
  95.                 pop dx
  96.                 pop cx
  97.                 int $21
  98.                 push ax
  99.              u< if
  100.                 mov al, # 1
  101.              else
  102.                 mov al, # 0
  103.              then
  104.                 sub ah, ah
  105.                 1push
  106.                 end-code
  107.  
  108. CODE HDOS3      ( bx cx dx ds fun -- ax cf | error-code 1 )
  109.                 pop ax
  110.                 pop ds
  111.                 pop dx
  112.                 pop cx
  113.                 pop bx
  114.                 int $21
  115.                 push ax
  116.              u< if
  117.                 mov al, # 1
  118.              else
  119.                 mov al, # 0
  120.              then
  121.                 sub ah, ah
  122.                 push ax
  123.                 mov ax, cs
  124.                 mov ds, ax
  125.                 next
  126.                 end-code
  127.  
  128. CODE HDOS4      ( bx cx dx fun -- ax cf | error-code 1 )
  129.                 pop ax
  130.                 pop dx
  131.                 pop cx
  132.                 pop bx
  133.                 int $21
  134.                 push ax
  135.              u< if
  136.                 mov al, # 1
  137.              else
  138.                 mov al, # 0
  139.              then
  140.                 sub ah, ah
  141.                 1push
  142.                 end-code
  143.  
  144. CODE MOVEPOINTER ( double-offset handle --- )
  145.                 pop bx
  146.                 ADD bx, # HNDLOFFSET
  147.                 mov bx, 0 [bx]
  148.                 pop cx
  149.                 pop dx
  150.                 mov ax, # $4200  \ from start of file
  151.                 int $21
  152.                 next
  153.                 end-code
  154.  
  155. CODE ENDFILE    ( handle --- double-end )
  156.                 pop bx
  157.                 add bx, # hndloffset
  158.                 mov bx, 0 [bx]
  159.                 mov cx, # 0
  160.                 mov dx, # 0
  161.                 mov ax, # $4202  \ from end of file
  162.                 int $21
  163.              u< if
  164.                 sub ax, ax
  165.              then
  166.                 push ax
  167.                 push dx
  168.                 next
  169.                 end-code
  170.  
  171. DEFER PATHSET   ( handle --- f1 )
  172.  
  173. ' 0= IS PATHSET
  174.  
  175. \   Code loaded later is plugged into PATHSET, to prepend the
  176. \ current path to the handle specified on the top of the stack.
  177. \
  178. \   The returned vlue is zero if the path was set properly, or
  179. \ non-zero if an error occured while setting the path.
  180.  
  181. CODE <HRENAME>  ( handle1 handle2 --- ax cf=0 | error-code 1 )
  182.                 pop di
  183.                 add di, # 1
  184.                 pop dx
  185.                 push es         \ Save ES for later restoral
  186.                 mov ax, ds
  187.                 mov es, ax      \ set es to ds
  188.                 add dx, # 1
  189.                 mov ax, # $5600  \ from start of file
  190.                 int $21
  191.                 pop es          \ Restore ES
  192.                 push ax
  193.              u< if
  194.                 mov ax, # 1
  195.              else
  196.                 mov ax, # 0
  197.              then
  198.                 1push
  199.                 end-code
  200.                         \ returns 18 if the rename was good, not zero.
  201.  
  202. : HRENAME       ( handle1 handle2 --- return-code )
  203.                 DUP PATHSET DROP OVER PATHSET DROP
  204.                 <HRENAME>
  205.                 if      $0FF and
  206.                 else    drop 0
  207.                 then    ;
  208.  
  209. : HCREATE       ( handle --- error-code )
  210.                 DUP PATHSET ?dup if  swap drop exit then
  211.                 dup >hndle >r       \     save handle address
  212.                 dup >attrib @         \   hndl --- bx hndl attib
  213.                 swap >nam               \ --- bx attrib name
  214.                 $3C02 hdos1 0=
  215.                 if      r@ ! 0      \ stuff handle, ret 0
  216.                 else    $0FF and
  217.                 then    r>drop ;
  218.  
  219. 0 VALUE R/W-MODE                \ current read/write mode
  220. 0 VALUE R/W-DMODE               \ default read/write mode
  221.  
  222. \ This word allow you to set the default read/write mode used by F-PC.
  223. \ It is used as follows:
  224. \                               READ-WRITE DEF-RWMODE
  225. \                       or      READ-ONLY  DEF-RWMODE
  226. \
  227. \ All further file open operations will be in the newly specified mode.
  228.  
  229. : DEF-RWMODE    ( -- )          \ use current mode as the default.
  230.                 r/w-mode %!> r/w-dmode ;
  231.  
  232. \ The following words effect only the next HOPEN operation to be performed.
  233. \ After the open is done, R/W-MODE reverts to the the default mode for later
  234. \ file opens.
  235.  
  236. : READ-ONLY     ( -- )          \ open a file for read only
  237.                 0 %!> r/w-mode ;
  238.  
  239. : READ-WRITE    ( -- )          \ open a file for read and write operations
  240.                 2 %!> r/w-mode ;
  241.  
  242. : WRITE-ONLY    ( -- )          \ open a file for write only.
  243.                 1 %!> r/w-mode ;
  244.  
  245. : HOPEN         ( handle --- error-code )
  246.                 DUP PATHSET ?dup if  nip exit then
  247.                 dup >hndle >r           \ save handle address
  248.                 dup >attrib @           \ hndl --- hndl attib
  249.                 swap >nam               \ --- attrib name
  250.                 $3D00 r/w-mode or
  251.                 hdos1 0=                \   read/write attribs
  252.                 if      r@ ! 0          \ stuff handle, ret 0
  253.                 else    $0FF and        \ else error code
  254.                 then    r>drop          \ clean rstack
  255.                 r/w-dmode %!> r/w-mode ;  \ revert to default mode
  256.  
  257. : HCLOSE        ( handle --- return-code )
  258.                 >hndle dup @ -1 rot ! dup -1 >
  259.                 if      0 0 $3E00 hdos4
  260.                         if      $0FF and
  261.                         else    drop 0 then
  262.                 else    drop 0
  263.                 then    ;
  264.  
  265. : HDELETE       ( handle --- return-code )
  266.                 0 0 rot >nam $4100 hdos4
  267.                 if $0FF and else drop 0 then ;
  268.  
  269.                 \ extended read
  270. : EXHREAD       ( a1 n1 handle segment -- length-read )
  271.                 >r >hndle @ -rot swap r> $3F00 hdos3
  272.                 if      $0FF and rwerr ! 0 then ;
  273.  
  274.                 \ extended write
  275. : EXHWRITE      ( a1 n1 handle segment -- length-written )
  276.                 >r >hndle @ -rot swap r> $4000 hdos3
  277.                 if      $0FF and rwerr ! 0 then ;
  278.  
  279. : HWRITE        ( a1 n1 handle --- length-written )
  280.                 >hndle @ -rot swap    \ handle count addr
  281.                 $4000 hdos4 if   $0FF and rwerr ! 0 then ;
  282.  
  283. : HREAD         ( a1 n1 handle --- length-read )
  284.                 >hndle @ -rot swap    \ handle count addr
  285.                 $3F00 hdos4 if   $0FF and rwerr ! 0 then ;
  286.  
  287. : FINDFIRST     ( string --- f1 )
  288.                 $010 swap $4E00 hdos1 drop $0FF and ;
  289.  
  290. : FINDNEXT      ( --- f1 )
  291.                 $000  $000 $4F00 hdos1 drop $0FF and ;
  292.  
  293. : SET-DTA       ( A1 --- )
  294.                 $1A BDOS DROP ;
  295.  
  296.