--- gforth/Attic/kernal.fs 1994/11/17 15:53:14 1.26 +++ gforth/Attic/kernal.fs 1995/09/06 21:00:21 1.40 @@ -66,6 +66,15 @@ DOES> ( n -- ) + c@ ; bl c, LOOP ; +\ !! this is machine-dependent, but works on all but the strangest machines +' faligned Alias maxaligned +' falign Alias maxalign + +\ the code field is aligned if its body is maxaligned +\ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned" +' maxaligned Alias cfaligned +' maxalign Alias cfalign + : chars ; immediate : A! ( addr1 addr2 -- ) dup relon ! ; @@ -78,9 +87,11 @@ DOES> ( n -- ) + c@ ; \ name> found 17dec92py -: (name>) ( nfa -- cfa ) count $1F and + aligned ; -: name> ( nfa -- cfa ) cell+ - dup (name>) swap c@ $80 and 0= IF @ THEN ; +: (name>) ( nfa -- cfa ) + count $1F and + cfaligned ; +: name> ( nfa -- cfa ) + cell+ + dup (name>) swap c@ $80 and 0= IF @ THEN ; : found ( nfa -- cfa n ) cell+ dup c@ >r (name>) r@ $80 and 0= IF @ THEN @@ -142,14 +153,14 @@ Defer source \ word parse 23feb93py : parse-word ( char -- addr len ) - source 2dup >r >r >in @ /string + source 2dup >r >r >in @ over min /string rot dup bl = IF drop (parse-white) ELSE (word) THEN 2dup + r> - 1+ r> min >in ! ; : word ( char -- addr ) parse-word here place bl here count + c! here ; : parse ( char -- addr len ) - >r source >in @ /string over swap r> scan >r + >r source >in @ over min /string over swap r> scan >r over - dup r> IF 1+ THEN >in +! ; \ name 13feb93py @@ -162,6 +173,12 @@ Defer source 2dup + r> - 1+ r> min >in ! ; \ name count ; +: name-too-short? ( c-addr u -- c-addr u ) + dup 0= -&16 and throw ; + +: name-too-long? ( c-addr u -- c-addr u ) + dup $1F u> -&19 and throw ; + \ Literal 17dec92py : Literal ( n -- ) state @ IF postpone lit , THEN ; @@ -329,7 +346,9 @@ hex \ ?stack 23feb93py -: ?stack ( ?? -- ?? ) sp@ s0 @ > IF -4 throw THEN ; +: ?stack ( ?? -- ?? ) + sp@ s0 @ > IF -4 throw THEN + fp@ f0 @ > IF -&45 throw THEN ; \ ?stack should be code -- it touches an empty stack! \ interpret 10mar92py @@ -358,7 +377,7 @@ Defer notfound ( c-addr count -- ) IF 1 and IF \ not restricted to compile state? - nip nip execute EXIT + nip nip execute EXIT THEN -&14 throw THEN @@ -693,8 +712,9 @@ Avariable leave-sp leave-stack 3 cells cell - dup @ swap leave-sp ! ; -: DONE ( orig -- ) drop >r drop +: DONE ( orig -- ) \ !! the original done had ( addr -- ) + drop >r drop begin leave> over r@ u>= @@ -769,13 +789,30 @@ Avariable leave-sp leave-stack 3 cells : (S") "lit count ; restrict : SLiteral postpone (S") here over char+ allot place align ; immediate restrict -: S" [char] " parse state @ IF postpone SLiteral THEN ; +create s"-buffer /line chars allot +: S" ( run-time: -- c-addr u ) + [char] " parse + state @ + IF + postpone SLiteral + ELSE + /line min >r s"-buffer r@ cmove + s"-buffer r> + THEN ; immediate : ." state @ IF postpone (.") ," align ELSE [char] " parse type THEN ; immediate : ( [char] ) parse 2drop ; immediate -: \ blk @ IF >in @ c/l / 1+ c/l * >in ! EXIT THEN - source >in ! drop ; immediate +: \ ( -- ) \ core-ext backslash + blk @ + IF + >in @ c/l / 1+ c/l * >in ! + EXIT + THEN + source >in ! drop ; immediate + +: \G ( -- ) \ new backslash + POSTPONE \ ; immediate \ error handling 22feb93py \ 'abort thrown out! 11may93jaw @@ -802,10 +839,13 @@ Avariable leave-sp leave-stack 3 cells defer (header) defer header ' (header) IS header +: string, ( c-addr u -- ) + \ puts down string as cstring + dup c, here swap chars dup allot move ; + : name, ( "name" -- ) - name - dup $1F u> -&19 and throw ( is name too long? ) - dup c, here swap chars dup allot move align ; + name name-too-short? name-too-long? + string, cfalign ; : input-stream-header ( "name" -- ) \ !! this is f83-implementation-dependent align here last ! -1 A, @@ -824,19 +864,19 @@ create nextname-buffer 32 chars allot \ !! f83-implementation-dependent nextname-buffer count align here last ! -1 A, - dup c, here swap chars dup allot move align + string, cfalign $80 flag! input-stream ; \ the next name is given in the string : nextname ( c-addr u -- ) \ general - dup $1F u> -&19 and throw ( is name too long? ) + name-too-long? nextname-buffer c! ( c-addr ) nextname-buffer count move ['] nextname-header IS (header) ; : noname-header ( -- ) - 0 last ! + 0 last ! cfalign input-stream ; : noname ( -- ) \ general @@ -856,7 +896,7 @@ create nextname-buffer 32 chars allot Create ??? 0 , 3 c, char ? c, char ? c, char ? c, : >name ( cfa -- nfa ) $21 cell do - dup i - count $9F and + aligned over $80 + = if + dup i - count $9F and + cfaligned over $80 + = if i - cell - unloop exit then cell +loop @@ -902,10 +942,10 @@ Create ??? 0 , 3 c, char ? c, char ? c, : Constant (Constant) , ; : AConstant (Constant) A, ; -: 2CONSTANT - create ( w1 w2 "name" -- ) +: 2Constant + Create ( w1 w2 "name" -- ) 2, - does> ( -- w1 w2 ) + DOES> ( -- w1 w2 ) 2@ ; \ IS Defer What's Defers TO 24feb93py @@ -952,32 +992,33 @@ AVariable current : last? ( -- false / nfa nfa ) last @ ?dup ; : (reveal) ( -- ) - last? - IF - dup @ 0< - IF - current @ @ over ! current @ ! - ELSE - drop - THEN - THEN ; + last? + IF + dup @ 0< + IF + current @ @ over ! current @ ! + ELSE + drop + THEN + THEN ; \ object oriented search list 17mar93py \ word list structure: -\ struct -\ 1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) -\ 1 cells: field reveal-method \ xt: ( -- ) -\ 1 cells: field rehash-method \ xt: ( wid -- ) + +struct + 1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) + 1 cells: field reveal-method \ xt: ( -- ) + 1 cells: field rehash-method \ xt: ( wid -- ) \ \ !! what else -\ end-struct wordlist-map-struct +end-struct wordlist-map-struct -\ struct -\ 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation -\ 1 cells: field wordlist-map \ pointer to a wordlist-map-struct -\ 1 cells: field wordlist-link \ link field to other wordlists -\ 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) -\ end-struct wordlist-struct +struct + 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation + 1 cells: field wordlist-map \ pointer to a wordlist-map-struct + 1 cells: field wordlist-link \ link field to other wordlists + 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) +end-struct wordlist-struct : f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; @@ -989,10 +1030,10 @@ AVariable lookup G forth-wordlist G forth-wordlist current T ! : (search-wordlist) ( addr count wid -- nfa / false ) - dup cell+ @ @ execute ; + dup wordlist-map @ find-method @ execute ; : search-wordlist ( addr count wid -- 0 / xt +-1 ) - (search-wordlist) dup IF found THEN ; + (search-wordlist) dup IF found THEN ; Variable warnings G -1 warnings T ! @@ -1023,9 +1064,9 @@ Variable warnings G -1 warnings T ! last? if name>string current @ check-shadow then - current @ cell+ @ cell+ @ execute ; + current @ wordlist-map @ reveal-method @ execute ; -: rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ; +: rehash ( wid -- ) dup wordlist-map @ rehash-method @ execute ; : ' ( "name" -- addr ) name sfind 0= if -&13 bounce then ; : ['] ( "name" -- addr ) ' postpone ALiteral ; immediate @@ -1057,9 +1098,10 @@ Variable warnings G -1 warnings T ! : (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 ; Create ctrlkeys - ] false false back false false false forw false + ] false false back false eof false forw false ?del false (ret) false false (ret) false false false false false false false false false false false false false false false false false false [ @@ -1109,7 +1151,7 @@ Defer key \ Query 07apr93py : refill ( -- flag ) - blk @ IF 1 blk +! true EXIT THEN + blk @ IF 1 blk +! true 0 >in ! EXIT THEN tib /line loadfile @ ?dup IF read-line throw @@ -1136,7 +1178,7 @@ Defer key \ : bin dup 1 chars - c@ \ r/o 4 chars + over - dup >r swap move r> ; -: bin 1+ ; +: bin 1 or ; create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos \ or not unix environments if @@ -1176,36 +1218,101 @@ create nl$ 1 c, A c, 0 c, \ gnu includes create pathfilenamebuf 256 chars allot \ !! make this grow on demand +\ : check-file-prefix ( addr len -- addr' len' flag ) +\ dup 0= IF true EXIT THEN +\ over c@ '/ = IF true EXIT THEN +\ over 2 S" ./" compare 0= IF true EXIT THEN +\ over 3 S" ../" compare 0= IF true EXIT THEN +\ over 2 S" ~/" compare 0= +\ IF 1 /string +\ S" HOME" getenv tuck pathfilenamebuf swap move +\ 2dup + >r pathfilenamebuf + swap move +\ pathfilenamebuf r> true +\ ELSE false +\ THEN ; + : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) - \ opens a file for reading, searching in the path for it; c-addr2 - \ u2 is the full filename (valid until the next call); if the file - \ is not found (or in case of other errors for each try), -38 - \ (non-existant file) is thrown. Opening for other access modes - \ makes little sense, as the path will usually contain dirs that - \ are only readable for the user - \ !! check for "/", "./", "../" in original filename; check for "~/"? + \ opens a file for reading, searching in the path for it (unless + \ the filename contains a slash); c-addr2 u2 is the full filename + \ (valid until the next call); if the file is not found (or in + \ case of other errors for each try), -38 (non-existant file) is + \ thrown. Opening for other access modes makes little sense, as + \ 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<> ) + 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 ) + pathfilenamebuf r> EXIT + then pathdirs 2@ 0 +\ check-file-prefix 0= +\ IF pathdirs 2@ 0 ?DO ( c-addr1 u1 dirnamep ) dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u ) 2dup pathfilenamebuf r@ chars + swap cmove ( addr u ) pathfilenamebuf over r> + dup >r r/o open-file 0= - if ( addr u file-id ) - nip nip r> rdrop 0 leave - then + IF ( addr u file-id ) + nip nip r> rdrop 0 LEAVE + THEN rdrop drop r> cell+ cell+ LOOP +\ ELSE 2dup open-file throw -rot THEN 0<> -&38 and throw ( file-id u2 ) pathfilenamebuf swap ; -: included ( i*x addr u -- j*x ) +create included-files 0 , 0 , ( pointer to and count of included files ) + +: included? ( c-addr u -- f ) + \ true, iff filename c-addr u is in included-files + included-files 2@ 0 + ?do ( c-addr u addr ) + dup >r 2@ 2over compare 0= + if + 2drop rdrop unloop + true EXIT + then + r> cell+ cell+ + loop + 2drop drop false ; + +: add-included-file ( c-addr u -- ) + \ add name c-addr u to included-files + included-files 2@ tuck 1+ 2* cells resize throw + swap 2dup 1+ included-files 2! + 2* cells + 2! ; + +: save-string ( addr1 u -- addr2 u ) + swap >r + dup allocate throw + swap 2dup r> -rot move ; + +: included1 ( i*x file-id c-addr u -- j*x ) + \ include the file file-id with the name given by c-addr u loadfilename 2@ >r >r - open-path-file ( file-id c-addr2 u2 ) - dup allocate throw over loadfilename 2! ( file-id c-addr2 u2 ) - drop loadfilename 2@ move + save-string 2dup loadfilename 2! add-included-file ( file-id ) ['] include-file catch - \ don't free filenames; they don't take much space - \ and are used for debugging r> r> loadfilename 2! throw ; + +: included ( i*x addr u -- j*x ) + open-path-file included1 ; + +: required ( i*x addr u -- j*x ) + \ include the file with the name given by addr u, if it is not + \ included already. Currently this works by comparing the name of + \ the file (with path) against the names of earlier included + \ files; however, it would probably be better to fstat the file, + \ and compare the device and inode. The advantages would be: no + \ problems with several paths to the same file (e.g., due to + \ links) and we would catch files included with include-file and + \ write a require-file. + open-path-file 2dup included? + if + 2drop close-file throw + else + included1 + then ; \ HEX DECIMAL 2may93jaw @@ -1222,12 +1329,15 @@ create pathfilenamebuf 256 chars allot \ : include ( "file" -- ) name included ; +: require ( "file" -- ) + name required ; + \ RECURSE 17may93jaw : recurse ( -- ) lastxt compile, ; immediate restrict : recursive ( -- ) - reveal ; immediate + reveal last off ; immediate \ */MOD */ 17may93jaw @@ -1385,22 +1495,25 @@ Variable argc 2drop here r> tuck - 2 cells / ; -: do-option ( addr1 len1 addr2 len2 -- n ) 2swap - 2dup s" -e" compare 0= >r - 2dup s" -evaluate" compare 0= r> or - IF 2drop dup >r ['] evaluate catch - ?dup IF dup >r DoError r> negate (bye) THEN - r> >tib +! 2 EXIT THEN - ." Unknown option: " type cr 2drop 1 ; +: do-option ( addr1 len1 addr2 len2 -- n ) + 2swap + 2dup s" -e" compare 0= >r + 2dup s" --evaluate" compare 0= r> or + IF 2drop dup >r ['] evaluate catch + ?dup IF dup >r DoError r> negate (bye) THEN + r> >tib +! 2 EXIT THEN + ." Unknown option: " type cr 2drop 1 ; -: process-args ( -- ) >tib @ >r +: process-args ( -- ) + >tib @ >r argc @ 1 ?DO I arg over c@ [char] - <> IF - true to script? included false to script? 1 + required 1 ELSE - I 1+ arg do-option + I 1+ argc @ = IF s" " ELSE I 1+ arg THEN + do-option THEN +LOOP r> >tib ! ; @@ -1409,16 +1522,19 @@ Defer 'cold ' noop IS 'cold : cold ( -- ) pathstring 2@ process-path pathdirs 2! + 0 0 included-files 2! 'cold argc @ 1 > IF + true to script? ['] process-args catch ?dup IF dup >r DoError cr r> negate (bye) THEN + cr THEN - cr - ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr + 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 ." Type `bye' to exit" loadline off quit ;