File:  [gforth] / gforth / hash.fs
Revision 1.33: download - view: text, annotated - select for diffs
Sun Mar 9 15:16:50 2003 UTC (16 years, 8 months ago) by anton
Branches: MAIN
CVS tags: v0-6-2, v0-6-1, v0-6-0, HEAD
updated copyright years

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

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