Annotation of gforth/hash.fs, revision 1.20

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.19      jwilke     21: [IFUNDEF] allocate
1.18      jwilke     22: : reserve-mem here swap allot ;
                     23: \ move to a kernel/memory.fs
                     24: [ELSE]
                     25: : reserve-mem allocate throw ;
                     26: [THEN]
                     27: 
                     28: [IFUNDEF] hashbits
1.19      jwilke     29: 11 Value hashbits
1.18      jwilke     30: [THEN]
1.2       anton      31: 1 hashbits lshift Value Hashlen
1.1       pazsan     32: 
1.18      jwilke     33: \ compute hash key                                     15jul94py
                     34: 
                     35: [IFUNDEF] hash
                     36: : hash ( addr len -- key )
                     37:     hashbits (hashkey1) ;
                     38: [THEN]
                     39: 
1.1       pazsan     40: Variable insRule        insRule on
1.4       pazsan     41: Variable revealed
1.1       pazsan     42: 
1.4       pazsan     43: \ Memory handling                                      10oct94py
1.1       pazsan     44: 
                     45: Variable HashPointer
1.4       pazsan     46: Variable HashIndex
1.13      anton      47: 0 Value HashTable
1.1       pazsan     48: 
1.18      jwilke     49: \ forward declarations
                     50: 0 Value hashsearch-map
                     51: Defer hash-alloc
                     52: 
