File:  [gforth] / gforth / hash.fs
Revision 1.17: download - view: text, annotated - select for diffs
Fri Nov 15 21:19:29 1996 UTC (27 years, 4 months ago) by pazsan
Branches: MAIN
CVS tags: v0-3-0, v0-2-1, v0-2-0, HEAD
Fixed hash growing

    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  HashTable >r clearhash
  107:       1 hashbits 1+ dup  to hashbits  lshift  to hashlen
  108:       r> free >r  0 to HashTable
  109:       addall r> throw
  110:   THEN ;
  111: 
  112: : (initvoc) ( addr -- )
  113:     cell+ dup @  0< IF  drop EXIT  THEN
  114:     dup 2 cells - @ hashsearch-map <> IF  drop EXIT  THEN
  115:     insRule @ >r  insRule off  hash-alloc 3 cells - dup
  116:     BEGIN  @ dup  WHILE  2dup swap (reveal  REPEAT
  117:     2drop  r> insRule ! ;
  118: 
  119: ' (initvoc) IS 'initvoc
  120: 
  121: \ Hash-Find                                            01jan93py
  122: 
  123: : make-hash
  124:   Root   hashsearch-map context @ cell+ !
  125:   Forth  hashsearch-map context @ cell+ !
  126:   addall          \ Baum aufbauen
  127: ;
  128: 
  129: make-hash  \ Baumsuche ist installiert.
  130: 
  131: : hash-cold  ( -- ) Defers 'cold
  132:   HashPointer off  0 TO HashTable  HashIndex off
  133:   voclink
  134:   BEGIN  @ dup @  WHILE
  135:          dup cell - @ >r
  136:          dup 'initvoc
  137:          r> over cell - !
  138:   REPEAT  drop ;
  139: ' hash-cold ' 'cold >body !
  140: 
  141: : .words  ( -- )
  142:   base @ >r hex HashTable  Hashlen 0
  143:   DO  cr  i 2 .r ." : " dup i cells +
  144:       BEGIN  @ dup  WHILE
  145:              dup cell+ @ .name  REPEAT  drop
  146:   LOOP  drop r> base ! ;
  147: 
  148: \ \ this stuff is for evaluating the hash function
  149: \ : square dup * ;
  150: 
  151: \ : countwl  ( -- sum sumsq )
  152: \     \ gives the number of words in the current wordlist
  153: \     \ and the sum of squares for the sublist lengths
  154: \     0 0
  155: \     hashtable Hashlen cells bounds DO
  156: \        0 i BEGIN
  157: \            @ dup WHILE
  158: \            swap 1+ swap
  159: \        REPEAT
  160: \        drop
  161: \        swap over square +
  162: \        >r + r>
  163: \        1 cells
  164: \    +LOOP ;
  165: 
  166: \ : chisq ( -- n )
  167: \     \ n should have about the same size as Hashlen
  168: \     countwl Hashlen 2 pick */ swap - ;

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