version 1.53, 2006/12/31 13:39:14
|
version 1.60, 2009/09/05 17:38:37
|
Line 1
|
Line 1
|
\ miscelleneous words |
\ miscelleneous words |
|
|
\ Copyright (C) 1996,1997,1998,2000,2003,2004,2005,2006 Free Software Foundation, Inc. |
\ Copyright (C) 1996,1997,1998,2000,2003,2004,2005,2006,2007,2008 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
\ Gforth is free software; you can redistribute it and/or |
\ Gforth is free software; you can redistribute it and/or |
\ modify it under the terms of the GNU General Public License |
\ 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. |
\ of the License, or (at your option) any later version. |
|
|
\ This program is distributed in the hope that it will be useful, |
\ This program is distributed in the hope that it will be useful, |
Line 15
|
Line 15
|
\ GNU General Public License for more details. |
\ GNU General Public License for more details. |
|
|
\ You should have received a copy of the GNU General Public License |
\ You should have received a copy of the GNU General Public License |
\ along with this program; if not, write to the Free Software |
\ along with this program. If not, see http://www.gnu.org/licenses/. |
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
|
|
|
require glocals.fs |
require glocals.fs |
|
|
Line 156 AUser CSP
|
Line 155 AUser CSP
|
|
|
[ifdef] compiler1 |
[ifdef] compiler1 |
: postponer1 ( c-addr u -- ... xt ) |
: postponer1 ( c-addr u -- ... xt ) |
2dup find-name dup if ( c-addr u nt ) |
2dup |
|
[ifdef] find-name-run-prelude find-name-run-prelude [else] find-name [then] |
|
dup if ( c-addr u nt ) |
nip nip name>comp |
nip nip name>comp |
2dup [comp'] [[ d= if |
2dup [comp'] [[ d= if |
2drop ['] compiler1 is parser1 ['] noop |
2drop ['] compiler1 is parser1 ['] noop |
Line 355 previous
|
Line 356 previous
|
|
|
\ safe output redirection |
\ safe output redirection |
|
|
: to-outfile-id ( file-id -- ) |
: outfile-execute ( ... xt file-id -- ... ) \ gforth |
to outfile-id ; |
\G execute @i{xt} with the output of @code{type} etc. redirected to |
|
\G @i{file-id}. |
|
outfile-id { oldfid } try |
|
to outfile-id execute 0 |
|
restore |
|
oldfid to outfile-id |
|
endtry |
|
throw ; |
|
|
|
: infile-execute ( ... xt file-id -- ... ) \ gforth |
|
\G execute @i{xt} with the input of @code{key} etc. redirected to |
|
\G @i{file-id}. |
|
infile-id { oldfid } try |
|
to infile-id execute 0 |
|
restore |
|
oldfid to infile-id |
|
endtry |
|
throw ; |
|
|
|
\ safe BASE wrapper |
|
|
|
: base-execute ( i*x xt u -- j*x ) \ gforth |
|
\G execute @i{xt} with the content of @code{BASE} being @i{u}, and |
|
\G restoring the original @code{BASE} afterwards. |
|
base @ { oldbase } \ use local, because TRY blocks the return stack |
|
try |
|
base ! execute 0 |
|
restore |
|
oldbase base ! |
|
endtry |
|
throw ; |
|
|
: >outfile ( file-id -- r:old-file-id ) |
\ th |
]] outfile-id >r try to-outfile-id [[ ; immediate compile-only |
|
|
|
: outfile< ( r:old-file-id -- ) |
: th ( addr1 u -- addr2 ) |
0 ]] literal recover endtry r> to-outfile-id throw [[ |
cells + ; |
; immediate compile-only |
|
|
|
: to-infile-id ( file-id -- ) |
|
to infile-id ; |
|
|
|
: >infile ( file-id -- r:old-file-id ) |
|
]] infile-id >r try to-infile-id [[ ; immediate compile-only |
|
|
|
: infile< ( r:old-file-id -- ) |
|
0 ]] literal recover endtry r> to-infile-id throw [[ |
|
; immediate compile-only |
|