home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / tpath.seq < prev    next >
Encoding:
Text File  |  1990-02-12  |  2.3 KB  |  56 lines
  1. \ PATHSET.SEQ   Words used to set the path of a file.   by Tom Zimmer
  2.  
  3. FORTH DECIMAL TARGET >LIBRARY       \ A Library file
  4.  
  5.    0 value flhndl            \ plugged later
  6.  
  7. : ?drive.extract ( handle --- drive-value )
  8.                 dup >nam 1+ c@ ':' =
  9.                 if      dup>r >nam c@ bl or 96 -
  10.                         r@ count 2- >r dup 2+ swap r> cmove
  11.                         r@ c@ 2- r@ c! r> count + off
  12.                 else    drop 0 25 bdos 1+ then    ;
  13.  
  14. : ?drive.prepend ( drive-value handle --- )
  15.                 over 0=
  16.                 if      2drop
  17.                 else    dup>r count >r dup 2+ r> cmove>
  18.                         64 + r@ >nam c! ':' r@ >nam 1+ c!
  19.                         r@ c@ 2+ r> c!
  20.                 then    ;
  21.  
  22. handle pathhndl
  23.  
  24. : get_curpath   ( n1 -- f1 )    \ n1 current drive, f1 true if failed
  25.                 >r '\' pathhndl 1+ c! 64 pathhndl c!
  26.                 pathhndl 2+ r> pdos dup ?exit   \ leave if can't get path
  27.                 drop
  28.                 pathhndl 1+ 64 0   \ determine path length
  29.                 do      dup i + c@ 0= if i pathhndl c! leave then
  30.                 loop    drop pathhndl c@ 1 >
  31.                 if      '\' pathhndl count + c!
  32.                         pathhndl c@ 1+ pathhndl c!
  33.                 then    flhndl c@ pathhndl c@ + 62 > dup 0=
  34.                 if      drop
  35.                         flhndl 1+ pathhndl c@ over + flhndl c@ cmove>
  36.                         pathhndl count flhndl 1+ swap cmove
  37.                         pathhndl c@ flhndl c@ + flhndl c!
  38.                         false
  39.                 then    ;
  40.  
  41. : prepend.path  ( handle --- f1 )       \ return true if failed
  42.                 pathhndl clr-hcb
  43.                 dup =: flhndl ?drive.extract >r \ save drive number of rstack
  44.                 flhndl >nam c@ '\' =
  45.                 if      r> flhndl ?drive.prepend
  46.                         0 flhndl count + c!     \ null terminate filename
  47.                         false exit              \ leave we got a path already
  48.                 then    r@ get_curpath     ( -- f1 )
  49.                 r> flhndl ?drive.prepend        \ put crive number back in
  50.                 0 flhndl count + c! ;           \ null terminate filename
  51.  
  52. ' PREPEND.PATH ALIAS PATHSET
  53.  
  54. FORTH TARGET >TARGET
  55.  
  56.