Annotation of gforth/hash.fs, revision 1.12
1.1 pazsan 1: \ Hashed dictionaries 15jul94py
2:
1.10 anton 3: \ Copyright (C) 1995 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:
1.9 anton 21: 11 value hashbits
1.2 anton 22: 1 hashbits lshift Value Hashlen
1.1 pazsan 23:
24: Variable insRule insRule on
1.4 pazsan 25: Variable revealed
1.1 pazsan 26:
1.4 pazsan 27: \ Memory handling 10oct94py
1.1 pazsan 28:
29: Variable HashPointer
1.4 pazsan 30: Variable HashTable
31: Variable HashIndex
1.1 pazsan 32:
1.4 pazsan 33: \ DelFix and NewFix are from bigFORTH 15jul94py
1.1 pazsan 34:
35: : DelFix ( addr root -- ) dup @ 2 pick ! ! ;
36: : NewFix ( root len # -- addr )
37: BEGIN 2 pick @ ?dup 0= WHILE 2dup * allocate throw
38: over 0 ?DO dup 4 pick DelFix 2 pick + LOOP drop
39: REPEAT >r drop r@ @ rot ! r@ swap erase r> ;
40:
41: \ compute hash key 15jul94py
42:
1.2 anton 43: : hash ( addr len -- key )
44: hashbits (hashkey1) ;
45: \ (hashkey)
46: \ Hashlen 1- and ;
1.1 pazsan 47:
1.12 ! anton 48: : bucket ( addr len wordlist -- bucket-addr )
! 49: \ @var{bucket-addr} is the address of a cell that points to the first
! 50: \ element in the list of the bucket for the string @var{addr len}
! 51: wordlist-extend @ -rot hash xor ( bucket# )
! 52: cells HashTable @ + ;
1.2 anton 53:
54: : hash-find ( addr len wordlist -- nfa / false )
1.12 ! anton 55: >r 2dup r> bucket @ (hashfind) ;
1.1 pazsan 56:
57: \ hash vocabularies 16jul94py
58:
59: : lastlink! ( addr link -- )
60: BEGIN dup @ dup WHILE nip REPEAT drop ! ;
61:
1.12 ! anton 62: : (reveal ( addr voc -- )
! 63: dup wordlist-extend @ 0<
! 64: IF
! 65: 2drop EXIT
! 66: THEN
! 67: over name>string rot bucket >r
! 68: HashPointer 2 Cells $400 NewFix
! 69: tuck cell+ ! r> insRule @
! 70: IF
! 71: dup @ 2 pick ! !
! 72: ELSE
! 73: lastlink!
! 74: THEN
! 75: revealed on ;
! 76:
! 77: : hash-reveal ( -- )
! 78: (reveal) last?
! 79: IF
! 80: current @ (reveal
! 81: THEN ;
1.1 pazsan 82:
1.4 pazsan 83: : addall ( -- )
84: voclink
85: BEGIN @ dup @ WHILE dup 'initvoc REPEAT drop ;
86:
87: : clearhash ( -- )
88: HashTable @ Hashlen cells bounds
89: DO I @
90: BEGIN dup WHILE
91: dup @ swap HashPointer DelFix
92: REPEAT I !
93: cell +LOOP HashIndex off ;
94:
1.7 pazsan 95: : re-hash clearhash addall ;
1.4 pazsan 96: : (rehash) ( addr -- )
1.7 pazsan 97: drop revealed @ IF re-hash revealed off THEN ;
1.4 pazsan 98:
1.12 ! anton 99: Create hashsearch-map ( -- wordlist-map )
! 100: ' hash-find A, ' hash-reveal A, ' (rehash) A,
1.4 pazsan 101:
102: \ hash allocate and vocabulary initialization 10oct94py
103:
104: : hash-alloc ( addr -- addr ) HashTable @ 0= IF
105: Hashlen cells allocate throw HashTable !
106: HashTable @ Hashlen cells erase THEN
107: HashIndex @ over ! 1 HashIndex +!
108: HashIndex @ Hashlen >=
109: IF clearhash
110: 1 hashbits 1+ dup to hashbits lshift to hashlen
111: HashTable @ free
112: addall
113: THEN ;
1.1 pazsan 114:
1.4 pazsan 115: : (initvoc) ( addr -- )
1.2 anton 116: cell+ dup @ 0< IF drop EXIT THEN
117: insRule @ >r insRule off hash-alloc
1.12 ! anton 118: 3 cells - hashsearch-map over cell+ ! dup
1.2 anton 119: BEGIN @ dup WHILE 2dup swap (reveal REPEAT
120: 2drop r> insRule ! ;
1.1 pazsan 121:
1.4 pazsan 122: ' (initvoc) IS 'initvoc
1.1 pazsan 123:
124: \ Hash-Find 01jan93py
125:
126: addall \ Baum aufbauen
127: \ Baumsuche ist installiert.
128:
1.5 pazsan 129: : hash-cold ( -- ) Defers 'cold
130: HashPointer off HashTable off HashIndex off
1.6 pazsan 131: voclink
132: BEGIN @ dup @ WHILE
133: dup cell - @ >r
134: dup 'initvoc
135: r> over cell - !
136: REPEAT drop ;
1.5 pazsan 137: ' hash-cold IS 'cold
138:
1.1 pazsan 139: : .words ( -- )
1.4 pazsan 140: base @ >r hex HashTable @ Hashlen 0
141: DO cr i 2 .r ." : " dup i cells +
1.1 pazsan 142: BEGIN @ dup WHILE
143: dup cell+ @ .name REPEAT drop
144: LOOP drop r> base ! ;
145:
1.2 anton 146: \ \ this stuff is for evaluating the hash function
147: \ : square dup * ;
148:
149: \ : countwl ( -- sum sumsq )
1.4 pazsan 150: \ \ gives the number of words in the current wordlist
151: \ \ and the sum of squares for the sublist lengths
1.2 anton 152: \ 0 0
1.4 pazsan 153: \ hashtable @ Hashlen cells bounds DO
154: \ 0 i BEGIN
155: \ @ dup WHILE
156: \ swap 1+ swap
157: \ REPEAT
158: \ drop
159: \ swap over square +
160: \ >r + r>
161: \ 1 cells
162: \ +LOOP ;
1.2 anton 163:
164: \ : chisq ( -- n )
1.4 pazsan 165: \ \ n should have about the same size as Hashlen
166: \ countwl Hashlen 2 pick */ swap - ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>