Return to hash.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/hash.fs, revision 1.10

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 HashTable
                     31: Variable HashIndex
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.2       anton      48: 
                     49: : hash-find ( addr len wordlist -- nfa / false )
1.8       pazsan     50:     [ 3 cells ] Literal + @ >r
1.4       pazsan     51:     2dup hash r> xor cells HashTable @ + @ (hashfind) ;
1.1       pazsan     52: 
                     53: \ hash vocabularies                                    16jul94py
                     54: 
                     55: : lastlink! ( addr link -- )
                     56:   BEGIN  dup @ dup  WHILE  nip  REPEAT  drop ! ;
                     57: 
1.8       pazsan     58: : (reveal ( addr voc -- )  [ 3 cells ] Literal + dup @ 0< IF  2drop EXIT  THEN
1.4       pazsan     59:   @ over cell+ count $1F and Hash xor cells >r
1.8       pazsan     60:   HashPointer 2 Cells $400 NewFix
1.4       pazsan     61:   tuck cell+ ! r> HashTable @ + insRule @
                     62:   IF  dup @ 2 pick ! !  ELSE  lastlink!  THEN  revealed on ;
1.1       pazsan     63: 
                     64: : hash-reveal ( -- )  (reveal) last?  IF
                     65:   current @ (reveal  THEN ;
                     66: 
1.4       pazsan     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: 
1.7       pazsan     79: : re-hash  clearhash addall ;
1.4       pazsan     80: : (rehash) ( addr -- )
1.7       pazsan     81:   drop revealed @ IF  re-hash revealed off  THEN ;
1.4       pazsan     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 ;
1.1       pazsan     97: 
1.4       pazsan     98: : (initvoc) ( addr -- )
1.2       anton      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 ! ;
1.1       pazsan    104: 
1.4       pazsan    105: ' (initvoc) IS 'initvoc
1.1       pazsan    106: 
                    107: \ Hash-Find                                            01jan93py
                    108: 
                    109: addall          \ Baum aufbauen
                    110: \ Baumsuche ist installiert.
                    111: 
1.5       pazsan    112: : hash-cold  ( -- ) Defers 'cold
                    113:   HashPointer off  HashTable off  HashIndex off
1.6       pazsan    114:   voclink
                    115:   BEGIN  @ dup @  WHILE
                    116:          dup cell - @ >r
                    117:          dup 'initvoc
                    118:          r> over cell - !
                    119:   REPEAT  drop ;
1.5       pazsan    120: ' hash-cold IS 'cold
                    121: 
1.1       pazsan    122: : .words  ( -- )
1.4       pazsan    123:   base @ >r hex HashTable @  Hashlen 0
                    124:   DO  cr  i 2 .r ." : " dup i cells +
1.1       pazsan    125:       BEGIN  @ dup  WHILE
                    126:              dup cell+ @ .name  REPEAT  drop
                    127:   LOOP  drop r> base ! ;
                    128: 
1.2       anton     129: \ \ this stuff is for evaluating the hash function
                    130: \ : square dup * ;
                    131: 
                    132: \ : countwl  ( -- sum sumsq )
1.4       pazsan    133: \     \ gives the number of words in the current wordlist
                    134: \     \ and the sum of squares for the sublist lengths
1.2       anton     135: \     0 0
1.4       pazsan    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 ;
1.2       anton     146: 
                    147: \ : chisq ( -- n )
1.4       pazsan    148: \     \ n should have about the same size as Hashlen
                    149: \     countwl Hashlen 2 pick */ swap - ;