Return to hash.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/hash.fs, revision 1.2

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: \  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: 
1.2     ! anton      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 ! ;
1.1       pazsan     64: 
                     65: ' (initvoc IS 'initvoc
                     66: 
1.2     ! anton      67: : addall  ( -- )
        !            68:     voclink
        !            69:     BEGIN  @ dup @  WHILE  dup (initvoc  REPEAT  drop ;
1.1       pazsan     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: 
1.2     ! anton      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 - ;