Annotation of gforth/hash.fs, revision 1.6
1.1 pazsan 1: \ Hashed dictionaries 15jul94py
2:
1.4 pazsan 3: 9 value hashbits
1.2 anton 4: 1 hashbits lshift Value Hashlen
1.1 pazsan 5:
6: Variable insRule insRule on
1.4 pazsan 7: Variable revealed
1.1 pazsan 8:
1.4 pazsan 9: \ Memory handling 10oct94py
1.1 pazsan 10:
11: Variable HashPointer
1.4 pazsan 12: Variable HashTable
13: Variable HashIndex
1.1 pazsan 14:
1.4 pazsan 15: \ DelFix and NewFix are from bigFORTH 15jul94py
1.1 pazsan 16:
17: : DelFix ( addr root -- ) dup @ 2 pick ! ! ;
18: : NewFix ( root len # -- addr )
19: BEGIN 2 pick @ ?dup 0= WHILE 2dup * allocate throw
20: over 0 ?DO dup 4 pick DelFix 2 pick + LOOP drop
21: REPEAT >r drop r@ @ rot ! r@ swap erase r> ;
22:
23: \ compute hash key 15jul94py
24:
1.2 anton 25: : hash ( addr len -- key )
26: hashbits (hashkey1) ;
27: \ (hashkey)
28: \ Hashlen 1- and ;
1.1 pazsan 29:
1.2 anton 30:
31: : hash-find ( addr len wordlist -- nfa / false )
32: $C + @ >r
1.4 pazsan 33: 2dup hash r> xor cells HashTable @ + @ (hashfind) ;
1.1 pazsan 34:
35: \ hash vocabularies 16jul94py
36:
37: : lastlink! ( addr link -- )
38: BEGIN dup @ dup WHILE nip REPEAT drop ! ;
39:
40: : (reveal ( addr voc -- ) $C + dup @ 0< IF 2drop EXIT THEN
1.4 pazsan 41: @ over cell+ count $1F and Hash xor cells >r
1.1 pazsan 42: HashPointer 8 $400 NewFix
1.4 pazsan 43: tuck cell+ ! r> HashTable @ + insRule @
44: IF dup @ 2 pick ! ! ELSE lastlink! THEN revealed on ;
1.1 pazsan 45:
46: : hash-reveal ( -- ) (reveal) last? IF
47: current @ (reveal THEN ;
48:
1.4 pazsan 49: : addall ( -- )
50: voclink
51: BEGIN @ dup @ WHILE dup 'initvoc REPEAT drop ;
52:
53: : clearhash ( -- )
54: HashTable @ Hashlen cells bounds
55: DO I @
56: BEGIN dup WHILE
57: dup @ swap HashPointer DelFix
58: REPEAT I !
59: cell +LOOP HashIndex off ;
60:
61: : rehash clearhash addall ;
62: : (rehash) ( addr -- )
63: drop revealed @ IF rehash revealed off THEN ;
64:
65: Create hashsearch ' hash-find A, ' hash-reveal A, ' (rehash) A,
66:
67: \ hash allocate and vocabulary initialization 10oct94py
68:
69: : hash-alloc ( addr -- addr ) HashTable @ 0= IF
70: Hashlen cells allocate throw HashTable !
71: HashTable @ Hashlen cells erase THEN
72: HashIndex @ over ! 1 HashIndex +!
73: HashIndex @ Hashlen >=
74: IF clearhash
75: 1 hashbits 1+ dup to hashbits lshift to hashlen
76: HashTable @ free
77: addall
78: THEN ;
1.1 pazsan 79:
1.4 pazsan 80: : (initvoc) ( addr -- )
1.2 anton 81: cell+ dup @ 0< IF drop EXIT THEN
82: insRule @ >r insRule off hash-alloc
83: 3 cells - hashsearch over cell+ ! dup
84: BEGIN @ dup WHILE 2dup swap (reveal REPEAT
85: 2drop r> insRule ! ;
1.1 pazsan 86:
1.4 pazsan 87: ' (initvoc) IS 'initvoc
1.1 pazsan 88:
89: \ Hash-Find 01jan93py
90:
91: addall \ Baum aufbauen
92: \ Baumsuche ist installiert.
93:
1.5 pazsan 94: : hash-cold ( -- ) Defers 'cold
95: HashPointer off HashTable off HashIndex off
1.6 ! pazsan 96: voclink
! 97: BEGIN @ dup @ WHILE
! 98: dup cell - @ >r
! 99: dup 'initvoc
! 100: r> over cell - !
! 101: REPEAT drop ;
1.5 pazsan 102: ' hash-cold IS 'cold
103:
1.1 pazsan 104: : .words ( -- )
1.4 pazsan 105: base @ >r hex HashTable @ Hashlen 0
106: DO cr i 2 .r ." : " dup i cells +
1.1 pazsan 107: BEGIN @ dup WHILE
108: dup cell+ @ .name REPEAT drop
109: LOOP drop r> base ! ;
110:
1.2 anton 111: \ \ this stuff is for evaluating the hash function
112: \ : square dup * ;
113:
114: \ : countwl ( -- sum sumsq )
1.4 pazsan 115: \ \ gives the number of words in the current wordlist
116: \ \ and the sum of squares for the sublist lengths
1.2 anton 117: \ 0 0
1.4 pazsan 118: \ hashtable @ Hashlen cells bounds DO
119: \ 0 i BEGIN
120: \ @ dup WHILE
121: \ swap 1+ swap
122: \ REPEAT
123: \ drop
124: \ swap over square +
125: \ >r + r>
126: \ 1 cells
127: \ +LOOP ;
1.2 anton 128:
129: \ : chisq ( -- n )
1.4 pazsan 130: \ \ n should have about the same size as Hashlen
131: \ countwl Hashlen 2 pick */ swap - ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>