/fth/misc2.fth

https://github.com/philburk/pforth · Forth · 279 lines · 242 code · 37 blank · 0 comment · 25 complexity · 8c7a75d4056e96c0654a0c6f4ca078f6 MD5 · raw file

  1. \ @(#) misc2.fth 98/01/26 1.2
  2. \ Utilities for PForth extracted from HMSL
  3. \
  4. \ Author: Phil Burk
  5. \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
  6. \
  7. \ Permission to use, copy, modify, and/or distribute this
  8. \ software for any purpose with or without fee is hereby granted.
  9. \
  10. \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
  11. \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
  12. \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  13. \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  14. \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  15. \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
  16. \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  17. \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  18. \
  19. \ 00001 9/14/92 Added call, 'c w->s
  20. \ 00002 11/23/92 Moved redef of : to loadcom.fth
  21. anew task-misc2.fth
  22. : 'N ( <name> -- , make 'n state smart )
  23. bl word find
  24. IF
  25. state @
  26. IF namebase - ( make nfa relocatable )
  27. [compile] literal ( store nfa of word to be compiled )
  28. compile namebase+
  29. THEN
  30. THEN
  31. ; IMMEDIATE
  32. : ?LITERAL ( n -- , do literal if compiling )
  33. state @
  34. IF [compile] literal
  35. THEN
  36. ;
  37. : 'c ( <name> -- xt , state sensitive ' )
  38. ' ?literal
  39. ; immediate
  40. variable if-debug
  41. : ? ( address -- , fatch from address and print value )
  42. @ .
  43. ;
  44. decimal
  45. create msec-delay 10000 , ( default for SUN )
  46. : (MSEC) ( #msecs -- )
  47. 0
  48. do msec-delay @ 0
  49. do loop
  50. loop
  51. ;
  52. defer msec
  53. ' (msec) is msec
  54. : SHIFT ( val n -- val<<n )
  55. dup 0<
  56. IF negate arshift
  57. ELSE lshift
  58. THEN
  59. ;
  60. variable rand-seed here rand-seed !
  61. : random ( -- random_number )
  62. rand-seed @
  63. 31421 * 6927 +
  64. 65535 and dup rand-seed !
  65. ;
  66. : choose ( range -- random_number , in range )
  67. random * -16 shift
  68. ;
  69. : wchoose ( hi lo -- random_number )
  70. tuck - choose +
  71. ;
  72. \ sort top two items on stack.
  73. : 2sort ( a b -- a<b | b<a , largest on top of stack)
  74. 2dup >
  75. if swap
  76. then
  77. ;
  78. \ sort top two items on stack.
  79. : -2sort ( a b -- a>b | b>a , smallest on top of stack)
  80. 2dup <
  81. if swap
  82. then
  83. ;
  84. : barray ( #bytes -- ) ( index -- addr )
  85. create allot
  86. does> +
  87. ;
  88. : warray ( #words -- ) ( index -- addr )
  89. create 2* allot
  90. does> swap 2* +
  91. ;
  92. : array ( #cells -- ) ( index -- addr )
  93. create cell* allot
  94. does> swap cell* +
  95. ;
  96. : .bin ( n -- , print in binary )
  97. base @ binary swap . base !
  98. ;
  99. : .dec ( n -- )
  100. base @ decimal swap . base !
  101. ;
  102. : .hex ( n -- )
  103. base @ hex swap . base !
  104. ;
  105. : B->S ( c -- c' , sign extend byte )
  106. dup $ 80 and
  107. IF
  108. [ $ 0FF invert ] literal or
  109. ELSE
  110. $ 0FF and
  111. THEN
  112. ;
  113. : W->S ( 16bit-signed -- cell-signed )
  114. dup $ 8000 and
  115. IF
  116. [ $ 0FFFF invert ] literal or
  117. ELSE
  118. $ 0FFFF and
  119. THEN
  120. ;
  121. : WITHIN { n1 n2 n3 -- flag }
  122. n2 n3 <=
  123. IF
  124. n2 n1 <=
  125. n1 n3 < AND
  126. ELSE
  127. n2 n1 <=
  128. n1 n3 < OR
  129. THEN
  130. ;
  131. : MOVE ( src dst num -- )
  132. >r 2dup - 0<
  133. IF
  134. r> CMOVE>
  135. ELSE
  136. r> CMOVE
  137. THEN
  138. ;
  139. : ERASE ( caddr num -- )
  140. dup 0>
  141. IF
  142. 0 fill
  143. ELSE
  144. 2drop
  145. THEN
  146. ;
  147. : BLANK ( addr u -- , set memory to blank )
  148. DUP 0>
  149. IF
  150. BL FILL
  151. ELSE
  152. 2DROP
  153. THEN
  154. ;
  155. \ Obsolete but included for CORE EXT word set.
  156. : QUERY REFILL DROP ;
  157. VARIABLE SPAN
  158. : EXPECT accept span ! ;
  159. : TIB source drop ;
  160. : UNUSED ( -- unused , dictionary space )
  161. CODELIMIT HERE -
  162. ;
  163. : MAP ( -- , dump interesting dictionary info )
  164. ." Code Segment" cr
  165. ." CODEBASE = " codebase .hex cr
  166. ." HERE = " here .hex cr
  167. ." CODELIMIT = " codelimit .hex cr
  168. ." Compiled Code Size = " here codebase - . cr
  169. ." CODE-SIZE = " code-size @ . cr
  170. ." Code Room UNUSED = " UNUSED . cr
  171. ." Name Segment" cr
  172. ." NAMEBASE = " namebase .hex cr
  173. ." HEADERS-PTR @ = " headers-ptr @ .hex cr
  174. ." NAMELIMIT = " namelimit .hex cr
  175. ." CONTEXT @ = " context @ .hex cr
  176. ." LATEST = " latest .hex ." = " latest id. cr
  177. ." Compiled Name size = " headers-ptr @ namebase - . cr
  178. ." HEADERS-SIZE = " headers-size @ . cr
  179. ." Name Room Left = " namelimit headers-ptr @ - . cr
  180. ;
  181. \ Search for substring S2 in S1
  182. : SEARCH { addr1 cnt1 addr2 cnt2 | addr3 cnt3 flag -- addr3 cnt3 flag }
  183. \ ." Search for " addr2 cnt2 type ." in " addr1 cnt1 type cr
  184. \ if true, s1 contains s2 at addr3 with cnt3 chars remaining
  185. \ if false, s3 = s1
  186. addr1 -> addr3
  187. cnt1 -> cnt3
  188. cnt1 cnt2 < not
  189. IF
  190. cnt1 cnt2 - 1+ 0
  191. DO
  192. true -> flag
  193. cnt2 0
  194. ?DO
  195. addr2 i chars + c@
  196. addr1 i j + chars + c@ <> \ mismatch?
  197. IF
  198. false -> flag
  199. LEAVE
  200. THEN
  201. LOOP
  202. flag
  203. IF
  204. addr1 i chars + -> addr3
  205. cnt1 i - -> cnt3
  206. LEAVE
  207. THEN
  208. LOOP
  209. THEN
  210. addr3 cnt3 flag
  211. ;
  212. private{
  213. : env= ( c-addr u c-addr1 u1 x -- x true true | c-addr u false )
  214. { x } 2over compare 0= if 2drop x true true else false then
  215. ;
  216. : 2env= ( c-addr u c-addr1 u1 x y -- x y true true | c-addr u false )
  217. { x y } 2over compare 0= if 2drop x y true true else false then
  218. ;
  219. 0 invert constant max-u
  220. 0 invert 1 rshift constant max-n
  221. }private
  222. : ENVIRONMENT? ( c-addr u -- false | i*x true )
  223. s" /COUNTED-STRING" 255 env= if exit then
  224. s" /HOLD" 128 env= if exit then \ same as PAD
  225. s" /PAD" 128 env= if exit then
  226. s" ADDRESS-UNITS-BITS" 8 env= if exit then
  227. s" FLOORED" false env= if exit then
  228. s" MAX-CHAR" 255 env= if exit then
  229. s" MAX-D" max-n max-u 2env= if exit then
  230. s" MAX-N" max-n env= if exit then
  231. s" MAX-U" max-u env= if exit then
  232. s" MAX-UD" max-u max-u 2env= if exit then
  233. s" RETURN-STACK-CELLS" 512 env= if exit then \ DEFAULT_RETURN_DEPTH
  234. s" STACK-CELLS" 512 env= if exit then \ DEFAULT_USER_DEPTH
  235. \ FIXME: maybe define those:
  236. \ s" FLOATING-STACK"
  237. \ s" MAX-FLOAT"
  238. \ s" #LOCALS"
  239. \ s" WORDLISTS"
  240. 2drop false
  241. ;
  242. privatize