Annotation of gforth/hash.fs, revision 1.40
1.1 pazsan 1: \ Hashed dictionaries 15jul94py
2:
1.40 ! anton 3: \ Copyright (C) 1995,1998,2000,2003,2006,2007,2009 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
1.36 anton 9: \ as published by the Free Software Foundation, either version 3
1.10 anton 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
1.36 anton 18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.10 anton 19:
1.28 jwilke 20: [IFUNDEF] erase
21: : erase ( addr len -- ) 0 fill ;
22: [THEN]
23:
1.19 jwilke 24: [IFUNDEF] allocate
1.18 jwilke 25: : reserve-mem here swap allot ;
26: \ move to a kernel/memory.fs
27: [ELSE]
28: : reserve-mem allocate throw ;
29: [THEN]
30:
31: [IFUNDEF] hashbits
1.19 jwilke 32: 11 Value hashbits
1.18 jwilke 33: [THEN]
1.2 anton 34: 1 hashbits lshift Value Hashlen
1.1 pazsan 35:
1.18 jwilke 36: \ compute hash key 15jul94py
37:
1.28 jwilke 38: has? ec [IF] [IFUNDEF] hash
39: : hash ( addr len -- key )
40: over c@ swap 1- IF swap char+ c@ + ELSE nip THEN
41: [ Hashlen 1- ] literal and ;
42: [THEN] [THEN]
43:
1.18 jwilke 44: [IFUNDEF] hash
45: : hash ( addr len -- key )
46: hashbits (hashkey1) ;
47: [THEN]
48:
1.1 pazsan 49: Variable insRule insRule on
1.4 pazsan 50: Variable revealed
1.1 pazsan 51:
1.4 pazsan 52: \ Memory handling 10oct94py
1.1 pazsan 53:
1.28 jwilke 54: AVariable HashPointer
1.29 pazsan 55: Variable HashIndex \ Number of wordlists
56: Variable HashPop \ Number of words
1.28 jwilke 57: 0 AValue HashTable
1.1 pazsan 58:
1.18 jwilke 59: \ forward declarations
1.28 jwilke 60: 0 AValue hashsearch-map
1.23 anton 61: Defer hash-alloc ( addr -- addr )
1.18 jwilke 62:
1.4 pazsan 63: \ DelFix and NewFix are from bigFORTH 15jul94py
1.1 pazsan 64:
65: : DelFix ( addr root -- ) dup @ 2 pick ! ! ;
66: : NewFix ( root len # -- addr )
1.18 jwilke 67: BEGIN 2 pick @ ?dup 0= WHILE 2dup * reserve-mem
1.1 pazsan 68: over 0 ?DO dup 4 pick DelFix 2 pick + LOOP drop
69: REPEAT >r drop r@ @ rot ! r@ swap erase r> ;
70:
1.12 anton 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# )
1.13 anton 75: cells HashTable + ;
1.2 anton 76:
77: : hash-find ( addr len wordlist -- nfa / false )
1.27 anton 78: >r 2dup r> bucket @ (hashlfind) ;
1.1 pazsan 79:
80: \ hash vocabularies 16jul94py
81:
82: : lastlink! ( addr link -- )
83: BEGIN dup @ dup WHILE nip REPEAT drop ! ;
84:
1.14 anton 85: : (reveal ( nfa wid -- )
1.12 anton 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
1.29 pazsan 94: revealed on 1 HashPop +! 0 hash-alloc drop ;
1.12 anton 95:
1.14 anton 96: : hash-reveal ( nfa wid -- )
97: 2dup (reveal) (reveal ;
1.1 pazsan 98:
1.18 jwilke 99: : inithash ( wid -- )
100: wordlist-extend
1.29 pazsan 101: insRule @ >r insRule off 1 hash-alloc over ! 3 cells -
1.21 pazsan 102: dup wordlist-id
1.18 jwilke 103: BEGIN @ dup WHILE 2dup swap (reveal REPEAT
104: 2drop r> insRule ! ;
105:
1.4 pazsan 106: : addall ( -- )
1.29 pazsan 107: HashPop off voclink
1.18 jwilke 108: BEGIN @ dup WHILE
109: dup 0 wordlist-link -
1.24 pazsan 110: dup wordlist-map @ reveal-method @ ['] hash-reveal =
1.18 jwilke 111: IF inithash ELSE drop THEN
112: REPEAT drop ;
1.4 pazsan 113:
114: : clearhash ( -- )
1.13 anton 115: HashTable Hashlen cells bounds
1.4 pazsan 116: DO I @
1.15 pazsan 117: BEGIN dup WHILE
1.23 anton 118: dup @ swap HashPointer DelFix
119: REPEAT
120: I !
121: cell +LOOP
122: HashIndex off
1.18 jwilke 123: voclink
1.23 anton 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 ;
1.18 jwilke 136:
137: : rehashall ( wid -- )
138: drop revealed @
139: IF clearhash addall revealed off
140: THEN ;
1.4 pazsan 141:
1.18 jwilke 142: : (rehash) ( wid -- )
143: dup wordlist-extend @ 0=
144: IF inithash
145: ELSE rehashall THEN ;
146:
1.29 pazsan 147: : hashdouble ( -- )
148: HashTable >r clearhash
149: 1 hashbits 1+ dup to hashbits lshift to hashlen
150: r> free >r 0 to HashTable
151: addall r> throw ;
152:
1.28 jwilke 153: const Create (hashsearch-map)
154: ' hash-find A, ' hash-reveal A, ' (rehash) A, ' (rehash) A,
155: (hashsearch-map) to hashsearch-map
1.4 pazsan 156:
157: \ hash allocate and vocabulary initialization 10oct94py
158:
1.29 pazsan 159: :noname ( n+ -- n )
1.18 jwilke 160: HashTable 0=
161: IF Hashlen cells reserve-mem TO HashTable
162: HashTable Hashlen cells erase THEN
1.29 pazsan 163: HashIndex @ swap HashIndex +!
1.4 pazsan 164: HashIndex @ Hashlen >=
1.19 jwilke 165: [ [IFUNDEF] allocate ]
1.18 jwilke 166: ABORT" no more space in hashtable"
167: [ [ELSE] ]
1.30 anton 168: HashPop @ hashlen 2* >= or
1.29 pazsan 169: IF hashdouble THEN
1.18 jwilke 170: [ [THEN] ] ; is hash-alloc
1.1 pazsan 171:
172: \ Hash-Find 01jan93py
1.19 jwilke 173: has? cross 0=
1.18 jwilke 174: [IF]
1.39 pazsan 175: : hash-wordlist ( wid -- )
176: hashsearch-map swap wordlist-map ! ;
1.16 pazsan 177: : make-hash
1.39 pazsan 178: forth-wordlist hash-wordlist
179: environment-wordlist hash-wordlist
180: ['] Root >body hash-wordlist
1.18 jwilke 181: addall ;
182: make-hash \ Baumsuche ist installiert.
183: [ELSE]
1.21 pazsan 184: hashsearch-map forth-wordlist wordlist-map !
1.18 jwilke 185: [THEN]
1.16 pazsan 186:
1.18 jwilke 187: \ for ec version display that vocabulary goes hashed
1.1 pazsan 188:
1.18 jwilke 189: : hash-cold ( -- )
1.19 jwilke 190: [ has? ec [IF] ] ." Hashing..." [ [THEN] ]
1.13 anton 191: HashPointer off 0 TO HashTable HashIndex off
1.18 jwilke 192: addall
193: \ voclink
194: \ BEGIN @ dup WHILE
195: \ dup 0 wordlist-link - initvoc
196: \ REPEAT drop
1.19 jwilke 197: [ has? ec [IF] ] ." Done" cr [ [THEN] ] ;
1.18 jwilke 198:
1.34 anton 199: :noname ( -- )
200: defers 'cold
201: hash-cold
202: ; is 'cold
1.5 pazsan 203:
1.1 pazsan 204: : .words ( -- )
1.13 anton 205: base @ >r hex HashTable Hashlen 0
1.4 pazsan 206: DO cr i 2 .r ." : " dup i cells +
1.1 pazsan 207: BEGIN @ dup WHILE
1.20 pazsan 208: dup cell+ @ name>string type space REPEAT drop
1.1 pazsan 209: LOOP drop r> base ! ;
210:
1.2 anton 211: \ \ this stuff is for evaluating the hash function
212: \ : square dup * ;
213:
214: \ : countwl ( -- sum sumsq )
1.4 pazsan 215: \ \ gives the number of words in the current wordlist
216: \ \ and the sum of squares for the sublist lengths
1.2 anton 217: \ 0 0
1.13 anton 218: \ hashtable Hashlen cells bounds DO
1.4 pazsan 219: \ 0 i BEGIN
220: \ @ dup WHILE
221: \ swap 1+ swap
222: \ REPEAT
223: \ drop
224: \ swap over square +
225: \ >r + r>
226: \ 1 cells
227: \ +LOOP ;
1.2 anton 228:
229: \ : chisq ( -- n )
1.4 pazsan 230: \ \ n should have about the same size as Hashlen
231: \ countwl Hashlen 2 pick */ swap - ;
1.38 pazsan 232:
233: \ Create hashhist here $100 cells dup allot erase
234:
235: \ : .hashhist ( -- ) hashhist $100 cells erase
236: \ HashTable HashLen cells bounds
237: \ DO 0 I BEGIN @ dup WHILE swap 1+ swap REPEAT drop
238: \ 1 swap cells hashhist + +!
239: \ cell +LOOP
240: \ 0 0 $100 0 DO
241: \ hashhist I cells + @ dup IF
242: \ cr I 0 .r ." : " dup . THEN tuck I * + >r + r>
243: \ LOOP cr ." Total: " 0 .r ." /" . cr ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to hash.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth