version 1.58, 1996/05/09 18:13:02
|
version 1.59, 1996/05/13 16:37:00
|
Line 145 HEX
|
Line 145 HEX
|
|
|
\ name> found 17dec92py |
\ name> found 17dec92py |
|
|
|
$80 constant alias-mask \ set when the word is not an alias! |
|
$40 constant immediate-mask |
|
$20 constant restrict-mask |
|
|
: (name>) ( nfa+cell -- cfa ) |
: (name>) ( nfa+cell -- cfa ) |
1 cells - name>string + cfaligned ; |
1 cells - name>string + cfaligned ; |
: name> ( nfa -- cfa ) \ gforth |
: name> ( nfa -- cfa ) \ gforth |
cell+ |
cell+ |
dup (name>) swap c@ $80 and 0= IF @ THEN ; |
dup (name>) swap c@ alias-mask and 0= IF @ THEN ; |
|
|
: found ( nfa -- cfa n ) \ gforth |
: found ( nfa -- cfa n ) \ gforth |
cell+ |
cell+ |
dup c@ >r (name>) r@ $80 and 0= IF @ THEN |
dup c@ >r (name>) r@ alias-mask and 0= IF @ THEN |
-1 r@ $40 and IF 1- THEN |
-1 r@ restrict-mask and IF 1- THEN |
r> $20 and IF negate THEN ; |
r> immediate-mask and IF negate THEN ; |
|
|
\ (find) 17dec92py |
\ (find) 17dec92py |
|
|
Line 484 Defer parser
|
Line 488 Defer parser
|
Defer name ( -- c-addr count ) \ gforth |
Defer name ( -- c-addr count ) \ gforth |
\ get the next word from the input buffer |
\ get the next word from the input buffer |
' (name) IS name |
' (name) IS name |
Defer notfound ( c-addr count -- ) |
Defer compiler-notfound ( c-addr count -- ) |
|
Defer interpreter-notfound ( c-addr count -- ) |
|
|
: no.extensions ( addr u -- ) |
: no.extensions ( addr u -- ) |
2drop -&13 bounce ; |
2drop -&13 bounce ; |
' no.extensions IS notfound |
' no.extensions IS compiler-notfound |
|
' no.extensions IS interpreter-notfound |
|
|
: compile-only ( ... -- ) |
: compile-only ( ... -- ) |
-&14 throw ; |
-&14 throw ; |
Line 521 Defer interpret-special ( c-addr u xt --
|
Line 527 Defer interpret-special ( c-addr u xt --
|
IF |
IF |
2rdrop |
2rdrop |
ELSE |
ELSE |
2r> notfound |
2r> interpreter-notfound |
THEN ; |
THEN ; |
|
|
' interpreter IS parser |
' interpreter IS parser |
Line 546 Defer interpret-special ( c-addr u xt --
|
Line 552 Defer interpret-special ( c-addr u xt --
|
postpone Literal |
postpone Literal |
2drop |
2drop |
ELSE |
ELSE |
drop notfound |
drop compiler-notfound |
THEN ; |
THEN ; |
|
|
: [ ( -- ) \ core left-bracket |
: [ ( -- ) \ core left-bracket |
Line 1000 create s"-buffer /line chars allot
|
Line 1006 create s"-buffer /line chars allot
|
\ aborts if the last defined word was headerless |
\ aborts if the last defined word was headerless |
last @ dup 0= abort" last word was headerless" cell+ ; |
last @ dup 0= abort" last word was headerless" cell+ ; |
|
|
: immediate $20 lastflags cset ; |
: immediate immediate-mask lastflags cset ; |
: restrict $40 lastflags cset ; |
: restrict restrict-mask lastflags cset ; |
|
|
\ Header 23feb93py |
\ Header 23feb93py |
|
|
Line 1017 defer header ( -- ) \ gforth
|
Line 1023 defer header ( -- ) \ gforth
|
\ puts down string as cstring |
\ puts down string as cstring |
dup c, here swap chars dup allot move ; |
dup c, here swap chars dup allot move ; |
|
|
: name, ( "name" -- ) \ gforth |
: header, ( c-addr u -- ) \ gforth |
name name-too-short? name-too-long? |
name-too-long? |
string, cfalign ; |
align here last ! |
: input-stream-header ( "name" -- ) |
current @ 1 or A, \ link field; before revealing, it contains the |
\ !! this is f83-implementation-dependent |
\ tagged reveal-into wordlist |
align here last ! -1 A, |
string, cfalign |
name, $80 lastflags cset ; |
alias-mask lastflags cset ; |
|
|
|
: input-stream-header ( "name" -- ) |
|
name name-too-short? header, ; |
: input-stream ( -- ) \ general |
: input-stream ( -- ) \ general |
\ switches back to getting the name from the input stream ; |
\ switches back to getting the name from the input stream ; |
['] input-stream-header IS (header) ; |
['] input-stream-header IS (header) ; |
Line 1035 defer header ( -- ) \ gforth
|
Line 1043 defer header ( -- ) \ gforth
|
create nextname-buffer 32 chars allot |
create nextname-buffer 32 chars allot |
|
|
: nextname-header ( -- ) |
: nextname-header ( -- ) |
\ !! f83-implementation-dependent |
nextname-buffer count header, |
nextname-buffer count |
|
align here last ! -1 A, |
|
string, cfalign |
|
$80 lastflags cset |
|
input-stream ; |
input-stream ; |
|
|
\ the next name is given in the string |
\ the next name is given in the string |
Line 1063 create nextname-buffer 32 chars allot
|
Line 1067 create nextname-buffer 32 chars allot
|
|
|
: Alias ( cfa "name" -- ) \ gforth |
: Alias ( cfa "name" -- ) \ gforth |
Header reveal |
Header reveal |
$80 lastflags creset |
alias-mask lastflags creset |
dup A, lastcfa ! ; |
dup A, lastcfa ! ; |
|
|
: name>string ( nfa -- addr count ) \ gforth name-to-string |
: name>string ( nfa -- addr count ) \ gforth name-to-string |
Line 1072 create nextname-buffer 32 chars allot
|
Line 1076 create nextname-buffer 32 chars allot
|
Create ??? 0 , 3 c, char ? c, char ? c, char ? c, |
Create ??? 0 , 3 c, char ? c, char ? c, char ? c, |
: >name ( cfa -- nfa ) \ gforth to-name |
: >name ( cfa -- nfa ) \ gforth to-name |
$21 cell do |
$21 cell do |
dup i - count $9F and + cfaligned over $80 + = if |
dup i - count $9F and + cfaligned over alias-mask + = if |
i - cell - unloop exit |
i - cell - unloop exit |
then |
then |
cell +loop |
cell +loop |
Line 1170 AVariable current ( -- addr ) \ gforth
|
Line 1174 AVariable current ( -- addr ) \ gforth
|
|
|
: last? ( -- false / nfa nfa ) |
: last? ( -- false / nfa nfa ) |
last @ ?dup ; |
last @ ?dup ; |
: (reveal) ( -- ) |
: (reveal) ( nfa wid -- ) |
last? |
( wid>wordlist-id ) dup >r |
IF |
@ over ( name>link ) ! |
dup @ 0< |
r> ! ; |
IF |
|
current @ @ over ! current @ ! |
|
ELSE |
|
drop |
|
THEN |
|
THEN ; |
|
|
|
\ object oriented search list 17mar93py |
\ object oriented search list 17mar93py |
|
|
Line 1187 AVariable current ( -- addr ) \ gforth
|
Line 1185 AVariable current ( -- addr ) \ gforth
|
|
|
struct |
struct |
1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) |
1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) |
1 cells: field reveal-method \ xt: ( -- ) \ used by dofield:, must be field |
1 cells: field reveal-method \ xt: ( nfa wid -- ) \ used by dofield:, must be field |
1 cells: field rehash-method \ xt: ( wid -- ) |
1 cells: field rehash-method \ xt: ( wid -- ) |
\ \ !! what else |
\ \ !! what else |
end-struct wordlist-map-struct |
end-struct wordlist-map-struct |
Line 1199 struct
|
Line 1197 struct
|
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 ) |
|
( wid>wordlist-id ) @ (f83find) ; |
|
|
\ Search list table: find reveal |
\ Search list table: find reveal |
Create f83search ' f83find A, ' (reveal) A, ' drop A, |
Create f83search ( -- wordlist-map ) |
|
' f83find A, ' (reveal) A, ' drop A, |
|
|
Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A, |
Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A, |
AVariable lookup G forth-wordlist lookup T ! |
AVariable lookup G forth-wordlist lookup T ! |
Line 1244 G -1 warnings T !
|
Line 1244 G -1 warnings T !
|
then ; |
then ; |
|
|
: reveal ( -- ) \ gforth |
: reveal ( -- ) \ gforth |
last? if |
last? |
name>string current @ check-shadow |
if \ the last word has a header |
then |
dup ( name>link ) @ 1 and |
current @ wordlist-map @ reveal-method perform ; |
if \ it is still hidden |
|
dup ( name>link ) @ 1 xor ( nfa wid ) |
|
2dup >r name>string r> check-shadow ( nfa wid ) |
|
dup wordlist-map @ reveal-method perform |
|
then |
|
then ; |
|
|
: rehash ( wid -- ) |
: rehash ( wid -- ) |
dup wordlist-map @ rehash-method perform ; |
dup wordlist-map @ rehash-method perform ; |
Line 1572 create image-included-files 1 , A, ( po
|
Line 1577 create image-included-files 1 , A, ( po
|
|
|
: recurse ( compilation -- ; run-time ?? -- ?? ) \ core |
: recurse ( compilation -- ; run-time ?? -- ?? ) \ core |
lastxt compile, ; immediate restrict |
lastxt compile, ; immediate restrict |
: recursive ( -- ) \ gforth |
' reveal alias recursive ( -- ) \ gforth |
reveal last off ; immediate |
immediate |
|
|
\ */MOD */ 17may93jaw |
\ */MOD */ 17may93jaw |
|
|