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