--- gforth/Attic/kernal.fs 1995/01/30 18:47:52 1.27 +++ gforth/Attic/kernal.fs 1995/03/14 19:01:43 1.33 @@ -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 @@ -1430,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 @@ -1454,6 +1480,7 @@ Defer 'cold ' noop IS 'cold : cold ( -- ) pathstring 2@ process-path pathdirs 2! + 0 0 included-files 2! 'cold argc @ 1 > IF