--- gforth/Attic/kernal.fs 1995/10/11 19:39:34 1.42 +++ gforth/Attic/kernal.fs 1995/11/30 18:01:48 1.49 @@ -1,7 +1,24 @@ -\ KERNAL.FS GNU FORTH kernal 17dec92py -\ $ID: +\ KERNAL.FS GForth kernal 17dec92py + +\ 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) -\ Copyright 1992 by the ANSI figForth Development Group \ Log: ', '- usw. durch [char] ... ersetzt \ man sollte die unterschiedlichen zahlensysteme @@ -84,13 +101,13 @@ DOES> ( n -- ) + c@ ; : 2, ( w1 w2 -- ) \ gforth here 2 cells allot 2! ; -: aligned ( addr -- addr' ) \ core - [ cell 1- ] Literal + [ -1 cells ] Literal and ; +\ : aligned ( addr -- addr' ) \ core +\ [ cell 1- ] Literal + [ -1 cells ] Literal and ; : align ( -- ) \ core here dup aligned swap ?DO bl c, LOOP ; -: faligned ( addr -- f-addr ) \ float - [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; +\ : faligned ( addr -- f-addr ) \ float +\ [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; : falign ( -- ) \ float here dup faligned swap @@ -226,15 +243,15 @@ Defer source ( -- addr count ) \ core \ Literal 17dec92py -: Literal ( compilation: n -- ; run-time: -- n ) \ core +: Literal ( compilation n -- ; run-time -- n ) \ core 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 ; immediate : char ( 'char' -- n ) \ core bl word char+ c@ ; -: [char] ( compilation: 'char' -- ; run-time: -- n ) +: [char] ( compilation 'char' -- ; run-time -- n ) char postpone Literal ; immediate ' [char] Alias Ascii immediate @@ -360,7 +377,7 @@ hex >r 0 r@ um/mod r> swap >r um/mod r> ; -: pad ( -- addr ) \ core +: pad ( -- addr ) \ core-ext here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ; \ hold <# #> sign # #s 25jan92py @@ -572,7 +589,7 @@ variable backedge-locals \ 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 \ the tail. list3 is the largest sublist of both lists. begin @@ -586,7 +603,7 @@ variable backedge-locals repeat drop ; -: sub-list? ( list1 list2 -- f ) +: sub-list? ( list1 list2 -- f ) \ gforth-internal \ true iff list1 is a sublist of list2 begin 2dup u< @@ -595,7 +612,7 @@ variable backedge-locals repeat = ; -: list-size ( list -- u ) +: list-size ( list -- u ) \ gforth-internal \ size of the locals frame represented by list 0 ( list n ) begin @@ -695,20 +712,20 @@ variable backedge-locals \ Structural Conditionals 12dec92py -: AHEAD ( compilation: -- orig ; run-time: -- ) \ tools-ext +: AHEAD ( compilation -- orig ; run-time -- ) \ tools-ext 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 -: ?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 \ better handled by tools like stack checkers 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 -: THEN ( compilation: orig -- ; run-time: -- ) \ core +: THEN ( compilation orig -- ; run-time -- ) \ core dup orig? dead-orig = if @@ -725,19 +742,19 @@ variable backedge-locals then then ; immediate restrict -' THEN alias ENDIF ( compilation: orig -- ; run-time: -- ) \ gforth +' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth immediate restrict \ 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 \ brought up with fig-Forth). -: ELSE ( compilation: orig1 -- orig2 ; run-time: f -- ) \ core +: ELSE ( compilation orig1 -- orig2 ; run-time f -- ) \ core POSTPONE ahead 1 cs-roll POSTPONE then ; immediate restrict -: BEGIN ( compilation: -- dest ; run-time: -- ) \ core +: BEGIN ( compilation -- dest ; run-time -- ) \ core dead-code @ if \ set up an assumption of the locals visible here. if the \ users want something to be visible, they have to declare @@ -752,7 +769,7 @@ immediate restrict \ issue a warning (see below). The following code is generated: \ lp+!# (current-local-size - dest-locals-size) \ branch -: AGAIN ( compilation: dest -- ; run-time: -- ) \ core-ext +: AGAIN ( compilation dest -- ; run-time -- ) \ core-ext dest? over list-size adjust-locals-size POSTPONE branch @@ -778,14 +795,14 @@ immediate restrict then ( list ) check-begin ; -: UNTIL ( compilation: dest -- ; run-time: f -- ) \ core +: UNTIL ( compilation dest -- ; run-time f -- ) \ core 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 1 cs-roll ; immediate restrict -: REPEAT ( compilation: orig dest -- ; run-time: -- ) \ core +: REPEAT ( compilation orig dest -- ; run-time -- ) \ core POSTPONE again POSTPONE then ; immediate restrict @@ -829,7 +846,7 @@ Avariable leave-sp leave-stack 3 cells cell - dup @ swap leave-sp ! ; -: DONE ( compilation: orig -- ; run-time: -- ) \ gforth +: DONE ( compilation orig -- ; run-time -- ) \ gforth \ !! the original done had ( addr -- ) drop >r drop begin @@ -840,15 +857,15 @@ Avariable leave-sp leave-stack 3 cells repeat >leave rdrop ; immediate restrict -: LEAVE ( compilation: -- ; run-time: loop-sys -- ) \ core +: LEAVE ( compilation -- ; run-time loop-sys -- ) \ core POSTPONE ahead >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 >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 begin drop do-dest ( 0 0 0 >leave ) ; immediate restrict @@ -858,22 +875,22 @@ Avariable leave-sp leave-stack 3 cells >mark >leave 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 -: +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 -: 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 -: -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 -: 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 -: FOR ( compilation: -- do-sys ; run-time: w -- loop-sys ) \ gforth +: FOR ( compilation -- do-sys ; run-time w -- loop-sys ) \ gforth POSTPONE (for) POSTPONE begin drop do-dest ( 0 0 0 >leave ) ; immediate restrict @@ -884,34 +901,34 @@ Avariable leave-sp leave-stack 3 cells >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest? 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 ( 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 \ !! 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 \ 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 \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for \ 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 -: 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 \ Structural Conditionals 12dec92py -: EXIT ( compilation: -- ; run-time: nest-sys -- ) \ core +: EXIT ( compilation -- ; run-time nest-sys -- ) \ core 0 adjust-locals-size POSTPONE ;s 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 \ Strings 22feb93py @@ -922,11 +939,11 @@ Avariable leave-sp leave-stack 3 cells r> r> dup count + aligned >r swap >r ; restrict : (.") "lit count type ; 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 ; immediate restrict 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 state @ IF @@ -936,10 +953,10 @@ create s"-buffer /line chars allot s"-buffer r> THEN ; immediate -: ." ( compilation: 'ccc"' -- ; run-time: -- ) \ core dot-quote +: ." ( compilation 'ccc"' -- ; run-time -- ) \ core dot-quote state @ IF postpone (.") ," align ELSE [char] " parse type THEN ; immediate -: ( ( compilation: 'ccc' -- ; run-time: -- ) \ core,file paren +: ( ( compilation 'ccc' -- ; run-time -- ) \ core,file paren [char] ) parse 2drop ; immediate : \ ( -- ) \ core-ext backslash blk @ @@ -961,7 +978,7 @@ create s"-buffer /line chars allot r> "error ! -2 throw THEN 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 \ Header states 23feb93py @@ -1066,7 +1083,7 @@ Create ??? 0 , 3 c, char ? c, char ? c, \ 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 @ IF ;-hook postpone (does>) ?struc dodoes, @@ -1139,7 +1156,7 @@ defer ;-hook ( sys2 -- sys1 ) : : ( -- colon-sys ) \ core colon 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 : :noname ( -- xt colon-sys ) \ core-ext colon-no-name @@ -1233,7 +1250,7 @@ G -1 warnings T ! : ' ( "name" -- addr ) \ core tick 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 \ Input 13feb93py @@ -1321,7 +1338,7 @@ Defer key ( -- c ) \ core tib /line loadfile @ ?dup IF read-line throw - ELSE loadline @ 0< IF 2drop false EXIT THEN + ELSE sourceline# 0< IF 2drop false EXIT THEN accept true THEN 1 loadline +! @@ -1363,12 +1380,14 @@ create nl$ 1 c, A c, 0 c, \ gnu includes \ include-file 07apr93py : push-file ( -- ) r> - loadline @ >r loadfile @ >r - blk @ >r >tib @ >r #tib @ dup >r >tib +! >in @ >r >r ; + sourceline# >r loadfile @ >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 ) dup IF - source >in @ loadline @ loadfilename 2@ + source >in @ sourceline# sourcefilename error-stack dup @ dup 1+ max-errors 1- min error-stack ! 6 * cells + cell+ @@ -1377,7 +1396,7 @@ create nl$ 1 c, A c, 0 c, \ gnu includes -1 cells +LOOP THEN r> - r> >in ! r> #tib ! r> >tib ! r> blk ! + r> >in ! r> #tib ! r> >tib ! r> tibstack ! r> blk ! r> loadfile ! r> loadline ! >r ; : read-loop ( i*x -- j*x ) @@ -1436,10 +1455,29 @@ create pathfilenamebuf 256 chars allot \ pathfilenamebuf swap ; 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 \ 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 ( -- ) image-included-files 2@ 2* cells save-string drop ( addr ) image-included-files 2@ nip included-files 2! ; @@ -1471,12 +1509,14 @@ create image-included-files 0 , 0 , ( po : included1 ( i*x file-id c-addr u -- j*x ) \ gforth \ include the file file-id with the name given by c-addr u - loadfilename 2@ >r >r - save-string 2dup loadfilename 2! add-included-file ( file-id ) + loadfilename# @ >r + save-string add-included-file ( file-id ) + included-files 2@ nip 1- loadfilename# ! ['] 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 ; : required ( i*x addr u -- j*x ) \ gforth @@ -1519,7 +1559,7 @@ create image-included-files 0 , 0 , ( po \ RECURSE 17may93jaw -: recurse ( compilation: -- ; run-time: ?? -- ?? ) \ core +: recurse ( compilation -- ; run-time ?? -- ?? ) \ core lastxt compile, ; immediate restrict : recursive ( -- ) \ gforth reveal last off ; immediate @@ -1536,9 +1576,8 @@ create image-included-files 0 , 0 , ( po \ EVALUATE 17may93jaw : 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 ! -\ BEGIN interpret >in @ #tib @ u>= UNTIL ['] interpret catch pop-file throw ; @@ -1605,8 +1644,8 @@ DEFER DOERROR ; : (DoError) ( throw-code -- ) - loadline @ IF - source >in @ loadline @ 0 0 .error-frame + sourceline# IF + source >in @ sourceline# 0 0 .error-frame THEN error-stack @ 0 ?DO -1 error-stack +! @@ -1636,7 +1675,7 @@ DEFER DOERROR postpone [ ['] 'quit CATCH dup WHILE - DoError r@ >tib ! + DoError r@ >tib ! r@ tibstack ! REPEAT drop r> >tib ! ; @@ -1661,7 +1700,7 @@ Variable argc : process-path ( addr1 u1 -- addr2 u2 ) \ addr1 u1 is a path string, addr2 u2 is an array of dir strings - here >r + align here >r BEGIN over >r [char] : scan over r> tuck - ( rest-str this-str ) @@ -1722,8 +1761,8 @@ Defer 'cold ' noop IS 'cold cr THEN false to script? - ." GNU Forth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr - ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr + ." GForth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr + ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr ." Type `bye' to exit" loadline off quit ; @@ -1745,8 +1784,8 @@ Defer 'cold ' noop IS 'cold : boot ( path **argv argc -- ) argc ! argv ! cstring>sstring pathstring 2! main-task up! - sp@ dup s0 ! $10 + >tib ! #tib off >in off - rp@ r0 ! fp@ f0 ! cold ; + sp@ dup s0 ! $10 + dup >tib ! tibstack ! #tib off >in off + rp@ r0 ! fp@ f0 ! ['] cold catch DoError bye ; : bye ( -- ) \ tools-ext script? 0= IF cr THEN 0 (bye) ;