home *** CD-ROM | disk | FTP | other *** search
/ Dream 52 / Amiga_Dream_52.iso / RiscOS / APP / DEVS / FORTH / WIMPFO.ZIP / !WimpForth / methhash < prev    next >
Text File  |  1995-12-08  |  2KB  |  74 lines
  1. \ PRIMHASH.F    primitive hash functions
  2.  
  3. \ -------------------- Find Name for Hashed Value --------------------
  4.  
  5. 16 #vocabulary hashed
  6.  
  7.  2 #vocabulary classes
  8. here ' classes >body -                  ( voc-pfa-size )
  9. 5 cells reserve                         ( extra for a class )
  10. constant voc-pfa-size
  11.  
  12. ' hashed vcfa>voc constant hash-wid
  13.  
  14. : unhash  ( hash-val -- addr len )
  15.         hash-wid voc#threads ( #threads ) 0
  16.         do      hash-wid i cells+
  17.                 begin   @ ?dup
  18.                 while   ( hash-val link-field )
  19.                         2dup cell+ ( link> ) >body @ =
  20.                         if      nip ( discard hash value )
  21.                                 l>name nfa-count ( addr len )
  22.                                 unloop exit
  23.                         then
  24.                 repeat
  25.         loop
  26.         drop S" Unknown" ;
  27.  
  28. : ?unhash  ( hash-val -- f1 )
  29.         hash-wid voc#threads ( #threads ) 0
  30.         do      hash-wid i cells+
  31.                 begin   @ ?dup
  32.                 while   ( hash-val link-field )
  33.                         2dup cell+ ( link> ) >body @ =
  34.                         if      2drop true
  35.                                 unloop exit
  36.                         then
  37.                 repeat
  38.         loop    drop false ;
  39.  
  40. 0 value obj-save
  41.  
  42. : .M0NAME       ( a1 -- )
  43.                 1 cells - @ unhash type ;
  44.  
  45. : .M1NAME       ( a1 a2 -- a3 )
  46.                 2 cells - @ unhash type
  47.                 cell+   ( a1 becomes a3 )   \ skip next cell also
  48.                 dup @ ?dup
  49.         if      obj-save cell - @           \ should use >CLASS, not yet there
  50.                 voc-pfa-size cell+ +        \ should use IFA,    not yet there
  51.                 begin   @ 2dup 3 cells+ @ =
  52.                         start/stop
  53.                 until   nip dup
  54.                 if      cell+ @ unhash space type
  55.                 else    drop ." ???"
  56.                 then    space
  57.         else    ."  self "
  58.         then    ;
  59.  
  60. : add-hash  ( addr len hash-val -- )
  61.         >r 2dup hash-wid search-wordlist
  62.         if
  63.                 r> 2drop 2drop  ( already found )
  64.         else
  65.                 current @ >r
  66.                 hash-wid current !
  67.                 "header
  68.                 r> current !
  69.                 docon ,
  70.                 r> ,
  71.         then ;
  72.  
  73.  
  74.