File:  [gforth] / gforth / hash.fs
Revision 1.1: download - view: text, annotated - select for diffs
Thu Jul 21 10:52:43 1994 UTC (27 years, 2 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Added dictionary hashing
Changed argument interpretation as documented
Made refill for DOS 20 times faster
Added m*/ and missing FP words.

    1: \ Hashed dictionaries                                  15jul94py
    2: 
    3: $80 Value Hashlen
    4: 
    5: Variable insRule        insRule on
    6: 
    7: \ Memory handling                                      15jul94py
    8: 
    9: Variable HashPointer
   10: 
   11: : hash-alloc ( addr -- addr )  dup @ 0= IF
   12:   Hashlen cells allocate throw over !
   13:   dup @ Hashlen cells erase THEN ;
   14: 
   15: \ DelFix and NewFix is from bigFORTH                   15jul94py
   16: 
   17: : DelFix ( addr root -- ) dup @ 2 pick ! ! ;
   18: : NewFix  ( root len # -- addr )
   19:   BEGIN  2 pick @ ?dup  0= WHILE  2dup * allocate throw
   20:          over 0 ?DO  dup 4 pick DelFix 2 pick +  LOOP  drop
   21:   REPEAT  >r drop r@ @ rot ! r@ swap erase r> ;
   22: 
   23: \ compute hash key                                     15jul94py
   24: 
   25: : hash ( addr len -- key )  (hashkey)
   26: \  tuck bounds  ?DO  I c@ toupper +  LOOP
   27:   Hashlen 1- and ;
   28: 
   29: : hash-find ( addr len wordlist -- nfa / false ) $C + @ >r
   30:   2dup hash cells r> + @ (hashfind) ;
   31: \  BEGIN  dup  WHILE
   32: \         2@ >r >r dup r@ cell+ c@ $1F and =
   33: \         IF  2dup r@ cell+ char+ capscomp 0=
   34: \	     IF  2drop r> rdrop  EXIT  THEN  THEN
   35: \	 rdrop r>
   36: \  REPEAT nip nip ;
   37: 
   38: \ hash vocabularies                                    16jul94py
   39: 
   40: : lastlink! ( addr link -- )
   41:   BEGIN  dup @ dup  WHILE  nip  REPEAT  drop ! ;
   42: 
   43: : (reveal ( addr voc -- )  $C + dup @ 0< IF  2drop EXIT  THEN
   44:   hash-alloc @ over cell+ count $1F and Hash cells + >r
   45:   HashPointer 8 $400 NewFix
   46:   tuck cell+ ! r> insRule @
   47:   IF  dup @ 2 pick ! !  ELSE  lastlink!  THEN ;
   48: 
   49: : hash-reveal ( -- )  (reveal) last?  IF
   50:   current @ (reveal  THEN ;
   51: 
   52: Create hashsearch  ' hash-find A,  ' hash-reveal A,  ' drop A,
   53: 
   54: : (initvoc ( addr -- )  cell+ dup @ 0< IF  drop EXIT  THEN
   55:   insRule @ >r  insRule off  hash-alloc
   56:   3 cells - hashsearch over cell+ ! dup
   57:   BEGIN  @ dup  WHILE  2dup swap (reveal  REPEAT
   58:   2drop  r> insRule ! ;
   59: 
   60: ' (initvoc IS 'initvoc
   61: 
   62: : addall  ( -- )  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: 

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