File:  [gforth] / gforth / hash.fs
Revision 1.18: download - view: text, annotated - select for diffs
Sun Jul 6 15:55:24 1997 UTC (24 years, 2 months ago) by jwilke
Branches: MAIN
CVS tags: HEAD
Major change!
hash and search does not rely on each other.
context and voclink are now present in kernel.
words and marker can now defined without loading hash or search
marker went to extend.fs
word went to kernel/tools.fs
table goes to seperate file (at the moment)
glocals.fs and kernel/toolsext.fs are changed because of the change in the
wordlist-map-struct...
Attention: You can't recompile the code without new kernel-files!!!
jens

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

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