File:  [gforth] / gforth / hash.fs
Revision 1.2: download - view: text, annotated - select for diffs
Thu Aug 25 15:25:27 1994 UTC (27 years, 1 month ago) by anton
Branches: MAIN
CVS tags: HEAD
make now generates both images
the image names were changed
added C-level support for deferred words (dodefer)
made 2>r 2r> 2r@ 2rdrop primitives
some tuning of the outer interpreter; eliminated many words based on
 counted strings
Replaced the hash function with one that works better for larger tables

    1: \ Hashed dictionaries                                  15jul94py
    2: 
    3: 7 value hashbits
    4: 1 hashbits lshift Value Hashlen
    5: 
    6: Variable insRule        insRule on
    7: 
    8: \ Memory handling                                      15jul94py
    9: 
   10: Variable HashPointer
   11: 
   12: : hash-alloc ( addr -- addr )  dup @ 0= IF
   13:   Hashlen cells allocate throw over !
   14:   dup @ Hashlen cells erase THEN ;
   15: 
   16: \ DelFix and NewFix is from bigFORTH                   15jul94py
   17: 
   18: : DelFix ( addr root -- ) dup @ 2 pick ! ! ;
   19: : NewFix  ( root len # -- addr )
   20:   BEGIN  2 pick @ ?dup  0= WHILE  2dup * allocate throw
   21:          over 0 ?DO  dup 4 pick DelFix 2 pick +  LOOP  drop
   22:   REPEAT  >r drop r@ @ rot ! r@ swap erase r> ;
   23: 
   24: \ compute hash key                                     15jul94py
   25: 
   26: : hash ( addr len -- key )
   27:     hashbits (hashkey1) ;
   28: \   (hashkey)
   29: \   Hashlen 1- and ;
   30: 
   31: 
   32: : hash-find ( addr len wordlist -- nfa / false )
   33:     $C + @ >r
   34:     2dup hash cells r> + @ (hashfind) ;
   35: \  BEGIN  dup  WHILE
   36: \         2@ >r >r dup r@ cell+ c@ $1F and =
   37: \         IF  2dup r@ cell+ char+ capscomp 0=
   38: \	     IF  2drop r> rdrop  EXIT  THEN  THEN
   39: \	 rdrop r>
   40: \  REPEAT nip nip ;
   41: 
   42: \ hash vocabularies                                    16jul94py
   43: 
   44: : lastlink! ( addr link -- )
   45:   BEGIN  dup @ dup  WHILE  nip  REPEAT  drop ! ;
   46: 
   47: : (reveal ( addr voc -- )  $C + dup @ 0< IF  2drop EXIT  THEN
   48:   hash-alloc @ over cell+ count $1F and Hash cells + >r
   49:   HashPointer 8 $400 NewFix
   50:   tuck cell+ ! r> insRule @
   51:   IF  dup @ 2 pick ! !  ELSE  lastlink!  THEN ;
   52: 
   53: : hash-reveal ( -- )  (reveal) last?  IF
   54:   current @ (reveal  THEN ;
   55: 
   56: Create hashsearch  ' hash-find A,  ' hash-reveal A,  ' drop A,
   57: 
   58: : (initvoc ( addr -- )
   59:     cell+ dup @ 0< IF  drop EXIT  THEN
   60:     insRule @ >r  insRule off  hash-alloc
   61:     3 cells - hashsearch over cell+ ! dup
   62:     BEGIN  @ dup  WHILE  2dup swap (reveal  REPEAT
   63:     2drop  r> insRule ! ;
   64: 
   65: ' (initvoc IS 'initvoc
   66: 
   67: : addall  ( -- )
   68:     voclink
   69:     BEGIN  @ dup @  WHILE  dup (initvoc  REPEAT  drop ;
   70: 
   71: \ Hash-Find                                            01jan93py
   72: 
   73: addall          \ Baum aufbauen
   74: \ Baumsuche ist installiert.
   75: 
   76: : .words  ( -- )
   77:   base @ >r hex context @ 3 cells +  HashLen 0
   78:   DO  cr  i 2 .r ." : " dup @ i cells +
   79:       BEGIN  @ dup  WHILE
   80:              dup cell+ @ .name  REPEAT  drop
   81:   LOOP  drop r> base ! ;
   82: 
   83: \ \ this stuff is for evaluating the hash function
   84: \ : square dup * ;
   85: 
   86: \ : countwl  ( -- sum sumsq )
   87: \     \ gives the number of words in the current wordlist and the sum of
   88: \     \ squares for the sublist lengths
   89: \     0 0
   90: \     context @ 3 cells + @ hashlen cells over + swap DO
   91: \ 	0 i BEGIN
   92: \ 	    @ dup WHILE
   93: \ 	    swap 1+ swap
   94: \ 	REPEAT
   95: \ 	drop
   96: \ 	swap over square +
   97: \ 	>r + r>
   98: \ 	1 cells
   99: \     +LOOP ;
  100: 
  101: \ : chisq ( -- n )
  102: \     \ n should have about the same size as hashlen
  103: \     countwl hashlen 2 pick */ swap - ;

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