home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / fpath.seq < prev    next >
Text File  |  1990-07-03  |  6KB  |  144 lines
  1. \ FPATH.SEQ     Allow easy open/load of files from OTHER directories
  2.  
  3. \ Link this file into the FILELIST chain.
  4.  
  5. FILES DEFINITIONS
  6.  
  7. VARIABLE FPATH.SEQ
  8.  
  9. FORTH DEFINITIONS
  10.  
  11. comment:
  12.  
  13.         This file allows F-PC to keep its system source files in a
  14.         different directory from your work directory. It also allows you
  15.         to specify 2 library directories for other utilities etc.
  16.  
  17.  
  18. comment;
  19.  
  20. CREATE FPATH$     160 ALLOT     \ Room for a LOO..NG path.
  21. CREATE PATHHNDL B/HCB ALLOT     \ A temporary handle
  22. 0 VALUE PATHPTR                 \ A pointer into the string of paths
  23. 0 VALUE PATHLEN
  24.  
  25. : PATH1         ( --- A1 )      \ return the first path, always current dir
  26.                 fpath$ count %!> pathlen        \ and length
  27.                              %!> pathptr        \ Reset the path pointer
  28.                 pathhndl dup>r clr-hcb          \ clear out the handle
  29.                 r@ pathset drop r> ;            \ install current directory
  30.  
  31. : NPATH         ( --- A1 F1 )           \ f1 = true if end of list
  32.                 pathptr pathlen                 \ a1 n1
  33.                 2dup ASCII ; scan               \ a1 n1 a2 n2
  34.                 1- 0MAX %!> pathlen      \ set new length
  35.                 dup 1+ %!> pathptr              \ and pointer
  36.                 nip over - dup pathhndl c!      \ set handle length
  37.                 pathhndl 1+ swap cmove          \ move the data
  38.                 pathhndl c@ >r
  39.                 pathhndl count + 1- c@ ASCII \ <>
  40.                 if      ASCII \ pathhndl count + c!
  41.                         1 pathhndl c+!
  42.                 then    pathhndl r> 0= ;
  43.  
  44. : SKIP.BLANKS   ( --- )
  45.                 source >in @ /string tuck bl skip nip - >in +! ;
  46.  
  47. : <FPATH+>      ( | <path> --- f1 )     \ f1 = true if null string
  48.                 skip.blanks
  49.                 ASCII ; word c@          \ we get a word
  50.                 fpath$ c@ 159 < and     \ and total length less than 132
  51.                 if      fpath$ c@ 0>
  52.                         if      ASCII ; fpath$ count + c! 1 fpath$ c+!  \ add ;
  53.                         then
  54.                         here count -trailing dup here c!
  55.                         fpath$ count + swap cmove    \ add path
  56.                         here c@ fpath$ c+!
  57.                 then    here c@ 0= ;
  58.  
  59. : FPATH+        ( | <paths-string> --- )
  60.                 %save>  #tib
  61.                 >in @   bl word drop >in @ #tib ! >in !
  62.                 begin   <fpath+>
  63.                 until   %restore> #tib ;
  64.  
  65.                 \ Set the current library path for LIBOPEN and LIBLOAD
  66. : FPATH         ( | <path-string> --- )
  67.                 fpath$ off              \ initialize the path string
  68.                 fpath+ ;
  69.  
  70.                 \ display the current library path
  71. : .FPATH        ( --- )
  72.                 fpath$ count type space ;
  73.  
  74.                 \ prepend the path in hndl to name at a1
  75. : PREPEND.APATH ( a1 hndl --- a1 )
  76.                 dup c@ >r                       \ save length of handle
  77.                 swap                            \ bring name to top
  78.                 dup  2+ c@ ASCII : =            \ do we already have a drive?
  79.                 over 1+ c@ ASCII \ = or         \ or a path specified?
  80.                 r> 0= or 0=                     \ or handle is empty
  81.                                                 \ skip prepend if we do
  82.              if dup c@ >r >r                    \ save name location & length
  83.                 r@ 1+ over c@ r@ + 1+ r@ c@ cmove> \ make room for path
  84.                 dup r@ over c@ 1+ cmove         \ move in path
  85.                 r> r> over c+!                  \ correct count
  86.              then  nip ;
  87.  
  88. CREATE FSAVE$ B/HCB ALLOT
  89.  
  90. : ?OPEN.ERROR   ( f1 --- )
  91.                 dup
  92.                 if      cr fsave$ count type
  93.                 then    abort" Open Error!" ;
  94.  
  95. : <$FILE>         ( a1 --- f1 )         \ f1 = true if failed to open
  96.                 fsave$ over c@ 1+ cmove
  97.                 fsave$ >r
  98.                 r@ here over c@ 1+ cmove
  99.                 here path1 prepend.apath
  100.                 $hopen  dup
  101.                 if      0=
  102.                         begin   r@ here over c@ 1+ cmove
  103.                                 npath   0=
  104.                                 if      here swap prepend.apath
  105.                                         $hopen 0=
  106.                                 else    drop 0= true
  107.                                 then
  108.                         until
  109.                 then    dup     \ if couldn't open, then show current
  110.                                 \ directory in error message
  111.                 if      drop r@ here over c@ 1+ cmove
  112.                         here path1 prepend.apath $hopen
  113.                 then    r>drop ;
  114.  
  115. : $FILE         ( A1 --- F1 )
  116.                 <$FILE>
  117.                 0.0 seqhandle movepointer       \ reset to beginning of file
  118.                 0.0 filepointer 2!
  119.                 loadline off                    \ reset file offset
  120.                 ibreset
  121.                 0 %!> screenchar ;              \ --- f1
  122.  
  123.                 \ Open a specified filename from ANY FPATH directory
  124. : FILE          ( | <filename> --- )
  125.                 gfl bl word $file ?open.error
  126.                 ." of " seqhandle endfile d. ." bytes."
  127.                 0 0 seqhandle movepointer ;     \ reset to biginning of file
  128.  
  129. : $FLOAD        ( a1 --- f1 )
  130.                 sequp
  131.                 <$file> dup>r 0=
  132.                 if      filepointer 2@ outbuf c@ 0 d- 2>r
  133.                         \ knock off length of line just read & save for later
  134.                         %off> outbuf
  135.                         <fload>
  136.                         2r> filepointer 2!      \ next read is here
  137.                 then    r>              ( --- f1 )
  138.                 seqdown ;
  139.  
  140. : FLOAD         ( | <filename> --- )
  141.                 bl word                         \ get filename
  142.                 $fload  ?open.error ;           \ perform the load
  143.  
  144.