home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / FFA.ZIP / HANDLES.SEQ < prev    next >
Encoding:
Text File  |  1988-01-06  |  9.0 KB  |  278 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. 70 CONSTANT B/HCB  68 CONSTANT HNDLOFFSET
  15. VARIABLE RWERR
  16.  
  17.                 \ Attrib is normally  zero (0) for Read/Write.
  18.                 \ Attrib may be set to one (1) for Write ONLY.
  19.                 \ Attrib may be set to two (2) for Read  ONLY.
  20. : >ATTRIB       ( handle --- attrib-addr )      66 + ;
  21.  
  22. : >HNDLE        ( handle --- handle-addr )      HNDLOFFSET + ;
  23. : >NAM          ( handle --- name-string-addr ) 1+   ;
  24. : CLR-HCB       ( HANDLE - ) DUP B/HCB ERASE -1 SWAP >HNDLE ! ;
  25.  
  26.                 \  defining    running
  27. : HANDLE        ( name ---  |  --- addr )
  28.                  CREATE HERE B/HCB ALLOT CLR-HCB ;
  29.  
  30.         \       The HANDLE memory data structure is as shown here.
  31.  
  32.         \         1byte    65 bytes      2 bytes    2 bytes
  33.         \       [ count  ] [ name....0 ] [ attrib ] [ handle > -1 ]
  34.         \         addr       addr+1        addr+66    addr+68
  35.         \          |          |             |          |
  36.         \          |          |_>NAM        |_>ATTRIB  |_>HNDLE
  37.         \          |
  38.         \          |_Address of the array returned by a word
  39.         \            defined with HANDLE.
  40.  
  41. CREATE DEFEXT 3 C,-T ASCII S C,-T ASCII E C,-T ASCII Q C,-T 4 ALLOT
  42.  
  43. : ?DEF.EXT      ( handle --- )    \ maybe add an extension to file
  44.                  dup c@ 60 > if drop exit then
  45.                  >r true r@ count bounds
  46.                ?do      i c@ ascii . =
  47.                         if      drop false leave
  48.                         then
  49.                 loop      \ returns true if no decimal point found
  50.                 if      defext count r@ count + 1+ swap cmove
  51.                         ascii . r@ count + c! 4 r@ c@ + r@ c!
  52.                 then    r> drop ;
  53.  
  54. : $>HANDLE       ( a1 a2 --- )
  55.                  dup >r CLR-HCB
  56.                  count 64 min dup r@ c! r@ 1+ swap
  57.                  0 max cmove 0 r@ count + c!
  58.                  r> ?DEF.EXT ;
  59.  
  60. : !HCB          ( handle --- )
  61.                  BL WORD CAPS @
  62.                  IF      DUP COUNT UPPER
  63.                  THEN    SWAP $>HANDLE ;
  64.  
  65. : FCB>HANDLE    ( A1 A2 --- )
  66.                 DUP CLR-HCB
  67.                 1+ DUP >R SWAP 1+ DUP >R 8 OVER + SWAP
  68.                 DO      I C@ BL = ?LEAVE
  69.                         I C@ OVER C! 1+
  70.                 LOOP    ASCII . OVER C! 1+
  71.                 R> 8 + 3 OVER + SWAP
  72.                 DO      I C@ BL = ?LEAVE
  73.                         I C@ OVER C! 1+
  74.                 LOOP    0 OVER C! R@ - R> 1- C! ;
  75.  
  76. : HANDLE>EXT    ( handle -- a1 )
  77.                 count + dup dup 4 -
  78.                 do      i c@ ascii . =
  79.                         if      drop i leave  then
  80.                 loop    ; \ points to final decimal point if present
  81.  
  82. : $>EXT         ( string-extension handle --- )
  83.                 dup c@ 60 > if 2drop exit then
  84.                 dup >r handle>ext
  85.                 ascii . over c! 1+ >r count r@
  86.                 swap cmove r> 3 + 0 over c! r@ - 1- r> c! ;
  87.  
  88. HEX
  89.  
  90. CODE HDOS1      ( cx dx fun -- ax cf | error-code 1 )
  91.                 pop ax
  92.                 pop dx
  93.                 pop cx
  94.                 int 21
  95.                 push ax
  96.              u< if
  97.                 mov al, # 1
  98.              else
  99.                 mov al, # 0
  100.              then
  101.                 sub ah, ah
  102.                 1push
  103.                 end-code
  104.  
  105. CODE HDOS3      ( bx cx dx ds fun -- ax cf | error-code 1 )
  106.                 pop ax
  107.                 pop ds
  108.                 pop dx
  109.                 pop cx
  110.                 pop bx
  111.                 int 21
  112.                 push ax
  113.              u< if
  114.                 mov al, # 1
  115.              else
  116.                 mov al, # 0
  117.              then
  118.                 sub ah, ah
  119.                 push ax
  120.                 mov ax, cs
  121.                 mov ds, ax
  122.                 next
  123.                 end-code
  124.  
  125. CODE HDOS4      ( bx cx dx fun -- ax cf | error-code 1 )
  126.                 pop ax
  127.                 pop dx
  128.                 pop cx
  129.                 pop bx
  130.                 int 21
  131.                 push ax
  132.              u< if
  133.                 mov al, # 1
  134.              else
  135.                 mov al, # 0
  136.              then
  137.                 sub ah, ah
  138.                 1push
  139.                 end-code
  140.  
  141. CODE MOVEPOINTER ( double-offset handle --- )
  142.                 pop bx
  143.                 ADD bx, # HNDLOFFSET
  144.                 mov ax, 0 [bx]
  145.                 mov bx, ax
  146.                 pop cx
  147.                 pop dx
  148.                 mov ax, # 4200  \ from start of file
  149.                 int 21
  150.                 next
  151.                 end-code
  152.  
  153. CODE ENDFILE    ( handle --- double-end )
  154.                 pop bx
  155.                 ADD bx, # HNDLOFFSET
  156.                 mov ax, 0 [bx]
  157.                 mov bx, ax
  158.                 mov cx, # 0
  159.                 mov dx, # 0
  160.                 mov ax, # 4202  \ from end of file
  161.                 int 21
  162.              u< if
  163.                 sub ax, ax
  164.              then
  165.                 push ax
  166.                 push dx
  167.                 next
  168.                 end-code
  169. DECIMAL
  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. HEX
  182.  
  183. CODE <HRENAME>  ( handle1 handle2 --- ax cf=0 | error-code 1 )
  184.                 pop bx
  185.                 add bx, # 1
  186.                 mov di, bx
  187.                 pop bx
  188.                 push es         \ Save ES for later restoral
  189.                 mov ax, ds
  190.                 mov es, ax      \ set es to ds
  191.                 add bx, # 1
  192.                 mov dx, bx
  193.                 mov ax, # 5600  \ from start of file
  194.                 int 21
  195.                 pop es          \ Restore ES
  196.                 push ax
  197.              u< if
  198.                 mov al, # 1
  199.              else
  200.                 mov al, # 0
  201.              then
  202.                 sub ah, ah
  203.                 1push
  204.                 end-code
  205.                         \ returns 18 if the rename was good, not zero.
  206.  
  207. : HRENAME       ( HANDLE1 HANDLE2 --- RETURN-CODE )
  208.                 DUP PATHSET DROP OVER PATHSET DROP
  209.                 <HRENAME>
  210.                 if      0FF and
  211.                 else    drop 0
  212.                 then    ;
  213.  
  214. : HCREATE       ( handle --- error-code )
  215.                 DUP PATHSET ?dup if  swap drop exit then
  216.                 dup >hndle >r       \     save handle address
  217.                 dup >attrib @         \   hndl --- bx hndl attib
  218.                 swap >nam               \ --- bx attrib name
  219.                 3C02 hdos1 0=
  220.                 if      r@ ! 0      \ stuff handle, ret 0
  221.                 else    0FF and
  222.                 then    r> drop ;
  223.  
  224. VARIABLE RWMODE 2 RWMODE !-T    \ default to read/write
  225.  
  226. : HOPEN         ( handle --- error-code )
  227.                 DUP PATHSET ?dup if  swap drop exit then
  228.                 dup >hndle >r   \           save handle address
  229.                 dup >attrib @     \         hndl --- hndl attib
  230.                 swap >nam           \       --- attrib name
  231.                 3D00 rwmode @ or      \
  232.                 hdos1 0=                \   read/write attribs
  233.                 if      r@ ! 0            \ stuff handle, ret 0
  234.                 else    0FF and             \ else error code
  235.                 then    r> drop ;             \ clean rstack
  236.  
  237. : HCLOSE        ( handle --- return-code )
  238.                 >hndle dup @ -1 rot ! dup -1 >
  239.                 if      0 0 3E00 hdos4
  240.                         if      0FF and
  241.                         else    drop 0 then
  242.                 else    drop 0
  243.                 then    ;
  244.  
  245. : HDELETE       ( handle --- return-code )
  246.                 0 0 rot >nam 4100 hdos4
  247.                 if 0FF and else drop 0 then ;
  248.  
  249.                 \ extended read
  250. : EXHREAD       ( a1 n1 handle segment -- length-read )
  251.                 >r >hndle @ -rot swap r> 3F00 hdos3
  252.                 if      0FF and rwerr ! 0 then ;
  253.  
  254.                 \ extended write
  255. : EXHWRITE      ( a1 n1 handle segment -- length-written )
  256.                 >r >hndle @ -rot swap r> 4000 hdos3
  257.                 if      0FF and rwerr ! 0 then ;
  258.  
  259. : HWRITE        ( a1 n1 handle --- length-written )
  260.                 >hndle @ rot rot swap    \ handle count addr
  261.                 4000 hdos4 if   0FF and rwerr ! 0 then ;
  262.  
  263. : HREAD         ( a1 n1 handle --- length-read )
  264.                 >hndle @ rot rot swap    \ handle count addr
  265.                 3F00 hdos4 if   0FF and rwerr ! 0 then ;
  266.  
  267. : FINDFIRST     ( string --- f1 )
  268.                 010 swap 4E00 hdos1 drop 0FF and ;
  269.  
  270. : FINDNEXT      ( --- f1 )
  271.                 000  000 4F00 hdos1 drop 0FF and ;
  272.  
  273. DECIMAL
  274.  
  275. : SET-DTA       ( A1 --- )
  276.                 26 BDOS DROP ;
  277.  
  278.