--- gforth/Attic/kernal.fs 1994/11/17 15:53:14 1.26 +++ gforth/Attic/kernal.fs 1995/03/13 09:17:31 1.32 @@ -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 @@ -358,7 +369,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 +704,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>= @@ -774,8 +786,16 @@ Avariable leave-sp leave-stack 3 cells : ." 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 +822,14 @@ 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 ; + string, cfalign ; : input-stream-header ( "name" -- ) \ !! this is f83-implementation-dependent align here last ! -1 A, @@ -824,7 +848,7 @@ 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 ; @@ -836,7 +860,7 @@ create nextname-buffer 32 chars allot ['] nextname-header IS (header) ; : noname-header ( -- ) - 0 last ! + 0 last ! cfalign input-stream ; : noname ( -- ) \ general @@ -856,7 +880,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 +926,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 @@ -965,19 +989,20 @@ AVariable current \ 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 +1014,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 +1048,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 @@ -1197,15 +1222,57 @@ create pathfilenamebuf 256 chars allot \ 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,6 +1289,9 @@ create pathfilenamebuf 256 chars allot \ : include ( "file" -- ) name included ; +: require ( "file" -- ) + name required ; + \ RECURSE 17may93jaw : recurse ( -- ) @@ -1385,13 +1455,14 @@ 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 argc @ 1 @@ -1409,6 +1480,7 @@ Defer 'cold ' noop IS 'cold : cold ( -- ) pathstring 2@ process-path pathdirs 2! + 0 0 included-files 2! 'cold argc @ 1 > IF