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>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to files.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth