Powered by ViewCVS 1.0-dev
| 1 : | pazsan | 1.1 | \ File specifiers 11jun93jaw |
| 2 : | |||
| 3 : | anton | 1.3 | \ Copyright (C) 1995-1997 Free Software Foundation, Inc. |
| 4 : | pazsan | 1.2 | |
| 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 : | pazsan | 1.1 | 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 : |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |