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: \ wordlist Vocabulary also previous 14may93py
15:
16: AVariable voclink
17:
18: : wordlist ( -- wid )
19: here 0 A, Forth-wordlist cell+ @ A, voclink @ A, 0 A,
20: dup 2 cells + voclink ! ;
21:
22: : Vocabulary ( -- ) Create wordlist drop DOES> context ! ;
23:
24: : also ( -- )
25: context @ vp @ 1+ dup maxvp > abort" Vocstack full"
26: vp ! context ! ;
27:
28: : previous ( -- ) vp @ 1- dup 0= abort" Vocstack empty" vp ! ;
29:
30: \ vocabulary find 14may93py
31:
32: : (vocfind) ( addr count nfa1 -- nfa2|false )
33: \ !! generalize this to be independent of vp
34: drop 1 vp @
35: DO 2dup vp I cells + @ (search-wordlist) dup
36: IF nip nip
37: UNLOOP EXIT
38: THEN drop
39: -1 +LOOP
40: 2drop false ;
41:
42: 0 value locals-wordlist
43:
44: : (localsvocfind) ( addr count nfa1 -- nfa2|false )
45: \ !! use generalized (vocfind)
46: drop locals-wordlist
47: IF 2dup locals-wordlist (search-wordlist) dup
48: IF nip nip
49: EXIT
50: THEN drop
51: THEN
52: 0 (vocfind) ;
53:
54: \ In the kernal the dictionary search works on only one wordlist.
55: \ The following stuff builds a thing that looks to the kernal like one
56: \ wordlist, but when searched it searches the whole search order
57: \ (including locals)
58:
59: \ this is the wordlist-map of the dictionary
60: Create vocsearch ' (localsvocfind) A, ' (reveal) A,
61:
62: \ Only root 14may93py
63:
64: wordlist \ the wordlist structure
65: vocsearch over cell+ A! \ patch the map into it
66:
67: Vocabulary Forth
68: Vocabulary Root
69:
70: : Only vp off also Root also definitions ;
71:
72: \ set initial search order 14may93py
73:
74: Forth-wordlist @ ' Forth >body A!
75:
76: Only Forth also definitions
77:
78: search A! \ our dictionary search order becomes the law
79:
80: \ get-order set-order 14may93py
81:
82: : get-order ( -- wid1 .. widn n )
83: vp @ 0 ?DO vp cell+ I cells + @ LOOP vp @ ;
84:
85: : set-order ( wid1 .. widn n / -1 -- )
86: dup -1 = IF drop Only exit THEN dup vp !
87: ?dup IF 1- FOR vp cell+ I cells + ! NEXT THEN ;
88:
89: : seal ( -- ) context @ 1 set-order ;
90:
91: \ words visible in roots 14may93py
92:
93: : .name ( name -- ) name>string type space ;
94: : words cr 0 context @
95: BEGIN @ dup WHILE 2dup cell+ c@ $1F and 2 + dup >r +
96: &79 > IF cr nip 0 swap THEN
97: dup .name space r> rot + swap REPEAT 2drop ;
98:
99: : body> ( data -- cfa ) 0 >body - ;
100:
101: : .voc body> >name .name ;
102: : order 1 vp @ DO vp I cells + @ .voc -1 +LOOP 2 spaces
103: current @ .voc ;
104: : vocs voclink BEGIN @ dup @ WHILE dup 2 cells - .voc REPEAT drop ;
105:
106: Root definitions
107:
108: ' words Alias words
109: ' Forth Alias Forth
110:
111: Forth definitions
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>