File:  [gforth] / gforth / hash.fs
Revision 1.22: download - view: text, annotated - select for diffs
Tue Dec 8 22:02:45 1998 UTC (25 years, 3 months ago) by anton
Branches: MAIN
CVS tags: HEAD
updated dates in copyright messages
inserted copyright messages in most files that did not have them
removed outdated files engine/32bit.h engine/strsig.c

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

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