--- gforth/Attic/kernal.fs 1994/11/11 16:10:12 1.23 +++ gforth/Attic/kernal.fs 1995/04/20 09:42:55 1.35 @@ -1,4 +1,4 @@ -\ KERNAL.FS ANS figFORTH kernal 17dec92py +\ KERNAL.FS GNU FORTH kernal 17dec92py \ $ID: \ Idea and implementation: Bernd Paysan (py) \ Copyright 1992 by the ANSI figForth Development Group @@ -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 ; @@ -358,7 +375,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 +710,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 +787,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 +837,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 +862,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 +894,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 +940,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 +1003,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 +1028,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 +1062,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 @@ -1136,7 +1175,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 @@ -1197,15 +1236,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 +1303,9 @@ create pathfilenamebuf 256 chars allot \ : include ( "file" -- ) name included ; +: require ( "file" -- ) + name required ; + \ RECURSE 17may93jaw : recurse ( -- ) @@ -1385,27 +1469,36 @@ Variable argc 2drop here r> tuck - 2 cells / ; -: ">tib ( addr len -- ) dup #tib ! >in off tib swap move ; - -: do-option ( addr1 len1 addr2 len2 -- n ) 2swap - 2dup s" -e" compare 0= >r - 2dup s" -evaluate" compare 0= r> or - IF 2drop ">tib interpret 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 + true to script? 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 THEN - +LOOP ; + +LOOP + false to script? + r> >tib ! ; + +Defer 'cold ' noop IS 'cold : cold ( -- ) pathstring 2@ process-path pathdirs 2! + 0 0 included-files 2! + 'cold argc @ 1 > IF ['] process-args catch ?dup @@ -1417,7 +1510,7 @@ Variable argc ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr ." Type `bye' to exit" - quit ; + loadline off quit ; : license ( -- ) cr ." This program is free software; you can redistribute it and/or modify" cr @@ -1436,7 +1529,8 @@ Variable argc : boot ( path **argv argc -- ) argc ! argv ! cstring>sstring pathstring 2! main-task up! - sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ; + sp@ dup s0 ! $10 + >tib ! #tib off >in off + rp@ r0 ! fp@ f0 ! cold ; : bye script? 0= IF cr THEN 0 (bye) ;