home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / handles.seq < prev    next >
Text File  |  1991-04-10  |  10KB  |  299 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 n1 a2 -- )         \ move string a1,n1 to handle a2
  60.                 dup>r CLR-HCB
  61.                 64 min r@ place
  62.                 0 r@ count + c!
  63.                 r> ?DEF.EXT ;
  64.  
  65. : $>HANDLE      ( a1 a2 --- )           \ move counted string a1 to handle a2
  66.                 >r count r> ">handle ;
  67.  
  68. : !HCB          ( handle --- )
  69.                 BL WORD COUNT CAPS @
  70.                 IF      2DUP UPPER
  71.                 THEN    ROT ">HANDLE ;
  72.  
  73. : FCB>HANDLE    ( A1 A2 --- )
  74.                 DUP CLR-HCB
  75.                 1+ dup>r SWAP 1+ dup>r 8 OVER + SWAP
  76.                 DO      I C@ BL = ?LEAVE
  77.                         I C@ OVER C! 1+
  78.                 LOOP    ASCII . OVER C! 1+
  79.                 R> 8 + 3 OVER + SWAP
  80.                 DO      I C@ BL = ?LEAVE
  81.                         I C@ OVER C! 1+
  82.                 LOOP    0 OVER C! R@ - R> 1- C! ;
  83.  
  84. : HANDLE>EXT    ( handle -- a1 )
  85.                 count + dup dup 4 -
  86.                 do      i c@ ASCII . =
  87.                         if      drop i leave  then
  88.                 loop    ; \ points to final decimal point if present
  89.  
  90. : $>EXT         ( string-extension handle --- )
  91.                 dup c@ 60 > if 2drop exit then
  92.                 dup>r handle>ext
  93.                 ASCII . over c! 1+ >r count r@ over >r
  94.                 swap cmove r> r> + 0 over c! r@ - 1- r> c! ;
  95.  
  96. CODE HDOS1      ( cx dx fun -- ax cf | error-code 1 )
  97.                 pop ax
  98.                 pop dx
  99.                 pop cx
  100.                 int $21
  101.                 push ax
  102.              u< if
  103.                 mov al, # 1
  104.              else
  105.                 mov al, # 0
  106.              then
  107.                 sub ah, ah
  108.                 1push
  109.                 end-code
  110.  
  111. CODE HDOS3      ( bx cx dx ds fun -- ax cf | error-code 1 )
  112.                 pop ax
  113.                 pop ds
  114.                 pop dx
  115.                 pop cx
  116.                 pop bx
  117.                 int $21
  118.                 push ax
  119.              u< if
  120.                 mov al, # 1
  121.              else
  122.                 mov al, # 0
  123.              then
  124.                 sub ah, ah
  125.                 push ax
  126.                 mov ax, cs
  127.                 mov ds, ax
  128.                 next
  129.                 end-code
  130.  
  131. CODE HDOS4      ( bx cx dx fun -- ax cf | error-code 1 )
  132.                 pop ax
  133.                 pop dx
  134.                 pop cx
  135.                 pop bx
  136.                 int $21
  137.                 push ax
  138.              u< if
  139.                 mov al, # 1
  140.              else
  141.                 mov al, # 0
  142.              then
  143.                 sub ah, ah
  144.                 1push
  145.                 end-code
  146.  
  147. CODE MOVEPOINTER ( double-offset handle --- )
  148.                 pop bx
  149.                 ADD bx, # HNDLOFFSET
  150.                 mov bx, 0 [bx]
  151.                 pop cx
  152.                 pop dx
  153.                 mov ax, # $4200  \ from start of file
  154.                 int $21
  155.                 next
  156.                 end-code
  157.  
  158. CODE ENDFILE    ( handle --- double-end )
  159.                 pop bx
  160.                 add bx, # hndloffset
  161.                 mov bx, 0 [bx]
  162.                 mov cx, # 0
  163.                 mov dx, # 0
  164.                 mov ax, # $4202  \ from end of file
  165.                 int $21
  166.              u< if
  167.                 sub ax, ax
  168.              then
  169.                 push ax
  170.                 push dx
  171.                 next
  172.                 end-code
  173.  
  174. DEFER PATHSET   ( handle --- f1 )
  175.  
  176. ' 0= IS PATHSET
  177.  
  178. \   Code loaded later is plugged into PATHSET, to prepend the
  179. \ current path to the handle specified on the top of the stack.
  180. \
  181. \   The returned vlue is zero if the path was set properly, or
  182. \ non-zero if an error occured while setting the path.
  183.  
  184. CODE <HRENAME>  ( handle1 handle2 --- ax cf=0 | error-code 1 )
  185.                 pop di
  186.                 add di, # 1
  187.                 pop dx
  188.                 push es         \ Save ES for later restoral
  189.                 mov ax, ds
  190.                 mov es, ax      \ set es to ds
  191.                 add dx, # 1
  192.                 mov ax, # $5600  \ from start of file
  193.                 int $21
  194.                 pop es          \ Restore ES
  195.                 push ax
  196.              u< if
  197.                 mov ax, # 1
  198.              else
  199.                 mov ax, # 0
  200.              then
  201.                 1push
  202.                 end-code
  203.                         \ returns 18 if the rename was good, not zero.
  204.  
  205. : HRENAME       ( handle1 handle2 --- return-code )
  206.                 DUP PATHSET DROP OVER PATHSET DROP
  207.                 <HRENAME>
  208.                 if      $0FF and
  209.                 else    drop 0
  210.                 then    ;
  211.  
  212. : HCREATE       ( handle --- error-code )
  213.                 DUP PATHSET ?dup if  nip exit then
  214.                 dup >hndle >r       \     save handle address
  215.                 dup >attrib @         \   hndl --- bx hndl attib
  216.                 swap >nam               \ --- bx attrib name
  217.                 $3C02 hdos1 0=
  218.                 if      r@ ! 0      \ stuff handle, ret 0
  219.                 else    $0FF and
  220.                 then    r>drop ;
  221.  
  222. 0 VALUE R/W-MODE                \ current read/write mode
  223. 0 VALUE R/W-DMODE               \ default read/write mode
  224.  
  225. \ This word allow you to set the default read/write mode used by F-PC.
  226. \ It is used as follows:
  227. \                               READ-WRITE DEF-RWMODE
  228. \                       or      READ-ONLY  DEF-RWMODE
  229. \
  230. \ All further file open operations will be in the newly specified mode.
  231.  
  232. : DEF-RWMODE    ( -- )          \ use current mode as the default.
  233.                 r/w-mode %!> r/w-dmode ;
  234.  
  235. \ The following words effect only the next HOPEN operation to be performed.
  236. \ After the open is done, R/W-MODE reverts to the the default mode for later
  237. \ file opens.
  238.  
  239. : READ-ONLY     ( -- )          \ open a file for read only
  240.                 0 %!> r/w-mode ;
  241.  
  242. : READ-WRITE    ( -- )          \ open a file for read and write operations
  243.                 2 %!> r/w-mode ;
  244.  
  245. : WRITE-ONLY    ( -- )          \ open a file for write only.
  246.                 1 %!> r/w-mode ;
  247.  
  248. : HOPEN         ( handle --- error-code )
  249.                 DUP PATHSET ?dup if  nip exit then
  250.                 dup >hndle >r           \ save handle address
  251.                 dup >attrib @           \ hndl --- hndl attib
  252.                 swap >nam               \ --- attrib name
  253.                 $3D00 r/w-mode or
  254.                 hdos1 0=                \   read/write attribs
  255.                 if      r@ ! 0          \ stuff handle, ret 0
  256.                 else    $0FF and        \ else error code
  257.                 then    r>drop          \ clean rstack
  258.                 r/w-dmode %!> r/w-mode ;  \ revert to default mode
  259.  
  260. : HCLOSE        ( handle --- return-code )
  261.                 >hndle dup @ -1 rot ! dup -1 >
  262.                 if      0 0 $3E00 hdos4
  263.                         if      $0FF and
  264.                         else    drop 0 then
  265.                 else    drop 0
  266.                 then    ;
  267.  
  268. : HDELETE       ( handle --- return-code )
  269.                 0 0 rot >nam $4100 hdos4
  270.                 if $0FF and else drop 0 then ;
  271.  
  272.                 \ extended read
  273. : EXHREAD       ( a1 n1 handle segment -- length-read )
  274.                 >r >hndle @ -rot swap r> $3F00 hdos3
  275.                 if      $0FF and rwerr ! 0 then ;
  276.  
  277.                 \ extended write
  278. : EXHWRITE      ( a1 n1 handle segment -- length-written )
  279.                 >r >hndle @ -rot swap r> $4000 hdos3
  280.                 if      $0FF and rwerr ! 0 then ;
  281.  
  282. : HWRITE        ( a1 n1 handle --- length-written )
  283.                 >hndle @ -rot swap    \ handle count addr
  284.                 $4000 hdos4 if   $0FF and rwerr ! 0 then ;
  285.  
  286. : HREAD         ( a1 n1 handle --- length-read )
  287.                 >hndle @ -rot swap    \ handle count addr
  288.                 $3F00 hdos4 if   $0FF and rwerr ! 0 then ;
  289.  
  290. : FINDFIRST     ( string --- f1 )
  291.                 $010 swap $4E00 hdos1 drop $0FF and ;
  292.  
  293. : FINDNEXT      ( --- f1 )
  294.                 $000  $000 $4F00 hdos1 drop $0FF and ;
  295.  
  296. : SET-DTA       ( A1 --- )
  297.                 $1A BDOS DROP ;
  298.  
  299.