[gforth] / gforth / kernel / require.fs  

gforth: gforth/kernel/require.fs

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help