version 1.28, 1995/02/06 18:14:34
|
version 1.34, 1995/04/14 18:56:55
|
Line 704 Avariable leave-sp leave-stack 3 cells
|
Line 704 Avariable leave-sp leave-stack 3 cells
|
cell - dup @ swap |
cell - dup @ swap |
leave-sp ! ; |
leave-sp ! ; |
|
|
: DONE ( orig -- ) drop >r drop |
: DONE ( orig -- ) |
\ !! the original done had ( addr -- ) |
\ !! the original done had ( addr -- ) |
|
drop >r drop |
begin |
begin |
leave> |
leave> |
over r@ u>= |
over r@ u>= |
Line 785 Avariable leave-sp leave-stack 3 cells
|
Line 786 Avariable leave-sp leave-stack 3 cells
|
: ." state @ IF postpone (.") ," align |
: ." state @ IF postpone (.") ," align |
ELSE [char] " parse type THEN ; immediate |
ELSE [char] " parse type THEN ; immediate |
: ( [char] ) parse 2drop ; immediate |
: ( [char] ) parse 2drop ; immediate |
: \ blk @ IF >in @ c/l / 1+ c/l * >in ! EXIT THEN |
: \ ( -- ) \ core-ext backslash |
source >in ! drop ; immediate |
blk @ |
|
IF |
|
>in @ c/l / 1+ c/l * >in ! |
|
EXIT |
|
THEN |
|
source >in ! drop ; immediate |
|
|
|
: \G ( -- ) \ new backslash |
|
POSTPONE \ ; immediate |
|
|
\ error handling 22feb93py |
\ error handling 22feb93py |
\ 'abort thrown out! 11may93jaw |
\ 'abort thrown out! 11may93jaw |
Line 917 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 926 Create ??? 0 , 3 c, char ? c, char ? c,
|
: Constant (Constant) , ; |
: Constant (Constant) , ; |
: AConstant (Constant) A, ; |
: AConstant (Constant) A, ; |
|
|
: 2CONSTANT |
: 2Constant |
create ( w1 w2 "name" -- ) |
Create ( w1 w2 "name" -- ) |
2, |
2, |
does> ( -- w1 w2 ) |
DOES> ( -- w1 w2 ) |
2@ ; |
2@ ; |
|
|
\ IS Defer What's Defers TO 24feb93py |
\ IS Defer What's Defers TO 24feb93py |
Line 980 AVariable current
|
Line 989 AVariable current
|
\ object oriented search list 17mar93py |
\ object oriented search list 17mar93py |
|
|
\ word list structure: |
\ word list structure: |
\ struct |
|
\ 1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) |
struct |
\ 1 cells: field reveal-method \ xt: ( -- ) |
1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) |
\ 1 cells: field rehash-method \ xt: ( wid -- ) |
1 cells: field reveal-method \ xt: ( -- ) |
|
1 cells: field rehash-method \ xt: ( wid -- ) |
\ \ !! what else |
\ \ !! what else |
\ end-struct wordlist-map-struct |
end-struct wordlist-map-struct |
|
|
\ struct |
struct |
\ 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation |
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-map \ pointer to a wordlist-map-struct |
\ 1 cells: field wordlist-link \ link field to other wordlists |
1 cells: field wordlist-link \ link field to other wordlists |
\ 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) |
1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) |
\ end-struct wordlist-struct |
end-struct wordlist-struct |
|
|
: f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; |
: f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; |
|
|
Line 1004 AVariable lookup G forth-wordlist
|
Line 1014 AVariable lookup G forth-wordlist
|
G forth-wordlist current T ! |
G forth-wordlist current T ! |
|
|
: (search-wordlist) ( addr count wid -- nfa / false ) |
: (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 ( addr count wid -- 0 / xt +-1 ) |
(search-wordlist) dup IF found THEN ; |
(search-wordlist) dup IF found THEN ; |
Line 1038 Variable warnings G -1 warnings T !
|
Line 1048 Variable warnings G -1 warnings T !
|
last? if |
last? if |
name>string current @ check-shadow |
name>string current @ check-shadow |
then |
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 ) name sfind 0= if -&13 bounce then ; |
: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate |
: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate |
Line 1445 Variable argc
|
Line 1455 Variable argc
|
2drop |
2drop |
here r> tuck - 2 cells / ; |
here r> tuck - 2 cells / ; |
|
|
: do-option ( addr1 len1 addr2 len2 -- n ) 2swap |
: do-option ( addr1 len1 addr2 len2 -- n ) |
2dup s" -e" compare 0= >r |
2swap |
2dup s" -evaluate" compare 0= r> or |
2dup s" -e" compare 0= >r |
IF 2drop dup >r ['] evaluate catch |
2dup s" --evaluate" compare 0= r> or |
?dup IF dup >r DoError r> negate (bye) THEN |
IF 2drop dup >r ['] evaluate catch |
r> >tib +! 2 EXIT THEN |
?dup IF dup >r DoError r> negate (bye) THEN |
." Unknown option: " type cr 2drop 1 ; |
r> >tib +! 2 EXIT THEN |
|
." Unknown option: " type cr 2drop 1 ; |
: process-args ( -- ) >tib @ >r |
|
|
: process-args ( -- ) |
|
>tib @ >r |
|
true to script? |
argc @ 1 |
argc @ 1 |
?DO |
?DO |
I arg over c@ [char] - <> |
I arg over c@ [char] - <> |
IF |
IF |
true to script? included false to script? 1 |
included 1 |
ELSE |
ELSE |
I 1+ arg do-option |
I 1+ arg do-option |
THEN |
THEN |
+LOOP |
+LOOP |
|
false to script? |
r> >tib ! ; |
r> >tib ! ; |
|
|
Defer 'cold ' noop IS 'cold |
Defer 'cold ' noop IS 'cold |
|
|
: cold ( -- ) |
: cold ( -- ) |
pathstring 2@ process-path pathdirs 2! |
pathstring 2@ process-path pathdirs 2! |
|
0 0 included-files 2! |
'cold |
'cold |
argc @ 1 > |
argc @ 1 > |
IF |
IF |