Annotation of gforth/hash.fs, revision 1.1

1.1     ! pazsan      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>