Annotation of gforth/hash.fs, revision 1.12

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

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