1: \ require.fs
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: \ Now: Kernel Module, Reloadable
22:
23: \ $Id: require.fs,v 1.4 1998/06/17 16:55:18 anton Exp $
24:
25: create included-files 0 , 0 , ( pointer to and count of included files )
26: here ," ./the terminal" dup c@ swap 1 + swap , A, here 2 cells -
27: create image-included-files 1 , A, ( pointer to and count of included files )
28: \ included-files points to ALLOCATEd space, while image-included-files
29: \ points to ALLOTed objects, so it survives a save-system
30:
31: : loadfilename ( -- a-addr )
32: \G a-addr 2@ produces the current file name ( c-addr u )
33: included-files 2@ loadfilename# @ min 2* cells + ;
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.
40: loadfilename 2@ ;
41:
42: : sourceline# ( -- u ) \ gforth sourceline-number
43: \G the line number of the line that is currently being interpreted
44: \G from a (stream) file. The first line has the number 1. If the
45: \G current input source is no (stream) file, the result is
46: \G undefined.
47: loadline @ ;
48:
49: : init-included-files ( -- )
50: image-included-files 2@ 2* cells save-mem drop ( addr )
51: image-included-files 2@ nip included-files 2! ;
52:
53: : included? ( c-addr u -- f ) \ gforth
54: \G true, iff filename c-addr u is in included-files
55: included-files 2@ 0
56: ?do ( c-addr u addr )
57: dup >r 2@ 2over compare 0=
58: if
59: 2drop rdrop unloop
60: true EXIT
61: then
62: r> cell+ cell+
63: loop
64: 2drop drop false ;
65:
66: : add-included-file ( c-addr u -- ) \ gforth
67: \G add name c-addr u to included-files
68: included-files 2@ 2* cells 2 cells extend-mem
69: 2/ cell / included-files 2!
70: 2! ;
71:
72: : included1 ( i*x file-id c-addr u -- j*x ) \ gforth
73: \G include the file file-id with the name given by c-addr u
74: loadfilename# @ >r
75: save-mem add-included-file ( file-id )
76: included-files 2@ nip 1- loadfilename# !
77: ['] include-file catch
78: r> loadfilename# !
79: throw ;
80:
81: : included ( i*x addr u -- j*x ) \ file
82: \G @code{include-file} the file whose name is given by the string
83: \G @var{addr u}.
84: open-fpath-file throw included1 ;
85:
86: : required ( i*x addr u -- j*x ) \ gforth
87: \G include the file with the name given by @var{addr u}, if it is not
88: \G @code{included} (or @code{required}) already. Currently this
89: \G works by comparing the name of the file (with path) against the
90: \G names of earlier included files.
91: \ however, it may be better to fstat the file,
92: \ and compare the device and inode. The advantages would be: no
93: \ problems with several paths to the same file (e.g., due to
94: \ links) and we would catch files included with include-file and
95: \ write a require-file.
96: open-fpath-file throw 2dup included?
97: if
98: 2drop close-file throw
99: else
100: included1
101: then ;
102:
103: \ INCLUDE 9may93jaw
104:
105: : include ( ... "file" -- ... ) \ gforth
106: \G includes @var{file}
107: name included ;
108:
109: : require ( ... "file" -- ... ) \ gforth
110: \G includes @var{file} only if it is not included already
111: name required ;
112:
113: 0 [IF]
114: : \I
115: here
116: 0 word count
117: string,
118: needsrcs^ @ ! ;
119:
120: : .modules
121: cr
122: needs^ @
123: BEGIN dup
124: WHILE dup cell+ count type cr
125: 5 spaces
126: dup cell+ count + aligned
127: @ dup IF count type ELSE drop THEN cr
128: @
129: REPEAT
130: drop ;
131:
132: : loadfilename#>str ( n -- adr len )
133: \ this converts the filenumber into the string
134: loadfilenamecount @ swap -
135: needs^ @
136: swap 0 ?DO dup 0= IF LEAVE THEN @ LOOP
137: dup IF cell+ count ELSE drop s" NOT FOUND" THEN ;
138: [THEN]
139:
140: : loadfilename#>str ( n -- adr len )
141: included-files 2@ drop swap 2* cells + 2@ ;
142:
143: : .modules
144: included-files 2@ 2* cells bounds ?DO
145: cr I 2@ type 2 cells +LOOP ;
146:
147: \ contains tools/newrequire.fs
148: \ \I $Id: require.fs,v 1.4 1998/06/17 16:55:18 anton Exp $
149:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>