--- gforth/Attic/kernal.fs 1995/10/16 18:33:11 1.43 +++ gforth/Attic/kernal.fs 1996/04/17 16:39:41 1.54 @@ -1,7 +1,24 @@ \ 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) -\ Copyright 1992 by the ANSI figForth Development Group \ Log: ', '- usw. durch [char] ... ersetzt \ man sollte die unterschiedlichen zahlensysteme @@ -59,15 +76,15 @@ HEX \ Bit string manipulation 06oct92py -Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, -DOES> ( n -- ) + c@ ; +\ Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, +\ DOES> ( n -- ) + c@ ; -: >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; -: +bit ( addr n -- ) >bit over c@ or swap c! ; +\ : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; +\ : +bit ( addr n -- ) >bit over c@ or swap c! ; -: relinfo ( -- addr ) forthstart dup @ + ; -: >rel ( addr -- n ) forthstart - ; -: relon ( addr -- ) relinfo swap >rel cell / +bit ; +\ : relinfo ( -- addr ) forthstart dup @ + !!bug!! ; +\ : >rel ( addr -- n ) forthstart - ; +\ : relon ( addr -- ) relinfo swap >rel cell / +bit ; \ here allot , c, A, 17dec92py @@ -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 @@ -111,10 +128,13 @@ DOES> ( n -- ) + c@ ; ; immediate -: A! ( addr1 addr2 -- ) \ gforth - dup relon ! ; -: A, ( addr -- ) \ gforth - here cell allot A! ; +\ : A! ( addr1 addr2 -- ) \ gforth +\ dup relon ! ; +\ : A, ( addr -- ) \ gforth +\ here cell allot A! ; +' ! alias A! ( addr1 addr2 -- ) \ gforth +' , alias A, ( addr -- ) \ gforth + \ on off 23feb93py @@ -125,8 +145,8 @@ DOES> ( n -- ) + c@ ; \ name> found 17dec92py -: (name>) ( nfa -- cfa ) - count $1F and + cfaligned ; +: (name>) ( nfa+cell -- cfa ) + 1 cells - name>string + cfaligned ; : name> ( nfa -- cfa ) \ gforth cell+ dup (name>) swap c@ $80 and 0= IF @ THEN ; @@ -141,7 +161,7 @@ DOES> ( n -- ) + c@ ; \ : (find) ( addr count nfa1 -- nfa2 / false ) \ BEGIN dup WHILE dup >r -\ cell+ count $1F and dup >r 2over r> = +\ name>string dup >r 2over r> = \ IF -text 0= IF 2drop r> EXIT THEN \ ELSE 2drop drop THEN r> @ \ REPEAT nip nip ; @@ -433,7 +453,7 @@ hex : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception ?DUP IF - [ here 4 cells ! ] + [ here 9 cells ! ] handler @ rp! r> handler ! r> lp! @@ -703,10 +723,11 @@ variable backedge-locals : ?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 +\ better handled by tools like stack checkers. Besides, it's faster. + POSTPONE ?dup-?branch >mark ; immediate restrict + : ?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-0=-?branch >mark ; immediate restrict : THEN ( compilation orig -- ; run-time -- ) \ core dup orig? @@ -861,19 +882,19 @@ Avariable leave-sp leave-stack 3 cells : ?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 n1 n2 -- | 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 u1 u2 -- | 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 n1 n2 -- | 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 u1 u2 -- | 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 u -- loop-sys ) \ gforth POSTPONE (for) POSTPONE begin drop do-dest ( 0 0 0 >leave ) ; immediate restrict @@ -940,7 +961,13 @@ create s"-buffer /line chars allot state @ IF postpone (.") ," align ELSE [char] " parse type THEN ; immediate : ( ( compilation 'ccc' -- ; run-time -- ) \ core,file paren - [char] ) parse 2drop ; immediate + BEGIN + >in @ [char] ) parse nip >in @ rot - = + WHILE + loadfile @ IF + refill 0= abort" missing ')' in paren comment" + THEN + REPEAT ; immediate : \ ( -- ) \ core-ext backslash blk @ IF @@ -1247,6 +1274,9 @@ G -1 warnings T ! 0A constant #lf ( -- c ) \ gforth : bell #bell emit ; +: cr ( -- ) \ core + \ emit a newline + #lf ( sic! ) emit ; \ : backspaces 0 ?DO #bs emit LOOP ; : >string ( span addr pos1 -- span addr pos1 addr2 len ) @@ -1294,26 +1324,26 @@ defer everychar \ Output 13feb93py +: (type) ( c-addr u -- ) \ gforth + outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ? +; + Defer type ( c-addr u -- ) \ core \ defer type for a output buffer or fast \ screen write -\ : (type) ( addr len -- ) -\ bounds ?DO I c@ emit LOOP ; - ' (type) IS Type +: (emit) ( c -- ) \ gforth + outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ? +; + Defer emit ( c -- ) \ core ' (Emit) IS Emit Defer key ( -- c ) \ core ' (key) IS key -\ : form ( -- rows cols ) &24 &80 ; -\ form should be implemented using TERMCAPS or CURSES -\ : rows form drop ; -\ : cols form nip ; - \ Query 07apr93py : refill ( -- flag ) \ core-ext,block-ext,file-ext @@ -1321,7 +1351,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 +! @@ -1338,8 +1368,8 @@ Defer key ( -- c ) \ core \ 2 c, here char r c, char + c, 0 c, \ 2 c, here char w c, char + c, 0 c, align 4 Constant w/o ( -- fam ) \ file w-o -2 Constant r/w ( -- fam ) \ file r-o -0 Constant r/o ( -- fam ) \ file r-w +2 Constant r/w ( -- fam ) \ file r-w +0 Constant r/o ( -- fam ) \ file r-o \ BIN WRITE-LINE 11jun93jaw @@ -1363,12 +1393,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 +1409,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 +1468,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,10 +1522,12 @@ 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 ) \ file open-path-file included1 ; @@ -1536,9 +1589,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 +1657,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,13 +1688,13 @@ DEFER DOERROR postpone [ ['] 'quit CATCH dup WHILE - DoError r@ >tib ! + DoError r@ >tib ! r@ tibstack ! REPEAT drop r> >tib ! ; \ Cold 13feb93py -\ : .name ( name -- ) cell+ count $1F and type space ; +\ : .name ( name -- ) name>string type space ; \ : words listwords @ \ BEGIN @ dup WHILE dup .name REPEAT drop ; @@ -1661,7 +1713,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 ) @@ -1709,6 +1761,7 @@ Variable argc Defer 'cold ' noop IS 'cold : cold ( -- ) \ gforth + stdout TO outfile-id pathstring 2@ process-path pathdirs 2! init-included-files 'cold @@ -1722,7 +1775,7 @@ Defer 'cold ' noop IS 'cold cr THEN false to script? - ." GForth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr + ." GForth " version-string type ." , Copyright (C) 1994-1996 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 +1798,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) ;