File:
[gforth] /
gforth /
hash.fs
Revision
1.14:
download - view:
text,
annotated -
select for diffs
Mon May 13 16:36:58 1996 UTC (27 years, 11 months ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
eliminated state-smartness in ;code and sfnumber
immediate-flag is now $40 and restrict-flag $20
HEADER now stores the compilation wordlist in the header and
REVEAL reveals into that wordlist
assorted cleanups
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 HashIndex
31: 0 Value HashTable
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: : 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 + ;
53:
54: : hash-find ( addr len wordlist -- nfa / false )
55: >r 2dup r> bucket @ (hashfind) ;
56:
57: \ hash vocabularies 16jul94py
58:
59: : lastlink! ( addr link -- )
60: BEGIN dup @ dup WHILE nip REPEAT drop ! ;
61:
62: : (reveal ( nfa wid -- )
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 ( nfa wid -- )
78: 2dup (reveal) (reveal ;
79:
80: : addall ( -- )
81: voclink
82: BEGIN @ dup @ WHILE dup 'initvoc REPEAT drop ;
83:
84: : clearhash ( -- )
85: HashTable Hashlen cells bounds
86: DO I @
87: BEGIN dup WHILE
88: dup @ swap HashPointer DelFix
89: REPEAT I !
90: cell +LOOP HashIndex off ;
91:
92: : re-hash clearhash addall ;
93: : (rehash) ( addr -- )
94: drop revealed @ IF re-hash revealed off THEN ;
95:
96: Create hashsearch-map ( -- wordlist-map )
97: ' hash-find A, ' hash-reveal A, ' (rehash) A,
98:
99: \ hash allocate and vocabulary initialization 10oct94py
100:
101: : hash-alloc ( addr -- addr ) HashTable 0= IF
102: Hashlen cells allocate throw TO HashTable
103: HashTable Hashlen cells erase THEN
104: HashIndex @ over ! 1 HashIndex +!
105: HashIndex @ Hashlen >=
106: IF clearhash
107: 1 hashbits 1+ dup to hashbits lshift to hashlen
108: HashTable free
109: addall
110: THEN ;
111:
112: : (initvoc) ( addr -- )
113: cell+ dup @ 0< IF drop EXIT THEN
114: insRule @ >r insRule off hash-alloc
115: 3 cells - hashsearch-map over cell+ ! dup
116: BEGIN @ dup WHILE 2dup swap (reveal REPEAT
117: 2drop r> insRule ! ;
118:
119: ' (initvoc) ' 'initvoc >body !
120:
121: \ Hash-Find 01jan93py
122:
123: addall \ Baum aufbauen
124: \ Baumsuche ist installiert.
125:
126: : hash-cold ( -- ) Defers 'cold
127: HashPointer off 0 TO HashTable HashIndex off
128: voclink
129: BEGIN @ dup @ WHILE
130: dup cell - @ >r
131: dup 'initvoc
132: r> over cell - !
133: REPEAT drop ;
134: ' hash-cold ' 'cold >body !
135:
136: : .words ( -- )
137: base @ >r hex HashTable Hashlen 0
138: DO cr i 2 .r ." : " dup i cells +
139: BEGIN @ dup WHILE
140: dup cell+ @ .name REPEAT drop
141: LOOP drop r> base ! ;
142:
143: \ \ this stuff is for evaluating the hash function
144: \ : square dup * ;
145:
146: \ : countwl ( -- sum sumsq )
147: \ \ gives the number of words in the current wordlist
148: \ \ and the sum of squares for the sublist lengths
149: \ 0 0
150: \ hashtable Hashlen cells bounds DO
151: \ 0 i BEGIN
152: \ @ dup WHILE
153: \ swap 1+ swap
154: \ REPEAT
155: \ drop
156: \ swap over square +
157: \ >r + r>
158: \ 1 cells
159: \ +LOOP ;
160:
161: \ : chisq ( -- n )
162: \ \ n should have about the same size as Hashlen
163: \ countwl Hashlen 2 pick */ swap - ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>