File:  [gforth] / gforth / Attic / files.fs
Revision 1.3: download - view: text, annotated - select for diffs
Wed Mar 19 18:27:13 1997 UTC (25 years, 3 months ago) by anton
Branches: MAIN
CVS tags: v0-3-0, HEAD
fixed some documentation bugs
updated dates on copyright messages
updated NEWS
some fixes in Makefile.in

    1: \ File specifiers                                       11jun93jaw
    2: 
    3: \ Copyright (C) 1995-1997 Free Software Foundation, Inc.
    4: 
    5: \ This file is part of Gforth.
    6: 
    7: \ Gforth is free software; you can redistribute it and/or
    8: \ modify it under the terms of the GNU General Public License
    9: \ as published by the Free Software Foundation; either version 2
   10: \ of the License, or (at your option) any later version.
   11: 
   12: \ This program is distributed in the hope that it will be useful,
   13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: \ GNU General Public License for more details.
   16: 
   17: \ You should have received a copy of the GNU General Public License
   18: \ along with this program; if not, write to the Free Software
   19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   20: 
   21: 4 Constant w/o ( -- fam ) \ file	w-o
   22: 2 Constant r/w ( -- fam ) \ file	r-w
   23: 0 Constant r/o ( -- fam ) \ file	r-o
   24: 
   25: : bin ( fam1 -- fam2 ) \ file
   26:     1 or ;
   27: 
   28: \ BIN WRITE-LINE                                        11jun93jaw
   29: 
   30: : write-line ( c-addr u fileid -- ior ) \ file
   31:     dup >r write-file
   32:     ?dup IF
   33: 	r> drop EXIT
   34:     THEN
   35:     #lf r> emit-file ;
   36: 
   37: \ include-file                                         07apr93py
   38: 
   39: : push-file  ( -- )  r>
   40:   sourceline# >r  loadfile @ >r
   41:   blk @ >r  tibstack @ >r  >tib @ >r  #tib @ >r
   42:   >tib @ tibstack @ = IF  r@ tibstack +!  THEN
   43:   tibstack @ >tib ! >in @ >r  >r ;
   44: 
   45: : pop-file   ( throw-code -- throw-code )
   46:   dup IF
   47:          source >in @ sourceline# sourcefilename
   48: 	 error-stack dup @ dup 1+
   49: 	 max-errors 1- min error-stack !
   50: 	 6 * cells + cell+
   51: 	 5 cells bounds swap DO
   52: 	                    I !
   53: 	 -1 cells +LOOP
   54:   THEN
   55:   r>
   56:   r> >in !  r> #tib !  r> >tib !  r> tibstack !  r> blk !
   57:   r> loadfile ! r> loadline !  >r ;
   58: 
   59: : read-loop ( i*x -- j*x )
   60:   BEGIN  refill  WHILE  interpret  REPEAT ;
   61: 
   62: : include-file ( i*x fid -- j*x ) \ file
   63:   push-file  loadfile !
   64:   0 loadline ! blk off  ['] read-loop catch
   65:   loadfile @ close-file swap 2dup or
   66:   pop-file  drop throw throw ;
   67: 
   68: create pathfilenamebuf 256 chars allot \ !! make this grow on demand
   69: 
   70: : absolut-path? ( addr u -- flag ) \ gforth
   71:     \G a path is absolute, if it starts with a / or a ~ (~ expansion),
   72:     \G or if it is in the form ./* or ../*, extended regexp: ^[/~]|./|../
   73:     \G Pathes simply containing a / are not absolute!
   74:     over c@ '/ = >r
   75:     over c@ '~ = >r
   76:     2dup 2 min S" ./" compare 0= >r
   77:          3 min S" ../" compare 0=
   78:     r> r> r> or or or ;
   79: 
   80: : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) \ gforth
   81:     \G opens a file for reading, searching in the path for it (unless
   82:     \G the filename contains a slash); c-addr2 u2 is the full filename
   83:     \G (valid until the next call); if the file is not found (or in
   84:     \G case of other errors for each try), -38 (non-existant file) is
   85:     \G thrown. Opening for other access modes makes little sense, as
   86:     \G the path will usually contain dirs that are only readable for
   87:     \G the user
   88:     \ !! use file-status to determine access mode?
   89:     2dup absolut-path?
   90:     IF \ the filename contains a slash
   91: 	2dup r/o open-file throw ( c-addr1 u1 file-id )
   92: 	-rot >r pathfilenamebuf r@ cmove ( file-id R: u1 )
   93: 	pathfilenamebuf r> EXIT
   94:     THEN
   95:     pathdirs 2@ 0
   96:     ?DO ( c-addr1 u1 dirnamep )
   97: 	dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u )
   98: 	2dup pathfilenamebuf r@ chars + swap cmove ( addr u )
   99: 	pathfilenamebuf over r> + dup >r r/o open-file 0=
  100: 	IF ( addr u file-id )
  101: 	    nip nip r> rdrop 0 LEAVE
  102: 	THEN
  103: 	rdrop drop r> cell+ cell+
  104:     LOOP
  105:     0<> -&38 and throw ( file-id u2 )
  106:     pathfilenamebuf swap ;
  107: 
  108: create included-files 0 , 0 , ( pointer to and count of included files )
  109: here ," the terminal" dup c@ swap 1 + swap , A, here 2 cells -
  110: create image-included-files  1 , A, ( pointer to and count of included files )
  111: \ included-files points to ALLOCATEd space, while image-included-files
  112: \ points to ALLOTed objects, so it survives a save-system
  113: 
  114: : loadfilename ( -- a-addr )
  115:     \G a-addr 2@ produces the current file name ( c-addr u )
  116:     included-files 2@ drop loadfilename# @ 2* cells + ;
  117: 
  118: : sourcefilename ( -- c-addr u ) \ gforth
  119:     \G the name of the source file which is currently the input
  120:     \G source.  The result is valid only while the file is being
  121:     \G loaded.  If the current input source is no (stream) file, the
  122:     \G result is undefined.
  123:     loadfilename 2@ ;
  124: 
  125: : sourceline# ( -- u ) \ gforth		sourceline-number
  126:     \G the line number of the line that is currently being interpreted
  127:     \G from a (stream) file. The first line has the number 1. If the
  128:     \G current input source is no (stream) file, the result is
  129:     \G undefined.
  130:     loadline @ ;
  131: 
  132: : init-included-files ( -- )
  133:     image-included-files 2@ 2* cells save-mem drop ( addr )
  134:     image-included-files 2@ nip included-files 2! ;
  135: 
  136: : included? ( c-addr u -- f ) \ gforth
  137:     \G true, iff filename c-addr u is in included-files
  138:     included-files 2@ 0
  139:     ?do ( c-addr u addr )
  140: 	dup >r 2@ 2over compare 0=
  141: 	if
  142: 	    2drop rdrop unloop
  143: 	    true EXIT
  144: 	then
  145: 	r> cell+ cell+
  146:     loop
  147:     2drop drop false ;
  148: 
  149: : add-included-file ( c-addr u -- ) \ gforth
  150:     \G add name c-addr u to included-files
  151:     included-files 2@ 2* cells 2 cells extend-mem
  152:     2/ cell / included-files 2!
  153:     2! ;
  154: 
  155: : included1 ( i*x file-id c-addr u -- j*x ) \ gforth
  156:     \G include the file file-id with the name given by c-addr u
  157:     loadfilename# @ >r
  158:     save-mem add-included-file ( file-id )
  159:     included-files 2@ nip 1- loadfilename# !
  160:     ['] include-file catch
  161:     r> loadfilename# !
  162:     throw ;
  163:     
  164: : included ( i*x addr u -- j*x ) \ file
  165:     open-path-file included1 ;
  166: 
  167: : required ( i*x addr u -- j*x ) \ gforth
  168:     \G include the file with the name given by addr u, if it is not
  169:     \G included already. Currently this works by comparing the name of
  170:     \G the file (with path) against the names of earlier included
  171:     \G files; however, it would probably be better to fstat the file,
  172:     \G and compare the device and inode. The advantages would be: no
  173:     \G problems with several paths to the same file (e.g., due to
  174:     \G links) and we would catch files included with include-file and
  175:     \G write a require-file.
  176:     open-path-file 2dup included?
  177:     if
  178: 	2drop close-file throw
  179:     else
  180: 	included1
  181:     then ;
  182: 
  183: \ INCLUDE                                               9may93jaw
  184: 
  185: : include  ( "file" -- ) \ gforth
  186:   name included ;
  187: 
  188: : require  ( "file" -- ) \ gforth
  189:   name required ;
  190: 
  191: \ additional words only needed if there is file support
  192: 
  193: : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file	paren
  194:     loadfile @ 0= IF  postpone (  EXIT  THEN
  195:     BEGIN
  196: 	>in @
  197: 	[char] ) parse nip
  198: 	>in @ rot - = \ is there no delimter?
  199:     WHILE
  200: 	refill 0=
  201: 	IF
  202: 	    warnings @
  203: 	    IF
  204: 		." warning: ')' missing" cr
  205: 	    THEN
  206: 	    EXIT
  207: 	THEN
  208:     REPEAT ; immediate
  209: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>