Annotation of gforth/hash.fs, revision 1.15

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 HashIndex
1.13      anton      31: 0 Value HashTable
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# )
1.13      anton      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.14      anton      62: : (reveal ( nfa wid -- )
1.12      anton      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: 
1.14      anton      77: : hash-reveal ( nfa wid -- )
                     78:     2dup (reveal) (reveal ;
1.1       pazsan     79: 
1.4       pazsan     80: : addall  ( -- )
                     81:     voclink
                     82:     BEGIN  @ dup @  WHILE  dup 'initvoc  REPEAT  drop ;
                     83: 
                     84: : clearhash  ( -- )
1.13      anton      85:     HashTable Hashlen cells bounds
1.4       pazsan     86:     DO  I @
1.15    ! pazsan     87:        BEGIN  dup  WHILE
        !            88:               dup @ swap HashPointer DelFix
1.4       pazsan     89:         REPEAT  I !
                     90:     cell +LOOP  HashIndex off ;
                     91: 
1.7       pazsan     92: : re-hash  clearhash addall ;
1.4       pazsan     93: : (rehash) ( addr -- )
1.7       pazsan     94:   drop revealed @ IF  re-hash revealed off  THEN ;
1.4       pazsan     95: 
1.12      anton      96: Create hashsearch-map ( -- wordlist-map )
                     97:     ' hash-find A, ' hash-reveal A, ' (rehash) A,
1.4       pazsan     98: 
                     99: \ hash allocate and vocabulary initialization          10oct94py
                    100: 
1.13      anton     101: : hash-alloc ( addr -- addr )  HashTable 0= IF
                    102:   Hashlen cells allocate throw TO HashTable
                    103:   HashTable Hashlen cells erase THEN
1.4       pazsan    104:   HashIndex @ over !  1 HashIndex +!
                    105:   HashIndex @ Hashlen >=
                    106:   IF  clearhash
                    107:       1 hashbits 1+ dup  to hashbits  lshift  to hashlen
1.13      anton     108:       HashTable free
1.4       pazsan    109:       addall
                    110:   THEN ;
1.1       pazsan    111: 
1.4       pazsan    112: : (initvoc) ( addr -- )
1.15    ! pazsan    113:     cell+ dup @  0< IF  drop EXIT  THEN
1.2       anton     114:     insRule @ >r  insRule off  hash-alloc
1.12      anton     115:     3 cells - hashsearch-map over cell+ ! dup
1.2       anton     116:     BEGIN  @ dup  WHILE  2dup swap (reveal  REPEAT
                    117:     2drop  r> insRule ! ;
1.1       pazsan    118: 
1.13      anton     119: ' (initvoc) ' 'initvoc >body !
1.1       pazsan    120: 
                    121: \ Hash-Find                                            01jan93py
                    122: 
                    123: addall          \ Baum aufbauen
                    124: \ Baumsuche ist installiert.
                    125: 
1.5       pazsan    126: : hash-cold  ( -- ) Defers 'cold
1.13      anton     127:   HashPointer off  0 TO HashTable  HashIndex off
1.6       pazsan    128:   voclink
                    129:   BEGIN  @ dup @  WHILE
                    130:          dup cell - @ >r
                    131:          dup 'initvoc
                    132:          r> over cell - !
                    133:   REPEAT  drop ;
1.13      anton     134: ' hash-cold ' 'cold >body !
1.5       pazsan    135: 
1.1       pazsan    136: : .words  ( -- )
1.13      anton     137:   base @ >r hex HashTable  Hashlen 0
1.4       pazsan    138:   DO  cr  i 2 .r ." : " dup i cells +
1.1       pazsan    139:       BEGIN  @ dup  WHILE
                    140:              dup cell+ @ .name  REPEAT  drop
                    141:   LOOP  drop r> base ! ;
                    142: 
1.2       anton     143: \ \ this stuff is for evaluating the hash function
                    144: \ : square dup * ;
                    145: 
                    146: \ : countwl  ( -- sum sumsq )
1.4       pazsan    147: \     \ gives the number of words in the current wordlist
                    148: \     \ and the sum of squares for the sublist lengths
1.2       anton     149: \     0 0
1.13      anton     150: \     hashtable Hashlen cells bounds DO
1.4       pazsan    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 ;
1.2       anton     160: 
                    161: \ : chisq ( -- n )
1.4       pazsan    162: \     \ n should have about the same size as Hashlen
                    163: \     countwl Hashlen 2 pick */ swap - ;

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