Return to hash.fs CVS log

Up to [gforth] / gforth

Added forth variants for primitives
Added a generator for forth primitives
Cleaned up some minor errors
Changed names of local access (was cell size dependent)
Where is "getopt.h"???!? Added tiny workaround. Where is getopt_long?

    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: 
   36: \ hash vocabularies                                    16jul94py
   37: 
   38: : lastlink! ( addr link -- )
   39:   BEGIN  dup @ dup  WHILE  nip  REPEAT  drop ! ;
   40: 
   41: : (reveal ( addr voc -- )  $C + dup @ 0< IF  2drop EXIT  THEN
   42:   hash-alloc @ over cell+ count $1F and Hash cells + >r
   43:   HashPointer 8 $400 NewFix
   44:   tuck cell+ ! r> insRule @
   45:   IF  dup @ 2 pick ! !  ELSE  lastlink!  THEN ;
   46: 
   47: : hash-reveal ( -- )  (reveal) last?  IF
   48:   current @ (reveal  THEN ;
   49: 
   50: Create hashsearch  ' hash-find A,  ' hash-reveal A,  ' drop A,
   51: 
   52: : (initvoc ( addr -- )
   53:     cell+ dup @ 0< IF  drop EXIT  THEN
   54:     insRule @ >r  insRule off  hash-alloc
   55:     3 cells - hashsearch over cell+ ! dup
   56:     BEGIN  @ dup  WHILE  2dup swap (reveal  REPEAT
   57:     2drop  r> insRule ! ;
   58: 
   59: ' (initvoc IS 'initvoc
   60: 
   61: : addall  ( -- )
   62:     voclink
   63:     BEGIN  @ dup @  WHILE  dup (initvoc  REPEAT  drop ;
   64: 
   65: \ Hash-Find                                            01jan93py
   66: 
   67: addall          \ Baum aufbauen
   68: \ Baumsuche ist installiert.
   69: 
   70: : .words  ( -- )
   71:   base @ >r hex context @ 3 cells +  HashLen 0
   72:   DO  cr  i 2 .r ." : " dup @ i cells +
   73:       BEGIN  @ dup  WHILE
   74:              dup cell+ @ .name  REPEAT  drop
   75:   LOOP  drop r> base ! ;
   76: 
   77: \ \ this stuff is for evaluating the hash function
   78: \ : square dup * ;
   79: 
   80: \ : countwl  ( -- sum sumsq )
   81: \     \ gives the number of words in the current wordlist and the sum of
   82: \     \ squares for the sublist lengths
   83: \     0 0
   84: \     context @ 3 cells + @ hashlen cells over + swap DO
   85: \ 	0 i BEGIN
   86: \ 	    @ dup WHILE
   87: \ 	    swap 1+ swap
   88: \ 	REPEAT
   89: \ 	drop
   90: \ 	swap over square +
   91: \ 	>r + r>
   92: \ 	1 cells
   93: \     +LOOP ;
   94: 
   95: \ : chisq ( -- n )
   96: \     \ n should have about the same size as hashlen
   97: \     countwl hashlen 2 pick */ swap - ;