version 1.42, 1995/10/11 19:39:34
|
version 1.43, 1995/10/16 18:33:11
|
Line 1
|
Line 1
|
\ KERNAL.FS GNU FORTH kernal 17dec92py |
\ KERNAL.FS GForth kernal 17dec92py |
\ $ID: |
\ $ID: |
\ Idea and implementation: Bernd Paysan (py) |
\ Idea and implementation: Bernd Paysan (py) |
\ Copyright 1992 by the ANSI figForth Development Group |
\ Copyright 1992 by the ANSI figForth Development Group |
Line 85 DOES> ( n -- ) + c@ ;
|
Line 85 DOES> ( n -- ) + c@ ;
|
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 ; |
|
|
Line 226 Defer source ( -- addr count ) \ core
|
Line 226 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 360 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 572 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 586 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 595 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 695 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 725 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 752 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 778 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 829 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 840 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 858 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 884 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 922 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 936 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 961 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 1066 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 1139 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 1233 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 1476 create image-included-files 0 , 0 , ( po
|
Line 1476 create image-included-files 0 , 0 , ( po
|
['] include-file catch |
['] include-file catch |
r> r> loadfilename 2! throw ; |
r> r> loadfilename 2! 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 1519 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 1722 Defer 'cold ' noop IS 'cold
|
Line 1722 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 ; |
|
|