Return to hash.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/hash.fs, revision 1.3

1.1       pazsan      1: \ Hashed dictionaries                                  15jul94py
                      2: 
1.2       anton       3: 7 value hashbits
                      4: 1 hashbits lshift Value Hashlen
1.1       pazsan      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: 
1.2       anton      26: : hash ( addr len -- key )
                     27:     hashbits (hashkey1) ;
                     28: \   (hashkey)
                     29: \   Hashlen 1- and ;
1.1       pazsan     30: 
1.2       anton      31: 
                     32: : hash-find ( addr len wordlist -- nfa / false )
                     33:     $C + @ >r
                     34:     2dup hash cells r> + @ (hashfind) ;
1.1       pazsan     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: 
1.2       anton      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 ! ;
1.1       pazsan     58: 
                     59: ' (initvoc IS 'initvoc
                     60: 
1.2       anton      61: : addall  ( -- )
                     62:     voclink
                     63:     BEGIN  @ dup @  WHILE  dup (initvoc  REPEAT  drop ;
1.1       pazsan     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: 
1.2       anton      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 - ;