File:  [gforth] / gforth / hash.fs
Revision 1.38: download - view: text, annotated - select for diffs
Sun Dec 6 23:00:03 2009 UTC (14 years, 3 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Added history printing function in the commented out evaluation section

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

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