--- gforth/kernel/files.fs 2000/09/09 20:32:58 1.11 +++ gforth/kernel/files.fs 2007/12/31 19:02:25 1.26 @@ -1,12 +1,12 @@ \ File specifiers 11jun93jaw -\ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,2000,2003,2006,2007 Free Software Foundation, Inc. \ This file is part of Gforth. \ Gforth is free software; you can redistribute it and/or \ modify it under the terms of the GNU General Public License -\ as published by the Free Software Foundation; either version 2 +\ as published by the Free Software Foundation, either version 3 \ of the License, or (at your option) any later version. \ This program is distributed in the hope that it will be useful, @@ -15,8 +15,7 @@ \ GNU General Public License for more details. \ You should have received a copy of the GNU General Public License -\ along with this program; if not, write to the Free Software -\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +\ along with this program. If not, see http://www.gnu.org/licenses/. 4 Constant w/o ( -- fam ) \ file w-o 2 Constant r/w ( -- fam ) \ file r-w @@ -34,40 +33,41 @@ THEN newline r> write-file ; -: read-line ( c_addr u1 wfileid -- u2 flag wior ) - (read-line) drop ; - \ include-file 07apr93py +has? new-input 0= [IF] +: loadfilename>r ( addr1 u1 -- R: addr2 u2 ) + r> loadfilename 2@ 2>r >r + loadfilename 2! ; + +: r>loadfilename ( R: addr u -- ) + r> 2r> loadfilename 2! >r ; + : push-file ( -- ) r> - loadline @ >r - loadfile @ >r - blk @ >r - tibstack @ >r - >tib @ >r - #tib @ >r - >in @ >r >r + #fill-bytes @ >r + loadline @ >r + loadfile @ >r + blk @ >r + tibstack @ >r + >tib @ >r + #tib @ >r + >in @ >r >r >tib @ tibstack @ = IF #tib @ tibstack +! THEN tibstack @ >tib ! ; : pop-file ( throw-code -- throw-code ) dup IF - source >in @ sourceline# sourcefilename - error-stack dup @ dup 1+ - max-errors 1- min error-stack ! - 6 * cells + cell+ - 5 cells bounds swap DO - I ! - -1 cells +LOOP + input-error-data >error THEN r> - r> >in ! - r> #tib ! - r> >tib ! - r> tibstack ! - r> blk ! - r> loadfile ! - r> loadline ! >r ; + r> >in ! + r> #tib ! + r> >tib ! + r> tibstack ! + r> blk ! + r> loadfile ! + r> loadline ! + r> #fill-bytes ! >r ; : read-loop ( i*x -- j*x ) BEGIN refill WHILE interpret REPEAT ; @@ -85,15 +85,15 @@ include-file1 throw throw ; : include-file ( i*x wfileid -- j*x ) \ file - loadfilename# @ >r - 3 loadfilename# ! \ "\a file/" + s" *a file*" loadfilename>r include-file1 - r> loadfilename# ! + r>loadfilename throw throw ; +[THEN] \ additional words only needed if there is file support -Warnings off +Redefinitions-start : ( ( compilation 'ccc' -- ; run-time -- ) \ core,file paren loadfile @ 0= IF postpone ( EXIT THEN @@ -112,4 +112,4 @@ Warnings off THEN REPEAT ; immediate -Warnings on +Redefinitions-end