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