version 1.45, 1995/10/29 21:35:13
|
version 1.47, 1995/11/09 18:06:20
|
Line 1
|
Line 1
|
\ KERNAL.FS GForth kernal 17dec92py |
\ KERNAL.FS GForth kernal 17dec92py |
\ $ID: |
|
|
\ Copyright (C) 1995 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 |
|
\ of the License, or (at your option) any later version. |
|
|
|
\ This program is distributed in the hope that it will be useful, |
|
\ but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
\ 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. |
|
|
\ Idea and implementation: Bernd Paysan (py) |
\ Idea and implementation: Bernd Paysan (py) |
\ Copyright 1992 by the ANSI figForth Development Group |
|
|
|
\ Log: ', '- usw. durch [char] ... ersetzt |
\ Log: ', '- usw. durch [char] ... ersetzt |
\ man sollte die unterschiedlichen zahlensysteme |
\ man sollte die unterschiedlichen zahlensysteme |
Line 1363 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1380 create nl$ 1 c, A c, 0 c, \ gnu includes
|
\ include-file 07apr93py |
\ include-file 07apr93py |
|
|
: push-file ( -- ) r> |
: push-file ( -- ) r> |
loadline @ >r loadfile @ >r |
loadline @ >r loadfile @ >r |
blk @ >r >tib @ >r #tib @ dup >r >tib +! >in @ >r >r ; |
blk @ >r tibstack @ >r >tib @ >r #tib @ >r |
|
>tib @ tibstack @ = IF r@ tibstack +! THEN |
|
tibstack @ >tib ! >in @ >r >r ; |
|
|
: pop-file ( throw-code -- throw-code ) |
: pop-file ( throw-code -- throw-code ) |
dup IF |
dup IF |
Line 1377 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1396 create nl$ 1 c, A c, 0 c, \ gnu includes
|
-1 cells +LOOP |
-1 cells +LOOP |
THEN |
THEN |
r> |
r> |
r> >in ! r> #tib ! r> >tib ! r> blk ! |
r> >in ! r> #tib ! r> >tib ! r> tibstack ! r> blk ! |
r> loadfile ! r> loadline ! >r ; |
r> loadfile ! r> loadline ! >r ; |
|
|
: read-loop ( i*x -- j*x ) |
: read-loop ( i*x -- j*x ) |
Line 1440 create image-included-files 0 , 0 , ( po
|
Line 1459 create image-included-files 0 , 0 , ( po
|
\ included-files points to ALLOCATEd space, while image-included-files |
\ included-files points to ALLOCATEd space, while image-included-files |
\ points to ALLOTed objects, so it survives a save-system |
\ points to ALLOTed objects, so it survives a save-system |
|
|
|
: loadfilename ( -- a-addr ) |
|
\ a-addr 2@ produces the current file name ( c-addr u ) |
|
included-files 2@ drop loadfilename# @ 2* cells + ; |
|
|
: init-included-files ( -- ) |
: init-included-files ( -- ) |
image-included-files 2@ 2* cells save-string drop ( addr ) |
image-included-files 2@ 2* cells save-string drop ( addr ) |
image-included-files 2@ nip included-files 2! ; |
image-included-files 2@ nip included-files 2! ; |
Line 1471 create image-included-files 0 , 0 , ( po
|
Line 1494 create image-included-files 0 , 0 , ( po
|
|
|
: included1 ( i*x file-id c-addr u -- j*x ) \ gforth |
: included1 ( i*x file-id c-addr u -- j*x ) \ gforth |
\ include the file file-id with the name given by c-addr u |
\ include the file file-id with the name given by c-addr u |
loadfilename 2@ >r >r |
loadfilename# @ >r |
save-string 2dup loadfilename 2! add-included-file ( file-id ) |
save-string add-included-file ( file-id ) |
|
included-files 2@ nip 1- loadfilename# ! |
['] include-file catch |
['] include-file catch |
r> r> loadfilename 2! throw ; |
r> loadfilename# ! |
|
throw ; |
|
|
: included ( i*x addr u -- j*x ) \ file |
: included ( i*x addr u -- j*x ) \ file |
open-path-file included1 ; |
open-path-file included1 ; |
Line 1536 create image-included-files 0 , 0 , ( po
|
Line 1561 create image-included-files 0 , 0 , ( po
|
\ EVALUATE 17may93jaw |
\ EVALUATE 17may93jaw |
|
|
: evaluate ( c-addr len -- ) \ core,block |
: evaluate ( c-addr len -- ) \ core,block |
push-file dup #tib ! >tib @ swap move |
push-file #tib ! >tib ! |
>in off blk off loadfile off -1 loadline ! |
>in off blk off loadfile off -1 loadline ! |
\ BEGIN interpret >in @ #tib @ u>= UNTIL |
|
['] interpret catch |
['] interpret catch |
pop-file throw ; |
pop-file throw ; |
|
|
Line 1636 DEFER DOERROR
|
Line 1660 DEFER DOERROR
|
postpone [ |
postpone [ |
['] 'quit CATCH dup |
['] 'quit CATCH dup |
WHILE |
WHILE |
DoError r@ >tib ! |
DoError r@ >tib ! r@ tibstack ! |
REPEAT |
REPEAT |
drop r> >tib ! ; |
drop r> >tib ! ; |
|
|
Line 1745 Defer 'cold ' noop IS 'cold
|
Line 1769 Defer 'cold ' noop IS 'cold
|
|
|
: boot ( path **argv argc -- ) |
: boot ( path **argv argc -- ) |
argc ! argv ! cstring>sstring pathstring 2! main-task up! |
argc ! argv ! cstring>sstring pathstring 2! main-task up! |
sp@ dup s0 ! $10 + >tib ! #tib off >in off |
sp@ dup s0 ! $10 + dup >tib ! tibstack ! #tib off >in off |
rp@ r0 ! fp@ f0 ! cold ; |
rp@ r0 ! fp@ f0 ! cold ; |
|
|
: bye ( -- ) \ tools-ext |
: bye ( -- ) \ tools-ext |