--- gforth/kernel/files.fs 2000/09/09 20:32:58 1.11 +++ gforth/kernel/files.fs 2006/12/31 13:39:18 1.24 @@ -1,6 +1,6 @@ \ File specifiers 11jun93jaw -\ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,2000,2003,2006 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -16,7 +16,7 @@ \ 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. +\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. 4 Constant w/o ( -- fam ) \ file w-o 2 Constant r/w ( -- fam ) \ file r-w @@ -34,40 +34,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 +86,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 +113,4 @@ Warnings off THEN REPEAT ; immediate -Warnings on +Redefinitions-end