home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / thandles.seq < prev    next >
Encoding:
Text File  |  1990-10-29  |  8.3 KB  |  235 lines
  1. \ THANDLES.SEQ          Handle impementation file       by Tom Zimmer
  2.  
  3. \ This file contains the code to talk to a file with the
  4. \ DOS 2.00+ handle routines.
  5.  
  6. FORTH DECIMAL TARGET >LIBRARY       \ A library file
  7.  
  8. TABLE DEFEXT    0 C,                                    \ length is zero
  9.                 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C,      \ extra space
  10. END-TABLE
  11.  
  12. : ?DEF.EXT      ( handle --- )    \ maybe add an extension to file
  13.                 dup c@ 60 > if drop exit then
  14.                 >r true r@ count bounds
  15.                ?do      i c@ '.' =
  16.                         if      drop false leave
  17.                         then
  18.                 loop      \ returns true if no decimal point found
  19.                 if      defext c@
  20.                         if      defext count r@ count + 1+ swap cmove
  21.                                 '.' r@ count + c!
  22.                                 defext c@ 1+ r@ c@ + r@ c!
  23.                         then
  24.                 then    r>drop ;
  25.  
  26. : $>HANDLE       ( a1 a2 --- )
  27.                  DUP>R CLR-HCB
  28.                  COUNT 64 MIN DUP R@ C! R@ 1+ SWAP
  29.                  0MAX CMOVE 0 R@ COUNT + C!
  30.                  R> ?DEF.EXT ;
  31.  
  32. : HANDLE>EXT    ( handle -- a1 )
  33.                 count + dup dup 4 -
  34.                 do      i c@ '.' =
  35.                         if      drop i leave  then
  36.                 loop    ; \ points to final decimal point if present
  37.  
  38. : $>EXT         ( string-extension handle --- )
  39.                 dup c@ 60 > if 2drop exit then
  40.                 dup>r handle>ext
  41.                 '.' over c! 1+ >r count r@ over >r
  42.                 swap cmove r> r> + 0 over c! r@ - 1- r> c! ;
  43.  
  44. ICODE HDOS1     ( cx dx fun -- ax cf | error-code 1 )
  45.                 [ASSEMBLER]
  46.                 LODSW
  47.                 XCHG BX, AX
  48.                 MOV DX, BX
  49.                 MOV CX, 0 [SI]
  50.                 int $21
  51.                 MOV 0 [SI], AX
  52.              U< IF      MOV AL, # 1
  53.                 ELSE    MOV AL, # 0
  54.                 THEN
  55.                 SUB AH, AH
  56.                 MOV BX, AX
  57.                 RET             END-ICODE
  58.  
  59. ICODE HDOS3     ( bx cx dx ds fun -- ax cf | error-code 1 )
  60.                 [ASSEMBLER]
  61.                 PUSH DS
  62.                 MOV CX, BX
  63.                 LODSW           PUSH AX
  64.                 LODSW           MOV DX, AX
  65.                 LODSW           XCHG CX, AX
  66.                 MOV BX, 0 [SI]
  67.                 POP DS
  68.                 INT $21
  69.                 POP DS
  70.                 MOV 0 [SI], AX
  71.              U< IF      MOV AL, # 1
  72.                 ELSE    MOV AL, # 0
  73.                 THEN
  74.                 SUB AH, AH
  75.                 MOV BX, AX
  76.                 RET             END-ICODE
  77.  
  78. ICODE HDOS4     ( bx cx dx fun -- ax cf | error-code 1 )
  79.                 [ASSEMBLER]
  80.                 LODSW           MOV DX, AX
  81.                 LODSW           MOV CX, AX
  82.                 MOV AX, BX
  83.                 MOV BX, 0 [SI]
  84.                 int $21
  85.                 MOV 0 [SI], AX
  86.              U< IF      MOV AL, # 1
  87.                 ELSE    MOV AL, # 0
  88.                 THEN
  89.                 SUB AH, AH
  90.                 MOV BX, AX
  91.                 RET             END-ICODE
  92.  
  93. ICODE MOVEPOINTER ( double-offset handle --- )
  94.                 [ASSEMBLER]
  95.                 ADD BX, # 68
  96.                 MOV BX, 0 [BX]
  97.                 LODSW           MOV CX, AX
  98.                 LODSW           MOV DX, AX
  99.                 MOV AX, # $4200  \ FROM START OF FILE
  100.                 INT $21
  101.                 LODSW           MOV BX, AX
  102.                 RET             END-ICODE
  103.  
  104. ICODE ENDFILE   ( handle --- double-end )
  105.                 [ASSEMBLER]
  106.                 ADD BX, # 68
  107.                 MOV BX, 0 [BX]
  108.                 MOV CX, # 0
  109.                 MOV DX, # 0
  110.                 MOV AX, # $4202         \ from end of file
  111.                 INT $21
  112.              U< IF
  113.                         SUB AX, AX
  114.                 THEN
  115.                 DEC SI
  116.                 DEC SI
  117.                 MOV 0 [SI], AX
  118.                 MOV BX, DX
  119.                 RET             END-ICODE
  120.  
  121. ICODE <HRENAME> ( handle1 handle2 --- ax cf=0 | error-code 1 )
  122.                 [ASSEMBLER]
  123.                 MOV DI, BX
  124.                 ADD DI, # 1
  125.                 MOV DX, 0 [SI]
  126.                 PUSH ES                 \ save ES for later restoral
  127.                 MOV AX, DS
  128.                 MOV ES, AX              \ set es to DS
  129.                 ADD DX, # 1
  130.                 MOV AX, # $5600         \ from start of file
  131.                 INT $21
  132.                 POP ES                  \ restore ES
  133.                 MOV 0 [SI], AX
  134.              U< IF      MOV BX, # 1
  135.                 ELSE    MOV BX, # 0
  136.                 THEN
  137.                 RET             END-ICODE
  138.                         \ returns 18 if the rename was good, not zero.
  139.  
  140. : HRENAME       ( handle1 handle2 --- return-code )
  141.                 <HRENAME>
  142.                 if      $0FF and
  143.                 else    drop 0
  144.                 then    ;
  145.  
  146. : HCREATE       ( handle --- error-code )
  147.                 dup >hndle >r           \     save handle address
  148.                 0 swap >nam             \ --- bx attrib name
  149.                 $3C02 hdos1 0=
  150.                 if      r@ ! 0          \ stuff handle, ret 0
  151.                 else    $0FF and
  152.                 then    r>drop ;
  153.  
  154. 0 VALUE R/W-MODE                \ current read/write mode
  155. 0 VALUE R/W-DMODE               \ default read/write mode
  156.  
  157. \ This word allow you to set the default read/write mode used by F-PC.
  158. \ It is used as follows:
  159. \                               READ-WRITE DEF-RWMODE
  160. \                       or      READ-ONLY  DEF-RWMODE
  161. \
  162. \ All further file open operations will be in the newly specified mode.
  163.  
  164. : DEF-RWMODE    ( -- )          \ use current mode as the default.
  165.                 r/w-mode !> r/w-dmode ;
  166.  
  167. \ The following words effect only the next HOPEN operation to be performed.
  168. \ After the open is done, R/W-MODE reverts to the the default mode for later
  169. \ file opens.
  170.  
  171. : READ-ONLY     ( -- )          \ open a file for read only
  172.                 0 !> r/w-mode ;
  173.  
  174. : READ-WRITE    ( -- )          \ open a file for read and write operations
  175.                 2 !> r/w-mode ;
  176.  
  177. : WRITE-ONLY    ( -- )          \ open a file for write only.
  178.                 1 !> r/w-mode ;
  179.  
  180. : HOPEN         ( handle --- error-code )
  181.                 DUP PATHSET ?dup if  nip exit then
  182.                 dup >hndle >r           \ save handle address
  183.                 dup >attrib @           \ hndl --- hndl attib
  184.                 swap >nam               \ --- attrib name
  185.                 $3D00 r/w-mode or
  186.                 hdos1 0=                \   read/write attribs
  187.                 if      r@ ! 0          \ stuff handle, ret 0
  188.                 else    $0FF and        \ else error code
  189.                 then    r>drop          \ clean rstack
  190.                 r/w-dmode !> r/w-mode ;  \ revert to default mode
  191.  
  192. : HCLOSE        ( handle --- return-code )
  193.                 >hndle dup @ -1 rot ! dup 0<
  194.                 if      drop 0
  195.                         exit            \ LEAVE NOW
  196.                 then
  197.                 0 0 $3E00 hdos4
  198.                 if      $0FF and
  199.                 else    drop 0
  200.                 then    ;
  201.  
  202. : HDELETE       ( handle --- return-code )
  203.                 0 0 rot >nam $4100 hdos4
  204.                 if $0FF and else drop 0 then ;
  205.  
  206.                 \ extended read
  207. : EXHREAD       ( a1 n1 handle segment -- length-read )
  208.                 >r >hndle @ -rot swap r> $3F00 hdos3
  209.                 if      $0FF and rwerr ! 0 then ;
  210.  
  211.                 \ extended write
  212. : EXHWRITE      ( a1 n1 handle segment -- length-written )
  213.                 >r >hndle @ -rot swap r> $4000 hdos3
  214.                 if      $0FF and rwerr ! 0 then ;
  215.  
  216. : HWRITE        ( a1 n1 handle --- length-written )
  217.                 >hndle @ -rot swap    \ handle count addr
  218.                 $4000 hdos4 if   $0FF and rwerr ! 0 then ;
  219.  
  220. : HREAD         ( a1 n1 handle --- length-read )
  221.                 >hndle @ -rot swap    \ handle count addr
  222.                 $3F00 hdos4 if   $0FF and rwerr ! 0 then ;
  223.  
  224. : FINDFIRST     ( string --- f1 )
  225.                 $010 swap $4E00 hdos1 drop $0FF and ;
  226.  
  227. : FINDNEXT      ( --- f1 )
  228.                 $000  $000 $4F00 hdos1 drop $0FF and ;
  229.  
  230. : SET-DTA       ( A1 --- )
  231.                 $1A BDOS DROP ;
  232.  
  233. FORTH DECIMAL TARGET >TARGET
  234.  
  235.