File:
[gforth] /
gforth /
hash.fs
Revision
1.22:
download - view:
text,
annotated -
select for diffs
Tue Dec 8 22:02:45 1998 UTC (25 years, 3 months ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
updated dates in copyright messages
inserted copyright messages in most files that did not have them
removed outdated files engine/32bit.h engine/strsig.c
1: \ Hashed dictionaries 15jul94py
2:
3: \ Copyright (C) 1995,1998 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., 675 Mass Ave, Cambridge, MA 02139, USA.
20:
21: [IFUNDEF] allocate
22: : reserve-mem here swap allot ;
23: \ move to a kernel/memory.fs
24: [ELSE]
25: : reserve-mem allocate throw ;
26: [THEN]
27:
28: [IFUNDEF] hashbits
29: 11 Value hashbits
30: [THEN]
31: 1 hashbits lshift Value Hashlen
32:
33: \ compute hash key 15jul94py
34:
35: [IFUNDEF] hash
36: : hash ( addr len -- key )
37: hashbits (hashkey1) ;
38: [THEN]
39:
40: Variable insRule insRule on
41: Variable revealed
42:
43: \ Memory handling 10oct94py
44:
45: Variable HashPointer
46: Variable HashIndex
47: 0 Value HashTable
48:
49: \ forward declarations
50: 0 Value hashsearch-map
51: Defer hash-alloc
52:
53: \ DelFix and NewFix are from bigFORTH 15jul94py
54:
55: : DelFix ( addr root -- ) dup @ 2 pick ! ! ;
56: : NewFix ( root len # -- addr )
57: BEGIN 2 pick @ ?dup 0= WHILE 2dup * reserve-mem
58: over 0 ?DO dup 4 pick DelFix 2 pick + LOOP drop
59: REPEAT >r drop r@ @ rot ! r@ swap erase r> ;
60:
61: : bucket ( addr len wordlist -- bucket-addr )
62: \ @var{bucket-addr} is the address of a cell that points to the first
63: \ element in the list of the bucket for the string @var{addr len}
64: wordlist-extend @ -rot hash xor ( bucket# )
65: cells HashTable + ;
66:
67: : hash-find ( addr len wordlist -- nfa / false )
68: >r 2dup r> bucket @ (hashfind) ;
69:
70: \ hash vocabularies 16jul94py
71:
72: : lastlink! ( addr link -- )
73: BEGIN dup @ dup WHILE nip REPEAT drop ! ;
74:
75: : (reveal ( nfa wid -- )
76: over name>string rot bucket >r
77: HashPointer 2 Cells $400 NewFix
78: tuck cell+ ! r> insRule @
79: IF
80: dup @ 2 pick ! !
81: ELSE
82: lastlink!
83: THEN
84: revealed on ;
85:
86: : hash-reveal ( nfa wid -- )
87: 2dup (reveal) (reveal ;
88:
89: : inithash ( wid -- )
90: wordlist-extend
91: insRule @ >r insRule off hash-alloc 3 cells -
92: dup wordlist-id
93: BEGIN @ dup WHILE 2dup swap (reveal REPEAT
94: 2drop r> insRule ! ;
95:
96: : addall ( -- )
97: voclink
98: BEGIN @ dup WHILE
99: dup 0 wordlist-link -
100: dup wordlist-map @ hashsearch-map =
101: IF inithash ELSE drop THEN
102: REPEAT drop ;
103:
104: : clearhash ( -- )
105: HashTable Hashlen cells bounds
106: DO I @
107: BEGIN dup WHILE
108: dup @ swap HashPointer DelFix
109: REPEAT I !
110: cell +LOOP HashIndex off
111: voclink
112: BEGIN @ dup WHILE
113: dup 0 wordlist-link -
114: dup wordlist-map @ hashsearch-map =
115: IF 0 swap wordlist-extend ! ELSE drop THEN
116: REPEAT drop ;
117:
118: : rehashall ( wid -- )
119: drop revealed @
120: IF clearhash addall revealed off
121: THEN ;
122:
123: : (rehash) ( wid -- )
124: dup wordlist-extend @ 0=
125: IF inithash
126: ELSE rehashall THEN ;
127:
128: \ >rom ?!
129: align here ' hash-find A, ' hash-reveal A, ' (rehash) A, ' (rehash) A,
130: to hashsearch-map
131:
132: \ hash allocate and vocabulary initialization 10oct94py
133:
134: :noname ( hash-alloc ) ( addr -- addr )
135: HashTable 0=
136: IF Hashlen cells reserve-mem TO HashTable
137: HashTable Hashlen cells erase THEN
138: HashIndex @ over ! 1 HashIndex +!
139: HashIndex @ Hashlen >=
140: [ [IFUNDEF] allocate ]
141: ABORT" no more space in hashtable"
142: [ [ELSE] ]
143: IF HashTable >r clearhash
144: 1 hashbits 1+ dup to hashbits lshift to hashlen
145: r> free >r 0 to HashTable
146: addall r> throw
147: THEN
148: [ [THEN] ] ; is hash-alloc
149:
150: \ Hash-Find 01jan93py
151: has? cross 0=
152: [IF]
153: : make-hash
154: hashsearch-map forth-wordlist wordlist-map !
155: addall ;
156: make-hash \ Baumsuche ist installiert.
157: [ELSE]
158: hashsearch-map forth-wordlist wordlist-map !
159: [THEN]
160:
161: \ for ec version display that vocabulary goes hashed
162:
163: : hash-cold ( -- )
164: [ has? ec [IF] ] ." Hashing..." [ [THEN] ]
165: HashPointer off 0 TO HashTable HashIndex off
166: addall
167: \ voclink
168: \ BEGIN @ dup WHILE
169: \ dup 0 wordlist-link - initvoc
170: \ REPEAT drop
171: [ has? ec [IF] ] ." Done" cr [ [THEN] ] ;
172:
173: ' hash-cold INIT8 chained
174:
175: : .words ( -- )
176: base @ >r hex HashTable Hashlen 0
177: DO cr i 2 .r ." : " dup i cells +
178: BEGIN @ dup WHILE
179: dup cell+ @ name>string type space REPEAT drop
180: LOOP drop r> base ! ;
181:
182: \ \ this stuff is for evaluating the hash function
183: \ : square dup * ;
184:
185: \ : countwl ( -- sum sumsq )
186: \ \ gives the number of words in the current wordlist
187: \ \ and the sum of squares for the sublist lengths
188: \ 0 0
189: \ hashtable Hashlen cells bounds DO
190: \ 0 i BEGIN
191: \ @ dup WHILE
192: \ swap 1+ swap
193: \ REPEAT
194: \ drop
195: \ swap over square +
196: \ >r + r>
197: \ 1 cells
198: \ +LOOP ;
199:
200: \ : chisq ( -- n )
201: \ \ n should have about the same size as Hashlen
202: \ countwl Hashlen 2 pick */ swap - ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>