1: \ Hashed dictionaries 15jul94py
2:
3: \ Copyright (C) 1995,1998,2000 Free Software Foundation, Inc.
4:
5: \ This file is part of Gforth.
6:
7: \ Gforth is free software; you can redistribute it and/or
8: \ modify it under the terms of the GNU General Public License
9: \ as published by the Free Software Foundation; either version 2
10: \ of the License, or (at your option) any later version.
11:
12: \ This program is distributed in the hope that it will be useful,
13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: \ GNU General Public License for more details.
16:
17: \ You should have received a copy of the GNU General Public License
18: \ along with this program; if not, write to the Free Software
19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
20:
21: [IFUNDEF] erase
22: : erase ( addr len -- ) 0 fill ;
23: [THEN]
24:
25: [IFUNDEF] allocate
26: : reserve-mem here swap allot ;
27: \ move to a kernel/memory.fs
28: [ELSE]
29: : reserve-mem allocate throw ;
30: [THEN]
31:
32: [IFUNDEF] hashbits
33: 11 Value hashbits
34: [THEN]
35: 1 hashbits lshift Value Hashlen
36:
37: \ compute hash key 15jul94py
38:
39: has? ec [IF] [IFUNDEF] hash
40: : hash ( addr len -- key )
41: over c@ swap 1- IF swap char+ c@ + ELSE nip THEN
42: [ Hashlen 1- ] literal and ;
43: [THEN] [THEN]
44:
45: [IFUNDEF] hash
46: : hash ( addr len -- key )
47: hashbits (hashkey1) ;
48: [THEN]
49:
50: Variable insRule insRule on
51: Variable revealed
52:
53: \ Memory handling 10oct94py
54:
55: AVariable HashPointer
56: Variable HashIndex
57: 0 AValue HashTable
58:
59: \ forward declarations
60: 0 AValue hashsearch-map
61: Defer hash-alloc ( addr -- addr )
62:
63: \ DelFix and NewFix are from bigFORTH 15jul94py
64:
65: : DelFix ( addr root -- ) dup @ 2 pick ! ! ;
66: : NewFix ( root len # -- addr )
67: BEGIN 2 pick @ ?dup 0= WHILE 2dup * reserve-mem
68: over 0 ?DO dup 4 pick DelFix 2 pick + LOOP drop
69: REPEAT >r drop r@ @ rot ! r@ swap erase r> ;
70:
71: : bucket ( addr len wordlist -- bucket-addr )
72: \ @var{bucket-addr} is the address of a cell that points to the first
73: \ element in the list of the bucket for the string @var{addr len}
74: wordlist-extend @ -rot hash xor ( bucket# )
75: cells HashTable + ;
76:
77: : hash-find ( addr len wordlist -- nfa / false )
78: >r 2dup r> bucket @ (hashlfind) ;
79:
80: \ hash vocabularies 16jul94py
81:
82: : lastlink! ( addr link -- )
83: BEGIN dup @ dup WHILE nip REPEAT drop ! ;
84:
85: : (reveal ( nfa wid -- )
86: over name>string rot bucket >r
87: HashPointer 2 Cells $400 NewFix
88: tuck cell+ ! r> insRule @
89: IF
90: dup @ 2 pick ! !
91: ELSE
92: lastlink!
93: THEN
94: revealed on ;
95:
96: : hash-reveal ( nfa wid -- )
97: 2dup (reveal) (reveal ;
98:
99: : inithash ( wid -- )
100: wordlist-extend
101: insRule @ >r insRule off hash-alloc 3 cells -
102: dup wordlist-id
103: BEGIN @ dup WHILE 2dup swap (reveal REPEAT
104: 2drop r> insRule ! ;
105:
106: : addall ( -- )
107: voclink
108: BEGIN @ dup WHILE
109: dup 0 wordlist-link -
110: dup wordlist-map @ reveal-method @ ['] hash-reveal =
111: IF inithash ELSE drop THEN
112: REPEAT drop ;
113:
114: : clearhash ( -- )
115: HashTable Hashlen cells bounds
116: DO I @
117: BEGIN dup WHILE
118: dup @ swap HashPointer DelFix
119: REPEAT
120: I !
121: cell +LOOP
122: HashIndex off
123: voclink
124: BEGIN ( wordlist-link-addr )
125: @ dup
126: WHILE ( wordlist-link )
127: dup 0 wordlist-link - ( wordlist-link wid )
128: dup wordlist-map @ hashsearch-map =
129: IF ( wordlist-link wid )
130: 0 swap wordlist-extend !
131: ELSE
132: drop
133: THEN
134: REPEAT
135: drop ;
136:
137: : rehashall ( wid -- )
138: drop revealed @
139: IF clearhash addall revealed off
140: THEN ;
141:
142: : (rehash) ( wid -- )
143: dup wordlist-extend @ 0=
144: IF inithash
145: ELSE rehashall THEN ;
146:
147: const Create (hashsearch-map)
148: ' hash-find A, ' hash-reveal A, ' (rehash) A, ' (rehash) A,
149: (hashsearch-map) to hashsearch-map
150:
151: \ hash allocate and vocabulary initialization 10oct94py
152:
153: :noname ( addr -- addr )
154: HashTable 0=
155: IF Hashlen cells reserve-mem TO HashTable
156: HashTable Hashlen cells erase THEN
157: HashIndex @ over ! 1 HashIndex +!
158: HashIndex @ Hashlen >=
159: [ [IFUNDEF] allocate ]
160: ABORT" no more space in hashtable"
161: [ [ELSE] ]
162: IF HashTable >r clearhash
163: 1 hashbits 1+ dup to hashbits lshift to hashlen
164: r> free >r 0 to HashTable
165: addall r> throw
166: THEN
167: [ [THEN] ] ; is hash-alloc
168:
169: \ Hash-Find 01jan93py
170: has? cross 0=
171: [IF]
172: : make-hash
173: hashsearch-map forth-wordlist wordlist-map !
174: addall ;
175: make-hash \ Baumsuche ist installiert.
176: [ELSE]
177: hashsearch-map forth-wordlist wordlist-map !
178: [THEN]
179:
180: \ for ec version display that vocabulary goes hashed
181:
182: : hash-cold ( -- )
183: [ has? ec [IF] ] ." Hashing..." [ [THEN] ]
184: HashPointer off 0 TO HashTable HashIndex off
185: addall
186: \ voclink
187: \ BEGIN @ dup WHILE
188: \ dup 0 wordlist-link - initvoc
189: \ REPEAT drop
190: [ has? ec [IF] ] ." Done" cr [ [THEN] ] ;
191:
192: ' hash-cold INIT8 chained
193:
194: : .words ( -- )
195: base @ >r hex HashTable Hashlen 0
196: DO cr i 2 .r ." : " dup i cells +
197: BEGIN @ dup WHILE
198: dup cell+ @ name>string type space REPEAT drop
199: LOOP drop r> base ! ;
200:
201: \ \ this stuff is for evaluating the hash function
202: \ : square dup * ;
203:
204: \ : countwl ( -- sum sumsq )
205: \ \ gives the number of words in the current wordlist
206: \ \ and the sum of squares for the sublist lengths
207: \ 0 0
208: \ hashtable Hashlen cells bounds DO
209: \ 0 i BEGIN
210: \ @ dup WHILE
211: \ swap 1+ swap
212: \ REPEAT
213: \ drop
214: \ swap over square +
215: \ >r + r>
216: \ 1 cells
217: \ +LOOP ;
218:
219: \ : chisq ( -- n )
220: \ \ n should have about the same size as Hashlen
221: \ countwl Hashlen 2 pick */ swap - ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>