1.4       pazsan     53: \ DelFix and NewFix are from bigFORTH                  15jul94py
1.1       pazsan     54: 
                     55: : DelFix ( addr root -- ) dup @ 2 pick ! ! ;
                     56: : NewFix  ( root len # -- addr )
1.18      jwilke     57:   BEGIN  2 pick @ ?dup  0= WHILE  2dup * reserve-mem
1.1       pazsan     58:          over 0 ?DO  dup 4 pick DelFix 2 pick +  LOOP  drop
                     59:   REPEAT  >r drop r@ @ rot ! r@ swap erase r> ;
                     60: 
1.12      anton      61: : bucket ( addr len wordlist -- bucket-addr )
                     62:     \ @var{bucket-addr} is the address of a cell that points to the first
                     63:     \ element in the list of the bucket for the string @var{addr len}
                     64:     wordlist-extend @ -rot hash xor ( bucket# )
1.13      anton      65:     cells HashTable + ;
1.2       anton      66: 
                     67: : hash-find ( addr len wordlist -- nfa / false )
1.12      anton      68:     >r 2dup r> bucket @ (hashfind) ;
1.1       pazsan     69: 
                     70: \ hash vocabularies                                    16jul94py
                     71: 
                     72: : lastlink! ( addr link -- )
                     73:   BEGIN  dup @ dup  WHILE  nip  REPEAT  drop ! ;
                     74: 
1.14      anton      75: : (reveal ( nfa wid -- )
1.12      anton      76:     over name>string rot bucket >r
                     77:     HashPointer 2 Cells $400 NewFix
                     78:     tuck cell+ ! r> insRule @
                     79:     IF
                     80:        dup @ 2 pick ! !
                     81:     ELSE
                     82:        lastlink!
                     83:     THEN
                     84:     revealed on ;
                     85: 
1.14      anton      86: : hash-reveal ( nfa wid -- )
                     87:     2dup (reveal) (reveal ;
1.1       pazsan     88: 
1.18      jwilke     89: : inithash ( wid -- )
                     90:     wordlist-extend
                     91:     insRule @ >r  insRule off  hash-alloc 3 cells - dup
                     92:     BEGIN  @ dup  WHILE  2dup swap (reveal  REPEAT
                     93:     2drop  r> insRule ! ;
                     94: 
1.4       pazsan     95: : addall  ( -- )
                     96:     voclink
1.18      jwilke     97:     BEGIN  @ dup WHILE
                     98:           dup 0 wordlist-link -
                     99:           dup wordlist-map @ hashsearch-map = 
                    100:           IF  inithash ELSE drop THEN
                    101:     REPEAT  drop ;
1.4       pazsan    102: 
                    103: : clearhash  ( -- )
1.13      anton     104:     HashTable Hashlen cells bounds
1.4       pazsan    105:     DO  I @
1.15      pazsan    106:        BEGIN  dup  WHILE
                    107:               dup @ swap HashPointer DelFix
1.4       pazsan    108:         REPEAT  I !
1.18      jwilke    109:     cell +LOOP  HashIndex off 
                    110:     voclink
                    111:     BEGIN @ dup WHILE
                    112:          dup 0 wordlist-link -
                    113:          dup wordlist-map @ hashsearch-map = 
                    114:          IF 0 swap wordlist-extend ! ELSE drop THEN
                    115:     REPEAT drop ;
                    116: 
                    117: : rehashall  ( wid -- ) 
                    118:   drop revealed @ 
                    119:   IF   clearhash addall revealed off 
                    120:   THEN ;
1.4       pazsan    121: 
1.18      jwilke    122: : (rehash)   ( wid -- )
                    123:   dup wordlist-extend @ 0=
                    124:   IF   inithash
                    125:   ELSE rehashall THEN ;
                    126: 
                    127: \ >rom ?!
                    128: align here    ' hash-find A, ' hash-reveal A, ' (rehash) A, ' (rehash) A,
                    129: to hashsearch-map
1.4       pazsan    130: 
                    131: \ hash allocate and vocabulary initialization          10oct94py
                    132: 
1.18      jwilke    133: :noname ( hash-alloc ) ( addr -- addr )  
                    134:   HashTable 0= 
                    135:   IF  Hashlen cells reserve-mem TO HashTable
                    136:       HashTable Hashlen cells erase THEN
1.4       pazsan    137:   HashIndex @ over !  1 HashIndex +!
                    138:   HashIndex @ Hashlen >=
1.19      jwilke    139:   [ [IFUNDEF] allocate ]
1.18      jwilke    140:   ABORT" no more space in hashtable"
                    141:   [ [ELSE] ]
1.17      pazsan    142:   IF  HashTable >r clearhash
1.4       pazsan    143:       1 hashbits 1+ dup  to hashbits  lshift  to hashlen
1.17      pazsan    144:       r> free >r  0 to HashTable
                    145:       addall r> throw
1.18      jwilke    146:   THEN 
                    147:   [ [THEN] ] ; is hash-alloc
1.1       pazsan    148: 
                    149: \ Hash-Find                                            01jan93py
1.19      jwilke    150: has? cross 0= 
1.18      jwilke    151: [IF]
1.16      pazsan    152: : make-hash
1.18      jwilke    153:   hashsearch-map forth-wordlist cell+ !
                    154:   addall ;
                    155:   make-hash \ Baumsuche ist installiert.
                    156: [ELSE]
                    157:   hashsearch-map forth-wordlist cell+ !
                    158: [THEN]
1.16      pazsan    159: 
1.18      jwilke    160: \ for ec version display that vocabulary goes hashed
1.1       pazsan    161: 
1.18      jwilke    162: : hash-cold  ( -- )
1.19      jwilke    163: [ has? ec [IF] ] ." Hashing..." [ [THEN] ]
1.13      anton     164:   HashPointer off  0 TO HashTable  HashIndex off
1.18      jwilke    165:   addall
                    166: \  voclink
                    167: \  BEGIN  @ dup WHILE
                    168: \         dup 0 wordlist-link - initvoc
                    169: \  REPEAT  drop 
1.19      jwilke    170: [ has? ec [IF] ] ." Done" cr [ [THEN] ] ;
1.18      jwilke    171: 
                    172: ' hash-cold INIT8 chained
1.5       pazsan    173: 
1.1       pazsan    174: : .words  ( -- )
1.13      anton     175:   base @ >r hex HashTable  Hashlen 0
1.4       pazsan    176:   DO  cr  i 2 .r ." : " dup i cells +
1.1       pazsan    177:       BEGIN  @ dup  WHILE
1.20    ! pazsan    178:              dup cell+ @ name>string type space  REPEAT  drop
1.1       pazsan    179:   LOOP  drop r> base ! ;
                    180: 
1.2       anton     181: \ \ this stuff is for evaluating the hash function
                    182: \ : square dup * ;
                    183: 
                    184: \ : countwl  ( -- sum sumsq )
1.4       pazsan    185: \     \ gives the number of words in the current wordlist
                    186: \     \ and the sum of squares for the sublist lengths
1.2       anton     187: \     0 0
1.13      anton     188: \     hashtable Hashlen cells bounds DO
1.4       pazsan    189: \        0 i BEGIN
                    190: \            @ dup WHILE
                    191: \            swap 1+ swap
                    192: \        REPEAT
                    193: \        drop
                    194: \        swap over square +
                    195: \        >r + r>
                    196: \        1 cells
                    197: \    +LOOP ;
1.2       anton     198: 
                    199: \ : chisq ( -- n )
1.4       pazsan    200: \     \ n should have about the same size as Hashlen
                    201: \     countwl Hashlen 2 pick */ swap - ;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>