1: \ require.fs
2:
3: \ Copyright (C) 1995,1996,1997,1998,2000 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., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
20:
21: \ Now: Kernel Module, Reloadable
22:
23: create included-files 0 , 0 , ( pointer to and count of included files )
24: \ note: these names must not contain a "/" or "\"; otherwise a part of
25: \ that name might be used when expanding "./" (see expandtopic).
26: here ," *a file*" dup c@ swap 1 + swap
27: here ," *a block*" dup c@ swap 1 + swap
28: here ," *evaluated string*" dup c@ swap 1 + swap
29: here ," *the terminal*" dup c@ swap 1 + swap
30: , A, , A, , A, , A, here 8 cells -
31: create image-included-files 4 , A, ( pointer to and count of included files )
32: \ included-files points to ALLOCATEd space, while image-included-files
33: \ points to ALLOTed objects, so it survives a save-system
34:
35: : sourcefilename ( -- c-addr u ) \ gforth
36: \G The name of the source file which is currently the input
37: \G source. The result is valid only while the file is being
38: \G loaded. If the current input source is no (stream) file, the
39: \G result is undefined. In Gforth, the result is valid during the
40: \G whole seesion (but not across @code{savesystem} etc.).
41: loadfilename 2@ ;
42:
43: : sourceline# ( -- u ) \ gforth sourceline-number
44: \G The line number of the line that is currently being interpreted
45: \G from a (stream) file. The first line has the number 1. If the
46: \G current input source is not a (stream) file, the result is
47: \G undefined.
48: loadline @ ;
49:
50: : init-included-files ( -- ) \ gforth-internal
51: image-included-files 2@ 2* cells save-mem drop ( addr )
52: image-included-files 2@ nip included-files 2! ;
53:
54: : included? ( c-addr u -- f ) \ gforth
55: \G True only if the file @var{c-addr u} is in the list of earlier
56: \G included files. If the file has been loaded, it may have been
57: \G specified as, say, @file{foo.fs} and found somewhere on the
58: \G Forth search path. To return @code{true} from @code{included?},
59: \G you must specify the exact path to the file, even if that is
60: \G @file{./foo.fs}
61: included-files 2@ 0
62: ?do ( c-addr u addr )
63: dup >r 2@ 2over str=
64: if
65: 2drop rdrop unloop
66: true EXIT
67: then
68: r> cell+ cell+
69: loop
70: 2drop drop false ;
71:
72: : add-included-file ( c-addr u -- ) \ gforth
73: \G add name c-addr u to included-files
74: included-files 2@ 2* cells 2 cells extend-mem
75: 2/ cell / included-files 2!
76: 2! ;
77:
78: has? new-input [IF]
79: : included1 ( i*x file-id c-addr u -- j*x ) \ gforth
80: \G Include the file file-id with the name given by @var{c-addr u}.
81: save-mem 2dup add-included-file ( file-id )
82: ['] include-file2 catch
83: throw ;
84: [ELSE]
85: : included1 ( i*x file-id c-addr u -- j*x ) \ gforth
86: \G Include the file file-id with the name given by @var{c-addr u}.
87: loadfilename 2@ 2>r
88: save-mem 2dup loadfilename 2!
89: add-included-file ( file-id )
90: ['] include-file2 catch
91: 2r> loadfilename 2!
92: throw ;
93: [THEN]
94:
95: : included ( i*x c-addr u -- j*x ) \ file
96: \G @code{include-file} the file whose name is given by the string
97: \G @var{c-addr u}.
98: open-fpath-file throw included1 ;
99:
100: : required ( i*x addr u -- j*x ) \ gforth
101: \G @code{include-file} the file with the name given by @var{addr
102: \G u}, if it is not @code{included} (or @code{required})
103: \G already. Currently this works by comparing the name of the file
104: \G (with path) against the names of earlier included files.
105: \ however, it may be better to fstat the file,
106: \ and compare the device and inode. The advantages would be: no
107: \ problems with several paths to the same file (e.g., due to
108: \ links) and we would catch files included with include-file and
109: \ write a require-file.
110: open-fpath-file throw 2dup included?
111: if
112: 2drop close-file throw
113: else
114: included1
115: then ;
116:
117: \ INCLUDE 9may93jaw
118:
119: : include ( ... "file" -- ... ) \ gforth
120: \G @code{include-file} the file @var{file}.
121: name included ;
122:
123: : require ( ... "file" -- ... ) \ gforth
124: \G @code{include-file} @var{file} only if it is not included already.
125: name required ;
126:
127: \ : \I
128: \ here
129: \ 0 word count
130: \ string,
131: \ needsrcs^ @ ! ;
132:
133: \ : .included ( -- ) \ gforth
134: \ \G list the names of the files that have been @code{included}
135: \ cr
136: \ needs^ @
137: \ BEGIN dup
138: \ WHILE dup cell+ count type cr
139: \ 5 spaces
140: \ dup cell+ count + aligned
141: \ @ dup IF count type ELSE drop THEN cr
142: \ @
143: \ REPEAT
144: \ drop ;
145:
146: : .strings ( addr u -- ) \ gforth
147: \G list the strings from an array of string descriptors at addr
148: \G with u entries, one per line.
149: 2* cells bounds ?DO
150: cr I 2@ type 2 cells +LOOP ;
151:
152: : .included ( -- ) \ gforth
153: \G list the names of the files that have been @code{included}
154: included-files 2@ .strings ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>