home *** CD-ROM | disk | FTP | other *** search
/ ftp.whtech.com / ftp.whtech.com.7z / ftp.whtech.com / emulators / v9t9 / linux / sources / V9t9 / tools / Forth / dict.fs < prev    next >
Encoding:
FORTH Source  |  2006-10-19  |  3.9 KB  |  209 lines
  1.  
  2. \    Dictionary words... these cover memory spaces, threading and compiler issues
  3. \    related to structure of the dictionary.
  4. \
  5.  
  6. $1F constant dict-name-mask
  7. $40 constant dict-name-immed
  8. $80 constant dict-name-smudge
  9.  
  10. \    \\\\\\\\\\\\\\
  11.  
  12. \ too damn slow and memory hogging
  13. 0 [if]
  14. \    Wordlist stuff.
  15. \
  16. \    We will keep the link field and name field in the 
  17. \    data/code space as in Forth-83, but will supplement
  18. \    this with a hash table.
  19. \
  20. \    The hash table is indexed by a key derived from the
  21. \    name of the word, and divided into N buckets of M-1
  22. \    entries each.  The M-1 entry is 0 for the end of the
  23. \    bucket chain or points to a new chain.  The ROM
  24. \    dictionary must know the starting point for the RAM
  25. \    hash buckets so there may be a unified searching
  26. \    algorithm.
  27. \
  28. \    When defining new words, we will overwrite existing
  29. \    entries pointing to the same name.
  30.  
  31. 1 include commonhash.fs
  32.  
  33. \ set up main wordlist
  34. [[ FORTH-wordlis @ ]] constant FORTH-WORDLIST
  35.  
  36. [then]
  37.  
  38. \    \\\\\\\\\\\\\\
  39.  
  40. \    Custom dictionary stuff
  41.  
  42. : nfa>xt
  43.     1 traverse
  44. ;
  45.  
  46. : xt>nfa
  47.     -1 traverse
  48. ;
  49.  
  50. : nfa>imm?    ( nfa -- t/f )
  51.     c@ dict-name-immed and 0<>
  52. ;
  53.  
  54. : lfa>nfa
  55.     2+
  56. ;
  57.  
  58. : id.        ( nfa -- )
  59.     count $1f and type
  60. ;
  61.  
  62. $1F constant width        \ max length of a name
  63.  
  64. \    \\\\\\\\\\\\\\\\\
  65.  
  66. \    dictionary words
  67.  
  68. [IFUNDEF] DP
  69. User DP
  70. [THEN]
  71.  
  72. [IFUNDEF] '
  73. : '    
  74. \   Skip leading space delimiters. Parse name delimited by a space. Find name and return xt, the execution token for name. An
  75. \   ambiguous condition exists if name is not found.
  76. \
  77. \   Similarly, the use of ' and ['] with compiling words is unclear if the precise compilation behavior of those words is not
  78. \   specified, so ANS Forth does not permit a Standard Program to use ' or ['] with compiling words.
  79.  
  80.     bl word    find 
  81.     0= if count type ." not found" 0 then        \ !!!
  82. ;
  83. [THEN]
  84.  
  85. [IFUNDEF] ,
  86. : ,
  87. \   Reserve one cell of data space and store x in the cell. If the data-space pointer is aligned when , begins execution, it
  88. \   will remain aligned when , finishes execution. An ambiguous condition exists if the data-space pointer is not aligned
  89. \   prior to execution of ,.
  90.      here ! #cell dp +!    
  91. ;
  92. [THEN]
  93.  
  94. [IFUNDEF] >BODY
  95. : >BODY
  96. \        ( xt -- a-addr )
  97. \   a-addr is the data-field address corresponding to xt. An ambiguous condition exists if xt is not for a word defined via
  98. \   CREATE.
  99.     3 cells +
  100. ;
  101. [THEN]
  102.  
  103. [IFUNDEF] ALIGN
  104. : ALIGN
  105.     here aligned dp !
  106. ;
  107. [THEN]
  108.  
  109. [IFUNDEF] ALIGNED
  110. : ALIGNED    ( addr -- addr )
  111.     #cell  1-  swap over +  swap and
  112. ;
  113. [THEN]
  114.  
  115. [IFUNDEF] ALLOT
  116. : ALLOT
  117.     here + dp !
  118. ;
  119. [THEN]
  120.  
  121. [IFUNDEF] C,
  122. : C,
  123.     here c!  0 char+  dp +!
  124. ;
  125. [THEN]
  126.  
  127. [IFUNDEF] FIND
  128. : FIND    \ ( c-addr -- c-addr 0  |  xt 1  |  xt -1 )
  129. \   Find the definition named in the counted string at c-addr. If the definition is not found after searching all the word
  130. \   lists in the search order, return c-addr and zero. If the definition is found, return xt. If the definition is immediate,
  131. \   also return one (1); otherwise also return minus-one (-1). For a given string, the values returned by FIND while compiling
  132. \   may differ from those returned while not compiling.
  133.  
  134. [ 1 [if] ]
  135.     latest            \ !!! need real wordlist
  136.     (find)            \ ( c-addr 0 | nfa 1 )
  137.  
  138. [ [else] ]
  139.  
  140. \    Use hash table
  141.     forth-wordlist    \ !!! need latest wordlist
  142.     hash>find
  143. \    over .
  144.  
  145. [ [then] ]
  146.  
  147.     if
  148.         dup nfa>xt 
  149.         swap c@ 
  150.         dict-name-immed and if 1 else -1 then
  151.     else
  152.         0
  153.     then
  154. ;
  155. [THEN]
  156. : wordtofind s" _2*" ;
  157. test" find hex 21 wordtofind pad swap cmove pad 2 over c! find 2dup . . if execute 42 = else 0 then decimal "
  158.  
  159. [IFUNDEF] HERE
  160. : HERE
  161.     dp @
  162. ;
  163. [THEN]
  164.  
  165. [IFUNDEF] [']
  166. : [']
  167.     ' ' compile,    
  168. ; immediate
  169. [THEN]
  170.  
  171. [IFUNDEF] IMMEDIATE
  172. : IMMEDIATE
  173.     latest lfa>nfa dup c@ dict-name-immed or swap c!
  174. ;
  175. [THEN]
  176.  
  177. [IFUNDEF] UNUSED
  178. : UNUSED
  179.     0 here -
  180. ;
  181. [THEN]
  182.  
  183. [IFUNDEF] WORDS
  184. : WORDS
  185.     latest        \ !!! need real wordlist
  186.     begin
  187.         dup lfa>nfa id. space
  188.         @ dup
  189.         0= (pause?) or
  190.     until
  191.     drop
  192. ;
  193. [THEN]
  194.  
  195. has? profiling [if]
  196. : prof
  197.     latest        \ !!! need real wordlist
  198.     begin
  199.         @ dup
  200.     while
  201.         dup lfa>nfa
  202.         dup    nfa>xt #cell - @ @ 5 .r space
  203.             id. cr
  204.     repeat
  205.     drop
  206. ;
  207. [then]
  208.  
  209.