home *** CD-ROM | disk | FTP | other *** search
/ ftp.whtech.com / ftp.whtech.com.7z / ftp.whtech.com / emulators / v9t9 / linux / sources / V9t9 / tools / Forth / commonhash.fs < prev    next >
Encoding:
FORTH Source  |  2006-10-19  |  3.0 KB  |  187 lines
  1.  
  2. \
  3. \    Dictionary hashing
  4. \
  5.  
  6.  
  7. \    Hash index is MOD'ded by this
  8. \ &17 constant hash-buckets
  9. &59 constant hash-buckets
  10.  
  11. \    Each bucket has this many entries;
  12. \    last one points to next bucket in chain
  13. &16 constant hash-bucket-size
  14.  
  15.  
  16. \    Each entry has pointer to XT
  17. \    which can be used to find the name again
  18.  
  19. : hash    ( caddr u -- idx )
  20. \    .s
  21. \    2dup ." Hashing: " type
  22.     [char] [ emit
  23.     0 swap            \ TOS is counter
  24.     0 ?do
  25.         1 cshift
  26.         over i + 
  27.         c@ dup 
  28.         [char] a [char] z within if
  29.            $20 -
  30.         then
  31. \ [ order ] .s cr        
  32.         XOR     
  33.     loop
  34.     0 hash-buckets UM/MOD drop    \ select bucket (unsigned mod)
  35.     nip                    \ lose caddr
  36.     [char] ] emit
  37. \    dup ." =" . cr
  38. ;
  39.  
  40. \    Allocate new bucket and store pointer at ptr
  41. \
  42. : bucket-allot ( ptr -- )
  43. \    ." allocating new bucket from " dup . cr
  44.     T $aa55 , here hash-bucket-size cells dup allot 
  45.     over swap erase
  46. \    dup ." -> " . 
  47.     swap 
  48.     ! H
  49. ;
  50.  
  51. \    Point to end of a chain of buckets
  52. \    bucket will never be 0 on entry.
  53. order
  54. : chain>end    ( bucket -- entry )
  55. \    ." bucket>end" cr
  56. \  .s    dup 100 dump
  57. \    .s
  58.     begin
  59.         dup     \ save original bucket
  60.         hash-bucket-size 1- T cells H +  \ point to end
  61.            dup 
  62. \        .s 
  63.         T @ H      \ if non-NULL, we filled the bucket
  64.     while
  65. \    ." next bucket..." dup . cr
  66.         nip T @ H    \ point to new bucket now
  67.     repeat
  68.  
  69.     \ scan list for empty spot
  70.     ( last-bucket last-bucket-end-ptr )
  71. \ .s
  72.     swap begin
  73.         dup T @ H 
  74.     while
  75.         T cell+ H
  76.     repeat
  77. \ .s
  78.     \ must terminate in 0...hash-bucket-size - 1
  79.     \ since the next-ptr is 0
  80.     ( last-bucket-end-ptr last-bucket-entry )
  81.  
  82.     \ now see if we're pointing to next ptr
  83.     2dup = if
  84.         bucket-allot
  85.         T @ H
  86.     else
  87.         nip
  88.     then
  89. \    .s
  90. ;
  91.  
  92. : >bucket    ( wl idx -- bucket )
  93.     hash-bucket-size T cells H * +    \ pointer to bucket
  94. ;
  95.  
  96. \    Find empty entry for string
  97. : hash>new ( wl caddr u -- entry )
  98.     hash >bucket
  99.     chain>end
  100. ;
  101.  
  102.  [if]
  103.  
  104. \    Search one bucket for a match
  105. : match-entry     ( caddr xt -- 1 | 0 )
  106.     dup if
  107.         \ xt>nfa 
  108.         \ dup id. 
  109.         (nfa=)
  110.     else
  111.         2drop 0
  112.     then
  113. ;
  114.  
  115. : bucket>find    ( caddr bucketptr -- xt 1 | bucketptr 0 )
  116. \    ." bucket>find" .s cr
  117.     hash-bucket-size 1- cells over + swap do
  118.         ( caddr )
  119.         dup  i @  match-entry
  120.         if 
  121.             drop  
  122.             i @ 
  123.             1 
  124.             unloop 
  125.         \    .s 
  126.             exit 
  127.         then
  128.         T cell H
  129.     +loop
  130.     drop 0
  131. ;
  132.  
  133. \    Find an entry in the hash chain
  134. : chain>find    ( caddr bucket -- entry 1 | 0 )
  135. \    ." chain>find" .s cr
  136.  
  137.     \ scan list for match
  138.     begin
  139.         2dup bucket>find       ( caddr bucket : bucketptr 0 | xt 1 )
  140.         if 
  141.             nip nip 1 
  142. \            .s 
  143.             exit
  144.         else
  145.             T hash-bucket-size 1- cells + @ H
  146.             dup 0= \ .s
  147.         then
  148.     until
  149.     drop 0
  150. ;
  151.  
  152. : hash>find ( caddr wl -- entry nfa )
  153.     >r dup count hash r> swap >bucket
  154.     ( caddr bucket ) 
  155.     chain>find
  156. \    .s
  157. ;
  158.  
  159. \ \\\\\\\\\\\\\\\\\\\\\\\
  160.  
  161. \    List words
  162.  
  163. [IFUNDEF] WORDS
  164. \ use hash list for testing
  165. : WORDS
  166.     forth-wordlist
  167.     hash-buckets 0 do
  168.         dup i hash-bucket-size cells * +
  169.         hash-bucket-size 1- 0 do
  170.             dup i cells + @
  171.             ?dup if  \ ." [" dup . ." ]"
  172.                 \ xt>nfa 
  173.                 id. space
  174.             then
  175.         loop
  176.         drop
  177.     loop
  178.     drop
  179. ;
  180. [ENDIF]
  181.  
  182. : eval-me
  183.     s" : test 10 0 DO 10 0 DO I J + DUP 9 = IF LEAVE THEN KEY? IF KEY EMIT ELSE $2A EMIT THEN LOOP CR LOOP ;"
  184. ;
  185.  
  186. [then]
  187.