version 1.42, 1995/10/11 19:39:34
|
version 1.49, 1995/11/30 18:01:48
|
Line 1
|
Line 1
|
\ KERNAL.FS GNU FORTH 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 84 DOES> ( n -- ) + c@ ;
|
Line 101 DOES> ( n -- ) + c@ ;
|
: 2, ( w1 w2 -- ) \ gforth |
: 2, ( w1 w2 -- ) \ gforth |
here 2 cells allot 2! ; |
here 2 cells allot 2! ; |
|
|
: aligned ( addr -- addr' ) \ core |
\ : aligned ( addr -- addr' ) \ core |
[ cell 1- ] Literal + [ -1 cells ] Literal and ; |
\ [ cell 1- ] Literal + [ -1 cells ] Literal and ; |
: align ( -- ) \ core |
: align ( -- ) \ core |
here dup aligned swap ?DO bl c, LOOP ; |
here dup aligned swap ?DO bl c, LOOP ; |
|
|
: faligned ( addr -- f-addr ) \ float |
\ : faligned ( addr -- f-addr ) \ float |
[ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; |
\ [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; |
|
|
: falign ( -- ) \ float |
: falign ( -- ) \ float |
here dup faligned swap |
here dup faligned swap |
Line 226 Defer source ( -- addr count ) \ core
|
Line 243 Defer source ( -- addr count ) \ core
|
|
|
\ Literal 17dec92py |
\ Literal 17dec92py |
|
|
: Literal ( compilation: n -- ; run-time: -- n ) \ core |
: Literal ( compilation n -- ; run-time -- n ) \ core |
state @ IF postpone lit , THEN ; immediate |
state @ IF postpone lit , THEN ; immediate |
: ALiteral ( compilation: addr -- ; run-time: -- addr ) \ gforth |
: ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth |
state @ IF postpone lit A, THEN ; |
state @ IF postpone lit A, THEN ; |
immediate |
immediate |
|
|
: char ( 'char' -- n ) \ core |
: char ( 'char' -- n ) \ core |
bl word char+ c@ ; |
bl word char+ c@ ; |
: [char] ( compilation: 'char' -- ; run-time: -- n ) |
: [char] ( compilation 'char' -- ; run-time -- n ) |
char postpone Literal ; immediate |
char postpone Literal ; immediate |
' [char] Alias Ascii immediate |
' [char] Alias Ascii immediate |
|
|
Line 360 hex
|
Line 377 hex
|
>r 0 r@ um/mod r> swap >r |
>r 0 r@ um/mod r> swap >r |
um/mod r> ; |
um/mod r> ; |
|
|
: pad ( -- addr ) \ core |
: pad ( -- addr ) \ core-ext |
here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ; |
here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ; |
|
|
\ hold <# #> sign # #s 25jan92py |
\ hold <# #> sign # #s 25jan92py |
Line 572 variable backedge-locals
|
Line 589 variable backedge-locals
|
|
|
\ locals list operations |
\ locals list operations |
|
|
: common-list ( list1 list2 -- list3 ) |
: common-list ( list1 list2 -- list3 ) \ gforth-internal |
\ list1 and list2 are lists, where the heads are at higher addresses than |
\ list1 and list2 are lists, where the heads are at higher addresses than |
\ the tail. list3 is the largest sublist of both lists. |
\ the tail. list3 is the largest sublist of both lists. |
begin |
begin |
Line 586 variable backedge-locals
|
Line 603 variable backedge-locals
|
repeat |
repeat |
drop ; |
drop ; |
|
|
: sub-list? ( list1 list2 -- f ) |
: sub-list? ( list1 list2 -- f ) \ gforth-internal |
\ true iff list1 is a sublist of list2 |
\ true iff list1 is a sublist of list2 |
begin |
begin |
2dup u< |
2dup u< |
Line 595 variable backedge-locals
|
Line 612 variable backedge-locals
|
repeat |
repeat |
= ; |
= ; |
|
|
: list-size ( list -- u ) |
: list-size ( list -- u ) \ gforth-internal |
\ size of the locals frame represented by list |
\ size of the locals frame represented by list |
0 ( list n ) |
0 ( list n ) |
begin |
begin |
Line 695 variable backedge-locals
|
Line 712 variable backedge-locals
|
|
|
\ Structural Conditionals 12dec92py |
\ Structural Conditionals 12dec92py |
|
|
: AHEAD ( compilation: -- orig ; run-time: -- ) \ tools-ext |
: AHEAD ( compilation -- orig ; run-time -- ) \ tools-ext |
POSTPONE branch >mark POSTPONE unreachable ; immediate restrict |
POSTPONE branch >mark POSTPONE unreachable ; immediate restrict |
|
|
: IF ( compilation: -- orig ; run-time: f -- ) \ core |
: IF ( compilation -- orig ; run-time f -- ) \ core |
POSTPONE ?branch >mark ; immediate restrict |
POSTPONE ?branch >mark ; immediate restrict |
|
|
: ?DUP-IF ( compilation: -- orig ; run-time: n -- n| ) \ gforth question-dupe-if |
: ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-if |
\ This is the preferred alternative to the idiom "?DUP IF", since it can be |
\ This is the preferred alternative to the idiom "?DUP IF", since it can be |
\ better handled by tools like stack checkers |
\ better handled by tools like stack checkers |
POSTPONE ?dup POSTPONE if ; immediate restrict |
POSTPONE ?dup POSTPONE if ; immediate restrict |
: ?DUP-0=-IF ( compilation: -- orig ; run-time: n -- n| ) \ gforth question-dupe-zero-equals-if |
: ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-zero-equals-if |
POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict |
POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict |
|
|
: THEN ( compilation: orig -- ; run-time: -- ) \ core |
: THEN ( compilation orig -- ; run-time -- ) \ core |
dup orig? |
dup orig? |
dead-orig = |
dead-orig = |
if |
if |
Line 725 variable backedge-locals
|
Line 742 variable backedge-locals
|
then |
then |
then ; immediate restrict |
then ; immediate restrict |
|
|
' THEN alias ENDIF ( compilation: orig -- ; run-time: -- ) \ gforth |
' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth |
immediate restrict |
immediate restrict |
\ Same as "THEN". This is what you use if your program will be seen by |
\ Same as "THEN". This is what you use if your program will be seen by |
\ people who have not been brought up with Forth (or who have been |
\ people who have not been brought up with Forth (or who have been |
\ brought up with fig-Forth). |
\ brought up with fig-Forth). |
|
|
: ELSE ( compilation: orig1 -- orig2 ; run-time: f -- ) \ core |
: ELSE ( compilation orig1 -- orig2 ; run-time f -- ) \ core |
POSTPONE ahead |
POSTPONE ahead |
1 cs-roll |
1 cs-roll |
POSTPONE then ; immediate restrict |
POSTPONE then ; immediate restrict |
|
|
|
|
: BEGIN ( compilation: -- dest ; run-time: -- ) \ core |
: BEGIN ( compilation -- dest ; run-time -- ) \ core |
dead-code @ if |
dead-code @ if |
\ set up an assumption of the locals visible here. if the |
\ set up an assumption of the locals visible here. if the |
\ users want something to be visible, they have to declare |
\ users want something to be visible, they have to declare |
Line 752 immediate restrict
|
Line 769 immediate restrict
|
\ issue a warning (see below). The following code is generated: |
\ issue a warning (see below). The following code is generated: |
\ lp+!# (current-local-size - dest-locals-size) |
\ lp+!# (current-local-size - dest-locals-size) |
\ branch <begin> |
\ branch <begin> |
: AGAIN ( compilation: dest -- ; run-time: -- ) \ core-ext |
: AGAIN ( compilation dest -- ; run-time -- ) \ core-ext |
dest? |
dest? |
over list-size adjust-locals-size |
over list-size adjust-locals-size |
POSTPONE branch |
POSTPONE branch |
Line 778 immediate restrict
|
Line 795 immediate restrict
|
then ( list ) |
then ( list ) |
check-begin ; |
check-begin ; |
|
|
: UNTIL ( compilation: dest -- ; run-time: f -- ) \ core |
: UNTIL ( compilation dest -- ; run-time f -- ) \ core |
dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict |
dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict |
|
|
: WHILE ( compilation: dest -- orig dest ; run-time: f -- ) \ core |
: WHILE ( compilation dest -- orig dest ; run-time f -- ) \ core |
POSTPONE if |
POSTPONE if |
1 cs-roll ; immediate restrict |
1 cs-roll ; immediate restrict |
|
|
: REPEAT ( compilation: orig dest -- ; run-time: -- ) \ core |
: REPEAT ( compilation orig dest -- ; run-time -- ) \ core |
POSTPONE again |
POSTPONE again |
POSTPONE then ; immediate restrict |
POSTPONE then ; immediate restrict |
|
|
Line 829 Avariable leave-sp leave-stack 3 cells
|
Line 846 Avariable leave-sp leave-stack 3 cells
|
cell - dup @ swap |
cell - dup @ swap |
leave-sp ! ; |
leave-sp ! ; |
|
|
: DONE ( compilation: orig -- ; run-time: -- ) \ gforth |
: DONE ( compilation orig -- ; run-time -- ) \ gforth |
\ !! the original done had ( addr -- ) |
\ !! the original done had ( addr -- ) |
drop >r drop |
drop >r drop |
begin |
begin |
Line 840 Avariable leave-sp leave-stack 3 cells
|
Line 857 Avariable leave-sp leave-stack 3 cells
|
repeat |
repeat |
>leave rdrop ; immediate restrict |
>leave rdrop ; immediate restrict |
|
|
: LEAVE ( compilation: -- ; run-time: loop-sys -- ) \ core |
: LEAVE ( compilation -- ; run-time loop-sys -- ) \ core |
POSTPONE ahead |
POSTPONE ahead |
>leave ; immediate restrict |
>leave ; immediate restrict |
|
|
: ?LEAVE ( compilation: -- ; run-time: f | f loop-sys -- ) \ gforth question-leave |
: ?LEAVE ( compilation -- ; run-time f | f loop-sys -- ) \ gforth question-leave |
POSTPONE 0= POSTPONE if |
POSTPONE 0= POSTPONE if |
>leave ; immediate restrict |
>leave ; immediate restrict |
|
|
: DO ( compilation: -- do-sys ; run-time: w1 w2 -- loop-sys ) |
: DO ( compilation -- do-sys ; run-time w1 w2 -- loop-sys ) \ core |
POSTPONE (do) |
POSTPONE (do) |
POSTPONE begin drop do-dest |
POSTPONE begin drop do-dest |
( 0 0 0 >leave ) ; immediate restrict |
( 0 0 0 >leave ) ; immediate restrict |
Line 858 Avariable leave-sp leave-stack 3 cells
|
Line 875 Avariable leave-sp leave-stack 3 cells
|
>mark >leave |
>mark >leave |
POSTPONE begin drop do-dest ; |
POSTPONE begin drop do-dest ; |
|
|
: ?DO ( compilation: -- do-sys ; run-time: w1 w2 -- | loop-sys ) \ core-ext question-do |
: ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ core-ext question-do |
POSTPONE (?do) ?do-like ; immediate restrict |
POSTPONE (?do) ?do-like ; immediate restrict |
|
|
: +DO ( compilation: -- do-sys ; run-time: w1 w2 -- | loop-sys ) \ gforth plus-do |
: +DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth plus-do |
POSTPONE (+do) ?do-like ; immediate restrict |
POSTPONE (+do) ?do-like ; immediate restrict |
|
|
: U+DO ( compilation: -- do-sys ; run-time: w1 w2 -- | loop-sys ) \ gforth u-plus-do |
: U+DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth u-plus-do |
POSTPONE (u+do) ?do-like ; immediate restrict |
POSTPONE (u+do) ?do-like ; immediate restrict |
|
|
: -DO ( compilation: -- do-sys ; run-time: w1 w2 -- | loop-sys ) \ gforth minus-do |
: -DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth minus-do |
POSTPONE (-do) ?do-like ; immediate restrict |
POSTPONE (-do) ?do-like ; immediate restrict |
|
|
: U-DO ( compilation: -- do-sys ; run-time: w1 w2 -- | loop-sys ) \ gforth u-minus-do |
: U-DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth u-minus-do |
POSTPONE (u-do) ?do-like ; immediate restrict |
POSTPONE (u-do) ?do-like ; immediate restrict |
|
|
: FOR ( compilation: -- do-sys ; run-time: w -- loop-sys ) \ gforth |
: FOR ( compilation -- do-sys ; run-time w -- loop-sys ) \ gforth |
POSTPONE (for) |
POSTPONE (for) |
POSTPONE begin drop do-dest |
POSTPONE begin drop do-dest |
( 0 0 0 >leave ) ; immediate restrict |
( 0 0 0 >leave ) ; immediate restrict |
Line 884 Avariable leave-sp leave-stack 3 cells
|
Line 901 Avariable leave-sp leave-stack 3 cells
|
>r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest? |
>r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest? |
until-like POSTPONE done POSTPONE unloop ; |
until-like POSTPONE done POSTPONE unloop ; |
|
|
: LOOP ( compilation: do-sys -- ; run-time: loop-sys1 -- | loop-sys2 ) \ core |
: LOOP ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ core |
['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict |
['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict |
|
|
: +LOOP ( compilation: do-sys -- ; run-time: loop-sys1 n -- | loop-sys2 ) \ core plus-loop |
: +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ core plus-loop |
['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict |
['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict |
|
|
\ !! should the compiler warn about +DO..-LOOP? |
\ !! should the compiler warn about +DO..-LOOP? |
: -LOOP ( compilation: do-sys -- ; run-time: loop-sys1 u -- | loop-sys2 ) \ gforth minus-loop |
: -LOOP ( compilation do-sys -- ; run-time loop-sys1 u -- | loop-sys2 ) \ gforth minus-loop |
['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict |
['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict |
|
|
\ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" |
\ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" |
\ will iterate as often as "high low ?DO inc S+LOOP". For positive |
\ will iterate as often as "high low ?DO inc S+LOOP". For positive |
\ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for |
\ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for |
\ negative increments. |
\ negative increments. |
: S+LOOP ( compilation: do-sys -- ; run-time: loop-sys1 n -- | loop-sys2 ) \ gforth s-plus-loop |
: S+LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ gforth s-plus-loop |
['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict |
['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict |
|
|
: NEXT ( compilation: do-sys -- ; run-time: loop-sys1 -- | loop-sys2 ) \ gforth |
: NEXT ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ gforth |
['] (next) ['] (next)-lp+!# loop-like ; immediate restrict |
['] (next) ['] (next)-lp+!# loop-like ; immediate restrict |
|
|
\ Structural Conditionals 12dec92py |
\ Structural Conditionals 12dec92py |
|
|
: EXIT ( compilation: -- ; run-time: nest-sys -- ) \ core |
: EXIT ( compilation -- ; run-time nest-sys -- ) \ core |
0 adjust-locals-size |
0 adjust-locals-size |
POSTPONE ;s |
POSTPONE ;s |
POSTPONE unreachable ; immediate restrict |
POSTPONE unreachable ; immediate restrict |
|
|
: ?EXIT ( -- ) ( compilation: -- ; run-time: nest-sys f -- | nest-sys ) \ gforth |
: ?EXIT ( -- ) ( compilation -- ; run-time nest-sys f -- | nest-sys ) \ gforth |
POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict |
POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict |
|
|
\ Strings 22feb93py |
\ Strings 22feb93py |
Line 922 Avariable leave-sp leave-stack 3 cells
|
Line 939 Avariable leave-sp leave-stack 3 cells
|
r> r> dup count + aligned >r swap >r ; restrict |
r> r> dup count + aligned >r swap >r ; restrict |
: (.") "lit count type ; restrict |
: (.") "lit count type ; restrict |
: (S") "lit count ; restrict |
: (S") "lit count ; restrict |
: SLiteral ( Compilation: c-addr1 u ; run-time: -- c-addr2 u ) \ string |
: SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string |
postpone (S") here over char+ allot place align ; |
postpone (S") here over char+ allot place align ; |
immediate restrict |
immediate restrict |
create s"-buffer /line chars allot |
create s"-buffer /line chars allot |
: S" ( compilation: 'ccc"' -- ; run-time: -- c-addr u ) \ core,file s-quote |
: S" ( compilation 'ccc"' -- ; run-time -- c-addr u ) \ core,file s-quote |
[char] " parse |
[char] " parse |
state @ |
state @ |
IF |
IF |
Line 936 create s"-buffer /line chars allot
|
Line 953 create s"-buffer /line chars allot
|
s"-buffer r> |
s"-buffer r> |
THEN ; immediate |
THEN ; immediate |
|
|
: ." ( compilation: 'ccc"' -- ; run-time: -- ) \ core dot-quote |
: ." ( compilation 'ccc"' -- ; run-time -- ) \ core dot-quote |
state @ IF postpone (.") ," align |
state @ IF postpone (.") ," align |
ELSE [char] " parse type THEN ; immediate |
ELSE [char] " parse type THEN ; immediate |
: ( ( compilation: 'ccc<close-paren>' -- ; run-time: -- ) \ core,file paren |
: ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren |
[char] ) parse 2drop ; immediate |
[char] ) parse 2drop ; immediate |
: \ ( -- ) \ core-ext backslash |
: \ ( -- ) \ core-ext backslash |
blk @ |
blk @ |
Line 961 create s"-buffer /line chars allot
|
Line 978 create s"-buffer /line chars allot
|
r> "error ! -2 throw |
r> "error ! -2 throw |
THEN |
THEN |
rdrop ; |
rdrop ; |
: abort" ( compilation: 'ccc"' -- ; run-time: f -- ) \ core,exception-ext abort-quote |
: abort" ( compilation 'ccc"' -- ; run-time f -- ) \ core,exception-ext abort-quote |
postpone (abort") ," ; immediate restrict |
postpone (abort") ," ; immediate restrict |
|
|
\ Header states 23feb93py |
\ Header states 23feb93py |
Line 1066 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 1083 Create ??? 0 , 3 c, char ? c, char ? c,
|
|
|
\ DOES> 17mar93py |
\ DOES> 17mar93py |
|
|
: DOES> ( compilation: colon-sys1 -- colon-sys2 ; run-time: nest-sys -- ) \ core does |
: DOES> ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does |
state @ |
state @ |
IF |
IF |
;-hook postpone (does>) ?struc dodoes, |
;-hook postpone (does>) ?struc dodoes, |
Line 1139 defer ;-hook ( sys2 -- sys1 )
|
Line 1156 defer ;-hook ( sys2 -- sys1 )
|
|
|
: : ( -- colon-sys ) \ core colon |
: : ( -- colon-sys ) \ core colon |
Header docol: cfa, defstart ] :-hook ; |
Header docol: cfa, defstart ] :-hook ; |
: ; ( compilation: colon-sys -- ; run-time: nest-sys ) \ core semicolon |
: ; ( compilation colon-sys -- ; run-time nest-sys ) \ core semicolon |
;-hook ?struc postpone exit reveal postpone [ ; immediate restrict |
;-hook ?struc postpone exit reveal postpone [ ; immediate restrict |
|
|
: :noname ( -- xt colon-sys ) \ core-ext colon-no-name |
: :noname ( -- xt colon-sys ) \ core-ext colon-no-name |
Line 1233 G -1 warnings T !
|
Line 1250 G -1 warnings T !
|
|
|
: ' ( "name" -- addr ) \ core tick |
: ' ( "name" -- addr ) \ core tick |
name sfind 0= if -&13 bounce then ; |
name sfind 0= if -&13 bounce then ; |
: ['] ( compilation: "name" -- ; run-time: --addr ) \ core bracket-tick |
: ['] ( compilation "name" -- ; run-time --addr ) \ core bracket-tick |
' postpone ALiteral ; immediate |
' postpone ALiteral ; immediate |
\ Input 13feb93py |
\ Input 13feb93py |
|
|
Line 1321 Defer key ( -- c ) \ core
|
Line 1338 Defer key ( -- c ) \ core
|
tib /line |
tib /line |
loadfile @ ?dup |
loadfile @ ?dup |
IF read-line throw |
IF read-line throw |
ELSE loadline @ 0< IF 2drop false EXIT THEN |
ELSE sourceline# 0< IF 2drop false EXIT THEN |
accept true |
accept true |
THEN |
THEN |
1 loadline +! |
1 loadline +! |
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 |
sourceline# >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 |
source >in @ loadline @ loadfilename 2@ |
source >in @ sourceline# sourcefilename |
error-stack dup @ dup 1+ |
error-stack dup @ dup 1+ |
max-errors 1- min error-stack ! |
max-errors 1- min error-stack ! |
6 * cells + cell+ |
6 * cells + cell+ |
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 1436 create pathfilenamebuf 256 chars allot \
|
Line 1455 create pathfilenamebuf 256 chars allot \
|
pathfilenamebuf swap ; |
pathfilenamebuf swap ; |
|
|
create included-files 0 , 0 , ( pointer to and count of included files ) |
create included-files 0 , 0 , ( pointer to and count of included files ) |
create image-included-files 0 , 0 , ( pointer to and count of included files ) |
here ," the terminal" dup c@ swap 1 + swap , A, here 2 cells - |
|
create image-included-files 1 , A, ( pointer to and count of included files ) |
\ 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 + ; |
|
|
|
: sourcefilename ( -- c-addr u ) \ gforth |
|
\ the name of the source file which is currently the input |
|
\ source. The result is valid only while the file is being |
|
\ loaded. If the current input source is no (stream) file, the |
|
\ result is undefined. |
|
loadfilename 2@ ; |
|
|
|
: sourceline# ( -- u ) \ gforth sourceline-number |
|
\ the line number of the line that is currently being interpreted |
|
\ from a (stream) file. The first line has the number 1. If the |
|
\ current input source is no (stream) file, the result is |
|
\ undefined. |
|
loadline @ ; |
|
|
: 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 1509 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 ) \ gforth |
: included ( i*x addr u -- j*x ) \ file |
open-path-file included1 ; |
open-path-file included1 ; |
|
|
: required ( i*x addr u -- j*x ) \ gforth |
: required ( i*x addr u -- j*x ) \ gforth |
Line 1519 create image-included-files 0 , 0 , ( po
|
Line 1559 create image-included-files 0 , 0 , ( po
|
|
|
\ RECURSE 17may93jaw |
\ RECURSE 17may93jaw |
|
|
: recurse ( compilation: -- ; run-time: ?? -- ?? ) \ core |
: recurse ( compilation -- ; run-time ?? -- ?? ) \ core |
lastxt compile, ; immediate restrict |
lastxt compile, ; immediate restrict |
: recursive ( -- ) \ gforth |
: recursive ( -- ) \ gforth |
reveal last off ; immediate |
reveal last off ; immediate |
Line 1536 create image-included-files 0 , 0 , ( po
|
Line 1576 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 1605 DEFER DOERROR
|
Line 1644 DEFER DOERROR
|
; |
; |
|
|
: (DoError) ( throw-code -- ) |
: (DoError) ( throw-code -- ) |
loadline @ IF |
sourceline# IF |
source >in @ loadline @ 0 0 .error-frame |
source >in @ sourceline# 0 0 .error-frame |
THEN |
THEN |
error-stack @ 0 ?DO |
error-stack @ 0 ?DO |
-1 error-stack +! |
-1 error-stack +! |
Line 1636 DEFER DOERROR
|
Line 1675 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 1661 Variable argc
|
Line 1700 Variable argc
|
|
|
: process-path ( addr1 u1 -- addr2 u2 ) |
: process-path ( addr1 u1 -- addr2 u2 ) |
\ addr1 u1 is a path string, addr2 u2 is an array of dir strings |
\ addr1 u1 is a path string, addr2 u2 is an array of dir strings |
here >r |
align here >r |
BEGIN |
BEGIN |
over >r [char] : scan |
over >r [char] : scan |
over r> tuck - ( rest-str this-str ) |
over r> tuck - ( rest-str this-str ) |
Line 1722 Defer 'cold ' noop IS 'cold
|
Line 1761 Defer 'cold ' noop IS 'cold
|
cr |
cr |
THEN |
THEN |
false to script? |
false to script? |
." GNU Forth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr |
." GForth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr |
." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr |
." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr |
." Type `bye' to exit" |
." Type `bye' to exit" |
loadline off quit ; |
loadline off quit ; |
|
|
Line 1745 Defer 'cold ' noop IS 'cold
|
Line 1784 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 catch DoError bye ; |
|
|
: bye ( -- ) \ tools-ext |
: bye ( -- ) \ tools-ext |
script? 0= IF cr THEN 0 (bye) ; |
script? 0= IF cr THEN 0 (bye) ; |