--- gforth/Attic/kernal.fs 1995/10/29 21:35:13 1.45 +++ gforth/Attic/kernal.fs 1996/07/16 20:57:11 1.60 @@ -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 @@ -57,17 +74,19 @@ HEX \ the code address of a @code{field} ['] reveal-method >code-address ; +NIL AConstant NIL \ gforth + \ 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 @@ -111,10 +130,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 @@ -123,25 +145,32 @@ DOES> ( n -- ) + c@ ; : off ( addr -- ) \ gforth false swap ! ; +\ dabs roll 17may93jaw + +: dabs ( d1 -- d2 ) \ double + dup 0< IF dnegate THEN ; + +: roll ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext + dup 1+ pick >r + cells sp@ cell+ dup cell+ rot move drop r> ; + \ name> found 17dec92py -: (name>) ( nfa -- cfa ) - count $1F and + cfaligned ; -: name> ( nfa -- cfa ) \ gforth - cell+ - dup (name>) swap c@ $80 and 0= IF @ THEN ; +$80 constant alias-mask \ set when the word is not an alias! +$40 constant immediate-mask +$20 constant restrict-mask -: found ( nfa -- cfa n ) \ gforth +: (name>) ( nfa+cell -- cfa ) + 1 cells - name>string + cfaligned ; +: name> ( nfa -- cfa ) \ gforth cell+ - dup c@ >r (name>) r@ $80 and 0= IF @ THEN - -1 r@ $40 and IF 1- THEN - r> $20 and IF negate THEN ; + dup (name>) swap c@ alias-mask and 0= IF @ THEN ; \ (find) 17dec92py \ : (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 ; @@ -227,23 +256,24 @@ Defer source ( -- addr count ) \ core \ Literal 17dec92py : Literal ( compilation n -- ; run-time -- n ) \ core - state @ IF postpone lit , THEN ; immediate + postpone lit , ; immediate restrict : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth - state @ IF postpone lit A, THEN ; - immediate + postpone lit A, ; immediate restrict : char ( 'char' -- n ) \ core bl word char+ c@ ; : [char] ( compilation 'char' -- ; run-time -- n ) - char postpone Literal ; immediate -' [char] Alias Ascii immediate + char postpone Literal ; immediate restrict : (compile) ( -- ) \ gforth r> dup cell+ >r @ compile, ; : postpone ( "name" -- ) \ core name sfind dup 0= abort" Can't compile " - 0> IF compile, ELSE postpone (compile) A, THEN ; - immediate restrict + 0> IF compile, ELSE postpone (compile) A, THEN ; immediate restrict + +: special: ( interp comp "name" -- ) + Create immediate swap A, A, + DOES> state @ IF cell+ THEN perform ; \ Use (compile) for the old behavior of compile! @@ -433,7 +463,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! @@ -466,11 +496,18 @@ Defer parser Defer name ( -- c-addr count ) \ gforth \ get the next word from the input buffer ' (name) IS name -Defer notfound ( c-addr count -- ) +Defer compiler-notfound ( c-addr count -- ) +Defer interpreter-notfound ( c-addr count -- ) : no.extensions ( addr u -- ) 2drop -&13 bounce ; -' no.extensions IS notfound +' no.extensions IS compiler-notfound +' no.extensions IS interpreter-notfound + +: compile-only ( ... -- ) + -&14 throw ; +Defer interpret-special ( c-addr u xt -- ) \ !! use nfa instead of xt? +' compile-only IS interpret-special : interpret ( ?? -- ?? ) \ gforth \ interpret/compile the (rest of the) input buffer @@ -485,27 +522,27 @@ Defer notfound ( c-addr count -- ) : interpreter ( c-addr u -- ) \ gforth \ interpretation semantics for the name/number c-addr u - 2dup sfind dup + 2dup (sfind) dup IF 1 and IF \ not restricted to compile state? nip nip execute EXIT THEN - -&14 throw + interpret-special exit THEN drop 2dup 2>r snumber? IF 2rdrop ELSE - 2r> notfound + 2r> interpreter-notfound THEN ; ' interpreter IS parser : compiler ( c-addr u -- ) \ gforth \ compilation semantics for the name/number c-addr u - 2dup sfind dup + 2dup (sfind) dup IF 0> IF @@ -523,7 +560,7 @@ Defer notfound ( c-addr count -- ) postpone Literal 2drop ELSE - drop notfound + drop compiler-notfound THEN ; : [ ( -- ) \ core left-bracket @@ -703,27 +740,29 @@ 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? - dead-orig = +: then-like ( orig -- addr ) + swap -rot dead-orig = if - >resolve drop + drop else dead-code @ if - >resolve set-locals-size-list dead-code off + set-locals-size-list dead-code off else \ both live - over list-size adjust-locals-size - >resolve + dup list-size adjust-locals-size locals-list @ common-list dup list-size adjust-locals-size locals-list ! then - then ; immediate restrict + then ; + +: THEN ( compilation orig -- ; run-time -- ) \ core + dup orig? then-like >resolve ; immediate restrict ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth immediate restrict @@ -752,13 +791,13 @@ 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 - dest? + +: again-like ( dest -- addr ) over list-size adjust-locals-size - POSTPONE branch - leave ) ; immediate restrict @@ -925,22 +964,14 @@ Avariable leave-sp leave-stack 3 cells : 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 - [char] " parse - state @ - IF - postpone SLiteral - ELSE - /line min >r s"-buffer r@ cmove - s"-buffer r> - THEN ; immediate - -: ." ( compilation 'ccc"' -- ; run-time -- ) \ core dot-quote - 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 @@ -966,12 +997,20 @@ create s"-buffer /line chars allot \ Header states 23feb93py -: flag! ( 8b -- ) - last @ dup 0= abort" last word was headerless" - cell+ tuck c@ xor swap c! ; -: immediate $20 flag! ; -: restrict $40 flag! ; -\ ' noop alias restrict +: cset ( bmask c-addr -- ) + tuck c@ or swap c! ; +: creset ( bmask c-addr -- ) + tuck c@ swap invert and swap c! ; +: ctoggle ( bmask c-addr -- ) + tuck c@ xor swap c! ; + +: lastflags ( -- c-addr ) + \ the address of the flags byte in the last header + \ aborts if the last defined word was headerless + last @ dup 0= abort" last word was headerless" cell+ ; + +: immediate immediate-mask lastflags cset ; +: restrict restrict-mask lastflags cset ; \ Header 23feb93py @@ -987,14 +1026,16 @@ defer header ( -- ) \ gforth \ puts down string as cstring dup c, here swap chars dup allot move ; -: name, ( "name" -- ) \ gforth - name name-too-short? name-too-long? - string, cfalign ; -: input-stream-header ( "name" -- ) - \ !! this is f83-implementation-dependent - align here last ! -1 A, - name, $80 flag! ; +: header, ( c-addr u -- ) \ gforth + name-too-long? + align here last ! + current @ 1 or A, \ link field; before revealing, it contains the + \ tagged reveal-into wordlist + string, cfalign + alias-mask lastflags cset ; +: input-stream-header ( "name" -- ) + name name-too-short? header, ; : input-stream ( -- ) \ general \ switches back to getting the name from the input stream ; ['] input-stream-header IS (header) ; @@ -1005,11 +1046,7 @@ defer header ( -- ) \ gforth create nextname-buffer 32 chars allot : nextname-header ( -- ) - \ !! f83-implementation-dependent - nextname-buffer count - align here last ! -1 A, - string, cfalign - $80 flag! + nextname-buffer count header, input-stream ; \ the next name is given in the string @@ -1032,7 +1069,9 @@ create nextname-buffer 32 chars allot lastcfa @ ; : Alias ( cfa "name" -- ) \ gforth - Header reveal , $80 flag! ; + Header reveal + alias-mask lastflags creset + dup A, lastcfa ! ; : name>string ( nfa -- addr count ) \ gforth name-to-string cell+ count $1F and ; @@ -1040,7 +1079,7 @@ create nextname-buffer 32 chars allot Create ??? 0 , 3 c, char ? c, char ? c, char ? c, : >name ( cfa -- nfa ) \ gforth to-name $21 cell do - dup i - count $9F and + cfaligned over $80 + = if + dup i - count $9F and + cfaligned over alias-mask + = if i - cell - unloop exit then cell +loop @@ -1064,17 +1103,6 @@ Create ??? 0 , 3 c, char ? c, char ? c, : Create ( -- ) \ core Header reveal dovar: cfa, ; -\ DOES> 17mar93py - -: DOES> ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does - state @ - IF - ;-hook postpone (does>) ?struc dodoes, - ELSE - align dodoes, here !does ] - THEN - defstart :-hook ; immediate - \ Create Variable User Constant 17mar93py : Variable ( -- ) \ core @@ -1110,25 +1138,8 @@ Create ??? 0 , 3 c, char ? c, char ? c, \ Create ( -- ) \ ['] noop A, \ DOES> ( ??? ) -\ @ execute ; +\ perform ; -: IS ( addr "name" -- ) \ gforth - ' >body - state @ - IF postpone ALiteral postpone ! - ELSE ! - THEN ; immediate -' IS Alias TO ( addr "name" -- ) \ core-ext -immediate - -: What's ( "name" -- addr ) \ gforth - ' >body - state @ - IF - postpone ALiteral postpone @ - ELSE - @ - THEN ; immediate : Defers ( "name" -- ) \ gforth ' >body @ compile, ; immediate @@ -1152,16 +1163,10 @@ AVariable current ( -- addr ) \ gforth : last? ( -- false / nfa nfa ) last @ ?dup ; -: (reveal) ( -- ) - last? - IF - dup @ 0< - IF - current @ @ over ! current @ ! - ELSE - drop - THEN - THEN ; +: (reveal) ( nfa wid -- ) + ( wid>wordlist-id ) dup >r + @ over ( name>link ) ! + r> ! ; \ object oriented search list 17mar93py @@ -1169,7 +1174,7 @@ AVariable current ( -- addr ) \ gforth struct 1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) - 1 cells: field reveal-method \ xt: ( -- ) \ used by dofield:, must be field + 1 cells: field reveal-method \ xt: ( nfa wid -- ) \ used by dofield:, must be field 1 cells: field rehash-method \ xt: ( wid -- ) \ \ !! what else end-struct wordlist-map-struct @@ -1181,27 +1186,82 @@ struct 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) end-struct wordlist-struct -: f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; +: f83find ( addr len wordlist -- nfa / false ) + ( wid>wordlist-id ) @ (f83find) ; \ Search list table: find reveal -Create f83search ' f83find A, ' (reveal) A, ' drop A, +Create f83search ( -- wordlist-map ) + ' f83find A, ' (reveal) A, ' drop A, Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A, AVariable lookup G forth-wordlist lookup T ! G forth-wordlist current T ! +\ higher level parts of find + +: special? ( xt -- flag ) + >does-code ['] S" >does-code = ; + +: xt>i ( xt -- xt ) + dup special? IF >body @ THEN ; + +: xt>c ( xt -- xt ) + dup special? IF >body cell+ @ THEN ; + +: xt>s ( xt -- xt ) + dup special? IF >body state @ IF cell+ THEN @ THEN ; + +: found ( nfa -- cfa n ) \ gforth + cell+ dup c@ >r (name>) + r@ alias-mask and 0= IF @ THEN -1 + r@ restrict-mask and IF 1- THEN + r> immediate-mask and IF negate THEN ; + : (search-wordlist) ( addr count wid -- nfa / false ) - dup wordlist-map @ find-method @ execute ; + dup wordlist-map @ find-method perform ; : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search - (search-wordlist) dup IF found THEN ; + (search-wordlist) dup IF found swap xt>s swap THEN ; + +: (sfind) ( c-addr u -- xt n / 0 ) + lookup @ (search-wordlist) dup IF found THEN ; + +: sfind ( c-addr u -- xt n / 0 ) \ gforth + lookup @ search-wordlist ; + +: find ( addr -- cfa +-1 / string false ) \ core,search + dup count sfind dup IF + rot drop + THEN + dup 1 and 0= IF 2/ THEN ; + +: (') ( "name" -- xt ) \ gforth paren-tick + name (sfind) 0= IF -&13 bounce THEN ; +: [(')] ( compilation "name" -- ; run-time -- addr ) \ gforth bracket-paren-tick + (') postpone ALiteral ; immediate restrict + +: ' ( "name" -- xt ) \ core tick + (') xt>i ; +: ['] ( compilation "name" -- ; run-time -- addr ) \ core bracket-tick + ' postpone ALiteral ; immediate restrict + +: C' ( "name" -- xt ) \ gforth c-tick + (') xt>c ; +: [C'] ( compilation "name" -- ; run-time -- addr ) \ gforth bracket-c-tick + C' postpone ALiteral ; immediate restrict + +: S' ( "name" -- xt ) \ gforth s-tick + (') xt>s ; +: [S'] ( compilation "name" -- ; run-time -- addr ) \ gforth bracket-s-tick + S' postpone ALiteral ; immediate restrict + +\ reveal words Variable warnings ( -- addr ) \ gforth G -1 warnings T ! : check-shadow ( addr count wid -- ) \ prints a warning if the string is already present in the wordlist -\ !! should be refined so the user can suppress the warnings >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if ." redefined " name>string 2dup type compare 0<> if @@ -1213,28 +1273,20 @@ G -1 warnings T ! then 2drop 2drop ; -: sfind ( c-addr u -- xt n / 0 ) \ gforth - lookup @ search-wordlist ; - -: find ( addr -- cfa +-1 / string false ) \ core,search - \ !! not ANS conformant: returns +-2 for restricted words - dup count sfind dup if - rot drop - then ; - : reveal ( -- ) \ gforth - last? if - name>string current @ check-shadow - then - current @ wordlist-map @ reveal-method @ execute ; + last? + if \ the last word has a header + dup ( name>link ) @ 1 and + if \ it is still hidden + dup ( name>link ) @ 1 xor ( nfa wid ) + 2dup >r name>string r> check-shadow ( nfa wid ) + dup wordlist-map @ reveal-method perform + then + then ; : rehash ( wid -- ) - dup wordlist-map @ rehash-method @ execute ; + dup wordlist-map @ rehash-method perform ; -: ' ( "name" -- addr ) \ core tick - name sfind 0= if -&13 bounce then ; -: ['] ( compilation "name" -- ; run-time --addr ) \ core bracket-tick - ' postpone ALiteral ; immediate \ Input 13feb93py 07 constant #bell ( -- c ) \ gforth @@ -1247,43 +1299,37 @@ 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 ) - over 3 pick 2 pick chars /string ; -: type-rest ( span addr pos1 -- span addr pos1 back ) - >string tuck type ; -: (del) ( max span addr pos1 -- max span addr pos2 ) - 1- >string over 1+ -rot move - rot 1- -rot #bs emit type-rest bl emit 1+ backspaces ; -: (ins) ( max span addr pos1 char -- max span addr pos2 ) - >r >string over 1+ swap move 2dup chars + r> swap c! - rot 1+ -rot type-rest 1- backspaces 1+ ; -: ?del ( max span addr pos1 -- max span addr pos2 0 ) - dup IF (del) THEN 0 ; -: (ret) type-rest drop true space ; -: back dup IF 1- #bs emit ELSE #bell emit THEN 0 ; -: forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ; -: eof 2 pick 0= IF bye ELSE (ret) THEN ; + +: (ins) ( max span addr pos1 key -- max span addr pos2 ) + >r 2dup + r@ swap c! r> emit 1+ rot 1+ -rot ; +: (bs) ( max span addr pos1 -- max span addr pos2 flag ) + dup IF + #bs emit bl emit #bs emit 1- rot 1- -rot + THEN false ; +: (ret) true space ; Create ctrlkeys - ] false false back false eof false forw false - ?del false (ret) false false (ret) false false + ] false false false false false false false false + (bs) false (ret) false false (ret) false false false false false false false false false false false false false false false false false false [ +defer insert-char +' (ins) IS insert-char defer everychar ' noop IS everychar : decode ( max span addr pos1 key -- max span addr pos2 flag ) everychar dup #del = IF drop #bs THEN \ del is rubout - dup bl < IF cells ctrlkeys + @ execute EXIT THEN + dup bl < IF cells ctrlkeys + perform EXIT THEN >r 2over = IF rdrop bell 0 EXIT THEN - r> (ins) 0 ; - -\ decode should better use a table for control key actions -\ to define keyboard bindings later + r> insert-char 0 ; : accept ( addr len -- len ) \ core dup 0< IF abs over dup 1 chars - c@ tuck type @@ -1294,26 +1340,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 +1367,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 +1384,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 +1409,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 +1425,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 ) @@ -1404,6 +1452,17 @@ create pathfilenamebuf 256 chars allot \ \ ELSE false \ THEN ; +: absolut-path? ( addr u -- flag ) \ gforth + \ a path is absolute, if it starts with a / or a ~ (~ expansion), + \ or if it is in the form ./* or ../*, extended regexp: [/~]|./|../ + \ Pathes simply containing a / are not absolute! + over c@ '/ = >r + over c@ '~ = >r + 2dup 2 min S" ./" compare 0= >r + 3 min S" ../" compare 0= + r> r> r> or or or ; +\ [char] / scan nip 0<> ; + : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) \ gforth \ opens a file for reading, searching in the path for it (unless \ the filename contains a slash); c-addr2 u2 is the full filename @@ -1413,7 +1472,7 @@ create pathfilenamebuf 256 chars allot \ \ the path will usually contain dirs that are only readable for \ the user \ !! use file-status to determine access mode? - 2dup [char] / scan nip ( 0<> ) + 2dup absolut-path? if \ the filename contains a slash 2dup r/o open-file throw ( c-addr1 u1 file-id ) -rot >r pathfilenamebuf r@ cmove ( file-id R: u1 ) @@ -1436,10 +1495,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 +1549,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 ; @@ -1521,8 +1601,8 @@ create image-included-files 0 , 0 , ( po : recurse ( compilation -- ; run-time ?? -- ?? ) \ core lastxt compile, ; immediate restrict -: recursive ( -- ) \ gforth - reveal last off ; immediate +' reveal alias recursive ( -- ) \ gforth + immediate \ */MOD */ 17may93jaw @@ -1536,9 +1616,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 +1684,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 +1715,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 ; @@ -1709,6 +1788,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 +1802,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 +1825,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) ; @@ -1756,3 +1836,5 @@ Defer 'cold ' noop IS 'cold \ or space and stackspace overrides \ 0 arg contains, however, the name of the program. + +