1: \ search order wordset 14may93py
2:
3: $10 constant maxvp
4: Variable vp
5: 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A,
6: 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A,
7:
8: : get-current ( -- wid ) current @ ;
9: : set-current ( wid -- ) current ! ;
10:
11: : context ( -- addr ) vp dup @ cells + ;
12: : definitions ( -- ) context @ current ! ;
13:
14: \ hash search 29may94py
15:
16: \ uses a direct hash mapped cache --- idea from Heinz Schnitter
17:
18: \ : hashkey ( addr count -- key )
19: \ swap c@ toupper 3 * + $3F and ; \ gives a simple hash key
20:
21: \ Variable hits
22: \ Variable fails
23:
24: \ : hash-find ( addr count wid -- nfa / false )
25: \ >r 2dup hashkey
26: \ cells r@ 3 cells + @ + \ hashed addr
27: \ dup @
28: \ IF >r r@ @ cell+ c@ over =
29: \ IF 2dup r@ @ cell+ char+ capscomp 0=
30: \ IF 2drop r> @ rdrop 1 hits +! EXIT THEN THEN
31: \ r>
32: \ THEN r> swap >r @ (f83casefind) dup
33: \ IF dup r@ ! THEN rdrop 1 fails +! ;
34:
35: \ : hash-reveal ( -- )
36: \ last?
37: \ IF dup cell+ count hashkey cells
38: \ current @ 3 cells + @ + !
39: \ (reveal)
40: \ THEN ;
41:
42: \ : clear-hash ( wid -- ) 3 cells + @ $40 cells erase ;
43:
44: \ Create hashsearch
45: \ ' hash-find A, ' hash-reveal A, ' clear-hash A,
46:
47: \ for testing
48:
49: \ : .hash ( wid -- ) 3 cells + @ ?dup 0= ?EXIT cr
50: \ 8 0 DO
51: \ 8 0 DO dup I J 8 * + cells + @ dup
52: \ IF cell+ count $1F and tuck 10 min type
53: \ 10 swap - spaces
54: \ ELSE drop 10 spaces THEN
55: \ LOOP
56: \ LOOP drop ;
57:
58: \ wordlist Vocabulary also previous 14may93py
59:
60: AVariable voclink
61:
62: : wordlist ( -- wid )
63: here 0 A, f83search ( hashsearch ) A, voclink @ A,
64: ( here cell+ ) 0 A, \ here $40 cells dup allot erase
65: dup 2 cells + voclink ! ;
66:
67: : Vocabulary ( -- ) Create wordlist drop DOES> context ! ;
68:
69: : also ( -- )
70: context @ vp @ 1+ dup maxvp > abort" Vocstack full"
71: vp ! context ! ;
72:
73: : previous ( -- ) vp @ 1- dup 0= abort" Vocstack empty" vp ! ;
74:
75: \ vocabulary find 14may93py
76:
77: : (vocfind) ( addr count wid -- nfa2|false )
78: \ !! generalize this to be independent of vp
79: drop 1 vp @
80: DO 2dup vp I cells + @ (search-wordlist) dup
81: IF nip nip
82: UNLOOP EXIT
83: THEN drop
84: -1 +LOOP
85: 2drop false ;
86:
87: 0 value locals-wordlist
88:
89: : (localsvocfind) ( addr count wid -- nfa2|false )
90: \ !! use generalized (vocfind)
91: drop locals-wordlist
92: IF 2dup locals-wordlist (search-wordlist) dup
93: IF nip nip
94: EXIT
95: THEN drop
96: THEN
97: 0 (vocfind) ;
98:
99: \ In the kernal the dictionary search works on only one wordlist.
100: \ The following stuff builds a thing that looks to the kernal like one
101: \ wordlist, but when searched it searches the whole search order
102: \ (including locals)
103:
104: \ this is the wordlist-map of the dictionary
105: Create vocsearch
106: ' (localsvocfind) A, ' (reveal) A, ' drop A,
107:
108: \ Only root 14may93py
109:
110: wordlist \ the wordlist structure
111: vocsearch over cell+ A! \ patch the map into it
112:
113: Vocabulary Forth
114: Vocabulary Root
115:
116: : Only vp off also Root also definitions ;
117:
118: \ set initial search order 14may93py
119:
120: Forth-wordlist @ ' Forth >body A!
121:
122: Only Forth also definitions
123:
124: search A! \ our dictionary search order becomes the law
125:
126: ' Forth >body AConstant Forth-wordlist
127:
128: \ get-order set-order 14may93py
129:
130: : get-order ( -- wid1 .. widn n )
131: vp @ 0 ?DO vp cell+ I cells + @ LOOP vp @ ;
132:
133: : set-order ( wid1 .. widn n / -1 -- )
134: dup -1 = IF drop Only exit THEN dup vp !
135: ?dup IF 1- FOR vp cell+ I cells + ! NEXT THEN ;
136:
137: : seal ( -- ) context @ 1 set-order ;
138:
139: \ words visible in roots 14may93py
140:
141: : .name ( name -- ) name>string type space ;
142: : words cr 0 context @
143: BEGIN @ dup WHILE 2dup cell+ c@ $1F and 2 + dup >r +
144: &79 > IF cr nip 0 swap THEN
145: dup .name space r> rot + swap REPEAT 2drop ;
146:
147: : body> ( data -- cfa ) 0 >body - ;
148:
149: : .voc body> >name .name ;
150: : order 1 vp @ DO vp I cells + @ .voc -1 +LOOP 2 spaces
151: current @ .voc ;
152: : vocs voclink BEGIN @ dup @ WHILE dup 2 cells - .voc REPEAT drop ;
153:
154: Root definitions
155:
156: ' words Alias words
157: ' Forth Alias Forth
158:
159: Forth definitions
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>