Annotation of gforth/hash.fs, revision 1.35
1.1 pazsan 1: \ Hashed dictionaries 15jul94py
2:
1.35 ! anton 3: \ Copyright (C) 1995,1998,2000,2003,2006 Free Software Foundation, Inc.
1.10 anton 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
1.26 anton 19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
1.10 anton 20:
1.28 jwilke 21: [IFUNDEF] erase
22: : erase ( addr len -- ) 0 fill ;
23: [THEN]
24:
1.19 jwilke 25: [IFUNDEF] allocate
1.18 jwilke 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
1.19 jwilke 33: 11 Value hashbits
1.18 jwilke 34: [THEN]
1.2 anton 35: 1 hashbits lshift Value Hashlen
1.1 pazsan 36:
1.18 jwilke 37: \ compute hash key 15jul94py
38:
1.28 jwilke 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:
1.18 jwilke 45: [IFUNDEF] hash
46: : hash ( addr len -- key )
47: hashbits (hashkey1) ;
48: [THEN]
49:
1.1 pazsan 50: Variable insRule insRule on
1.4 pazsan 51: Variable revealed
1.1 pazsan 52:
1.4 pazsan 53: \ Memory handling 10oct94py
1.1 pazsan 54:
1.28 jwilke 55: AVariable HashPointer
1.29 pazsan 56: Variable HashIndex \ Number of wordlists
57: Variable HashPop \ Number of words
1.28 jwilke 58: 0 AValue HashTable
1.1 pazsan 59:
1.18 jwilke 60: \ forward declarations
1.28 jwilke 61: 0 AValue hashsearch-map
1.23 anton 62: Defer hash-alloc ( addr -- addr )
1.18 jwilke 63:
1.4 pazsan 64: \ DelFix and NewFix are from bigFORTH 15jul94py
1.1 pazsan 65:
66: : DelFix ( addr root -- ) dup @ 2 pick ! ! ;
67: : NewFix ( root len # -- addr )
1.18 jwilke 68: BEGIN 2 pick @ ?dup 0= WHILE 2dup * reserve-mem
1.1 pazsan 69: over 0 ?DO dup 4 pick DelFix 2 pick + LOOP drop
70: REPEAT >r drop r@ @ rot ! r@ swap erase r> ;
71:
1.12 anton 72: : bucket ( addr len wordlist -- bucket-addr )
73: \ @var{bucket-addr} is the address of a cell that points to the first
74: \ element in the list of the bucket for the string @var{addr len}
75: wordlist-extend @ -rot hash xor ( bucket# )
1.13 anton 76: cells HashTable + ;
1.2 anton 77:
78: : hash-find ( addr len wordlist -- nfa / false )
1.27 anton 79: >r 2dup r> bucket @ (hashlfind) ;
1.1 pazsan 80:
81: \ hash vocabularies 16jul94py
82:
83: : lastlink! ( addr link -- )
84: BEGIN dup @ dup WHILE nip REPEAT drop ! ;
85:
1.14 anton 86: : (reveal ( nfa wid -- )
1.12 anton 87: over name>string rot bucket >r
88: HashPointer 2 Cells $400 NewFix
89: tuck cell+ ! r> insRule @
90: IF
91: dup @ 2 pick ! !
92: ELSE
93: lastlink!
94: THEN
1.29 pazsan 95: revealed on 1 HashPop +! 0 hash-alloc drop ;
1.12 anton 96:
1.14 anton 97: : hash-reveal ( nfa wid -- )
98: 2dup (reveal) (reveal ;
1.1 pazsan 99:
1.18 jwilke 100: : inithash ( wid -- )
101: wordlist-extend
1.29 pazsan 102: insRule @ >r insRule off 1 hash-alloc over ! 3 cells -
1.21 pazsan 103: dup wordlist-id
1.18 jwilke 104: BEGIN @ dup WHILE 2dup swap (reveal REPEAT
105: 2drop r> insRule ! ;
106:
1.4 pazsan 107: : addall ( -- )
1.29 pazsan 108: HashPop off voclink
1.18 jwilke 109: BEGIN @ dup WHILE
110: dup 0 wordlist-link -
1.24 pazsan 111: dup wordlist-map @ reveal-method @ ['] hash-reveal =
1.18 jwilke 112: IF inithash ELSE drop THEN
113: REPEAT drop ;
1.4 pazsan 114:
115: : clearhash ( -- )
1.13 anton 116: HashTable Hashlen cells bounds
1.4 pazsan 117: DO I @
1.15 pazsan 118: BEGIN dup WHILE
1.23 anton 119: dup @ swap HashPointer DelFix
120: REPEAT
121: I !
122: cell +LOOP
123: HashIndex off
1.18 jwilke 124: voclink
1.23 anton 125: BEGIN ( wordlist-link-addr )
126: @ dup
127: WHILE ( wordlist-link )
128: dup 0 wordlist-link - ( wordlist-link wid )
129: dup wordlist-map @ hashsearch-map =
130: IF ( wordlist-link wid )
131: 0 swap wordlist-extend !
132: ELSE
133: drop
134: THEN
135: REPEAT
136: drop ;
1.18 jwilke 137:
138: : rehashall ( wid -- )
139: drop revealed @
140: IF clearhash addall revealed off
141: THEN ;
1.4 pazsan 142:
1.18 jwilke 143: : (rehash) ( wid -- )
144: dup wordlist-extend @ 0=
145: IF inithash
146: ELSE rehashall THEN ;
147:
1.29 pazsan 148: : hashdouble ( -- )
149: HashTable >r clearhash
150: 1 hashbits 1+ dup to hashbits lshift to hashlen
151: r> free >r 0 to HashTable
152: addall r> throw ;
153:
1.28 jwilke 154: const Create (hashsearch-map)
155: ' hash-find A, ' hash-reveal A, ' (rehash) A, ' (rehash) A,
156: (hashsearch-map) to hashsearch-map
1.4 pazsan 157:
158: \ hash allocate and vocabulary initialization 10oct94py
159:
1.29 pazsan 160: :noname ( n+ -- n )
1.18 jwilke 161: HashTable 0=
162: IF Hashlen cells reserve-mem TO HashTable
163: HashTable Hashlen cells erase THEN
1.29 pazsan 164: HashIndex @ swap HashIndex +!
1.4 pazsan 165: HashIndex @ Hashlen >=
1.19 jwilke 166: [ [IFUNDEF] allocate ]
1.18 jwilke 167: ABORT" no more space in hashtable"
168: [ [ELSE] ]
1.30 anton 169: HashPop @ hashlen 2* >= or
1.29 pazsan 170: IF hashdouble THEN
1.18 jwilke 171: [ [THEN] ] ; is hash-alloc
1.1 pazsan 172:
173: \ Hash-Find 01jan93py
1.19 jwilke 174: has? cross 0=
1.18 jwilke 175: [IF]
1.16 pazsan 176: : make-hash
1.21 pazsan 177: hashsearch-map forth-wordlist wordlist-map !
1.18 jwilke 178: addall ;
179: make-hash \ Baumsuche ist installiert.
180: [ELSE]
1.21 pazsan 181: hashsearch-map forth-wordlist wordlist-map !
1.18 jwilke 182: [THEN]
1.16 pazsan 183:
1.18 jwilke 184: \ for ec version display that vocabulary goes hashed
1.1 pazsan 185:
1.18 jwilke 186: : hash-cold ( -- )
1.19 jwilke 187: [ has? ec [IF] ] ." Hashing..." [ [THEN] ]
1.13 anton 188: HashPointer off 0 TO HashTable HashIndex off
1.18 jwilke 189: addall
190: \ voclink
191: \ BEGIN @ dup WHILE
192: \ dup 0 wordlist-link - initvoc
193: \ REPEAT drop
1.19 jwilke 194: [ has? ec [IF] ] ." Done" cr [ [THEN] ] ;
1.18 jwilke 195:
1.34 anton 196: :noname ( -- )
197: defers 'cold
198: hash-cold
199: ; is 'cold
1.5 pazsan 200:
1.1 pazsan 201: : .words ( -- )
1.13 anton 202: base @ >r hex HashTable Hashlen 0
1.4 pazsan 203: DO cr i 2 .r ." : " dup i cells +
1.1 pazsan 204: BEGIN @ dup WHILE
1.20 pazsan 205: dup cell+ @ name>string type space REPEAT drop
1.1 pazsan 206: LOOP drop r> base ! ;
207:
1.2 anton 208: \ \ this stuff is for evaluating the hash function
209: \ : square dup * ;
210:
211: \ : countwl ( -- sum sumsq )
1.4 pazsan 212: \ \ gives the number of words in the current wordlist
213: \ \ and the sum of squares for the sublist lengths
1.2 anton 214: \ 0 0
1.13 anton 215: \ hashtable Hashlen cells bounds DO
1.4 pazsan 216: \ 0 i BEGIN
217: \ @ dup WHILE
218: \ swap 1+ swap
219: \ REPEAT
220: \ drop
221: \ swap over square +
222: \ >r + r>
223: \ 1 cells
224: \ +LOOP ;
1.2 anton 225:
226: \ : chisq ( -- n )
1.4 pazsan 227: \ \ n should have about the same size as Hashlen
228: \ countwl Hashlen 2 pick */ swap - ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>