Annotation of gforth/hash.fs, revision 1.26
1.1 pazsan 1: \ Hashed dictionaries 15jul94py
2:
1.25 anton 3: \ Copyright (C) 1995,1998,2000 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.19 jwilke 21: [IFUNDEF] allocate
1.18 jwilke 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
1.19 jwilke 29: 11 Value hashbits
1.18 jwilke 30: [THEN]
1.2 anton 31: 1 hashbits lshift Value Hashlen
1.1 pazsan 32:
1.18 jwilke 33: \ compute hash key 15jul94py
34:
35: [IFUNDEF] hash
36: : hash ( addr len -- key )
37: hashbits (hashkey1) ;
38: [THEN]
39:
1.1 pazsan 40: Variable insRule insRule on
1.4 pazsan 41: Variable revealed
1.1 pazsan 42:
1.4 pazsan 43: \ Memory handling 10oct94py
1.1 pazsan 44:
45: Variable HashPointer
1.4 pazsan 46: Variable HashIndex
1.13 anton 47: 0 Value HashTable
1.1 pazsan 48:
1.18 jwilke 49: \ forward declarations
50: 0 Value hashsearch-map
1.23 anton 51: Defer hash-alloc ( addr -- addr )
1.18 jwilke 52:
1.4 pazsan 53: \ DelFix and NewFix are from bigFORTH 15jul94py
1.1 pazsan 54:
55: : DelFix ( addr root -- ) dup @ 2 pick ! ! ;
56: : NewFix ( root len # -- addr )
1.18 jwilke 57: BEGIN 2 pick @ ?dup 0= WHILE 2dup * reserve-mem
1.1 pazsan 58: over 0 ?DO dup 4 pick DelFix 2 pick + LOOP drop
59: REPEAT >r drop r@ @ rot ! r@ swap erase r> ;
60:
1.12 anton 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# )
1.13 anton 65: cells HashTable + ;
1.2 anton 66:
67: : hash-find ( addr len wordlist -- nfa / false )
1.12 anton 68: >r 2dup r> bucket @ (hashfind) ;
1.1 pazsan 69:
70: \ hash vocabularies 16jul94py
71:
72: : lastlink! ( addr link -- )
73: BEGIN dup @ dup WHILE nip REPEAT drop ! ;
74:
1.14 anton 75: : (reveal ( nfa wid -- )
1.12 anton 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:
1.14 anton 86: : hash-reveal ( nfa wid -- )
87: 2dup (reveal) (reveal ;
1.1 pazsan 88:
1.18 jwilke 89: : inithash ( wid -- )
90: wordlist-extend
1.21 pazsan 91: insRule @ >r insRule off hash-alloc 3 cells -
92: dup wordlist-id
1.18 jwilke 93: BEGIN @ dup WHILE 2dup swap (reveal REPEAT
94: 2drop r> insRule ! ;
95:
1.4 pazsan 96: : addall ( -- )
97: voclink
1.18 jwilke 98: BEGIN @ dup WHILE
99: dup 0 wordlist-link -
1.24 pazsan 100: dup wordlist-map @ reveal-method @ ['] hash-reveal =
1.18 jwilke 101: IF inithash ELSE drop THEN
102: REPEAT drop ;
1.4 pazsan 103:
104: : clearhash ( -- )
1.13 anton 105: HashTable Hashlen cells bounds
1.4 pazsan 106: DO I @
1.15 pazsan 107: BEGIN dup WHILE
1.23 anton 108: dup @ swap HashPointer DelFix
109: REPEAT
110: I !
111: cell +LOOP
112: HashIndex off
1.18 jwilke 113: voclink
1.23 anton 114: BEGIN ( wordlist-link-addr )
115: @ dup
116: WHILE ( wordlist-link )
117: dup 0 wordlist-link - ( wordlist-link wid )
118: dup wordlist-map @ hashsearch-map =
119: IF ( wordlist-link wid )
120: 0 swap wordlist-extend !
121: ELSE
122: drop
123: THEN
124: REPEAT
125: drop ;
1.18 jwilke 126:
127: : rehashall ( wid -- )
128: drop revealed @
129: IF clearhash addall revealed off
130: THEN ;
1.4 pazsan 131:
1.18 jwilke 132: : (rehash) ( wid -- )
133: dup wordlist-extend @ 0=
134: IF inithash
135: ELSE rehashall THEN ;
136:
137: \ >rom ?!
138: align here ' hash-find A, ' hash-reveal A, ' (rehash) A, ' (rehash) A,
139: to hashsearch-map
1.4 pazsan 140:
141: \ hash allocate and vocabulary initialization 10oct94py
142:
1.23 anton 143: :noname ( addr -- addr )
1.18 jwilke 144: HashTable 0=
145: IF Hashlen cells reserve-mem TO HashTable
146: HashTable Hashlen cells erase THEN
1.4 pazsan 147: HashIndex @ over ! 1 HashIndex +!
148: HashIndex @ Hashlen >=
1.19 jwilke 149: [ [IFUNDEF] allocate ]
1.18 jwilke 150: ABORT" no more space in hashtable"
151: [ [ELSE] ]
1.17 pazsan 152: IF HashTable >r clearhash
1.4 pazsan 153: 1 hashbits 1+ dup to hashbits lshift to hashlen
1.17 pazsan 154: r> free >r 0 to HashTable
155: addall r> throw
1.18 jwilke 156: THEN
157: [ [THEN] ] ; is hash-alloc
1.1 pazsan 158:
159: \ Hash-Find 01jan93py
1.19 jwilke 160: has? cross 0=
1.18 jwilke 161: [IF]
1.16 pazsan 162: : make-hash
1.21 pazsan 163: hashsearch-map forth-wordlist wordlist-map !
1.18 jwilke 164: addall ;
165: make-hash \ Baumsuche ist installiert.
166: [ELSE]
1.21 pazsan 167: hashsearch-map forth-wordlist wordlist-map !
1.18 jwilke 168: [THEN]
1.16 pazsan 169:
1.18 jwilke 170: \ for ec version display that vocabulary goes hashed
1.1 pazsan 171:
1.18 jwilke 172: : hash-cold ( -- )
1.19 jwilke 173: [ has? ec [IF] ] ." Hashing..." [ [THEN] ]
1.13 anton 174: HashPointer off 0 TO HashTable HashIndex off
1.18 jwilke 175: addall
176: \ voclink
177: \ BEGIN @ dup WHILE
178: \ dup 0 wordlist-link - initvoc
179: \ REPEAT drop
1.19 jwilke 180: [ has? ec [IF] ] ." Done" cr [ [THEN] ] ;
1.18 jwilke 181:
182: ' hash-cold INIT8 chained
1.5 pazsan 183:
1.1 pazsan 184: : .words ( -- )
1.13 anton 185: base @ >r hex HashTable Hashlen 0
1.4 pazsan 186: DO cr i 2 .r ." : " dup i cells +
1.1 pazsan 187: BEGIN @ dup WHILE
1.20 pazsan 188: dup cell+ @ name>string type space REPEAT drop
1.1 pazsan 189: LOOP drop r> base ! ;
190:
1.2 anton 191: \ \ this stuff is for evaluating the hash function
192: \ : square dup * ;
193:
194: \ : countwl ( -- sum sumsq )
1.4 pazsan 195: \ \ gives the number of words in the current wordlist
196: \ \ and the sum of squares for the sublist lengths
1.2 anton 197: \ 0 0
1.13 anton 198: \ hashtable Hashlen cells bounds DO
1.4 pazsan 199: \ 0 i BEGIN
200: \ @ dup WHILE
201: \ swap 1+ swap
202: \ REPEAT
203: \ drop
204: \ swap over square +
205: \ >r + r>
206: \ 1 cells
207: \ +LOOP ;
1.2 anton 208:
209: \ : chisq ( -- n )
1.4 pazsan 210: \ \ n should have about the same size as Hashlen
211: \ countwl Hashlen 2 pick */ swap - ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>