/fth/t_corex.fth

https://github.com/philburk/pforth · Forth · 334 lines · 263 code · 71 blank · 0 comment · 1 complexity · 1f9d6f4c9c8897948eb9c77b295c97cb MD5 · raw file

  1. \ @(#) t_corex.fth 98/03/16 1.2
  2. \ Test ANS Forth Core Extensions
  3. \
  4. \ Copyright 1994 3DO, Phil Burk
  5. INCLUDE? }T{ t_tools.fth
  6. ANEW TASK-T_COREX.FTH
  7. DECIMAL
  8. TEST{
  9. \ ==========================================================
  10. T{ 1 2 3 }T{ 1 2 3 }T
  11. \ ----------------------------------------------------- .(
  12. T{ 27 .( IF YOU SEE THIS THEN .( WORKED!) }T{ 27 }T
  13. CR .( 1234 - SHOULD LINE UP WITH NEXT LINE.) CR 1234 8 .R CR
  14. T{ .( ) 987 .( TEST NULL STRING IN .( ) CR }T{ 987 }T
  15. \ ----------------------------------------------------- 0<>
  16. T{ 5 0<> }T{ TRUE }T
  17. T{ 0 0<> }T{ 0 }T
  18. T{ -1000 0<> }T{ TRUE }T
  19. \ ----------------------------------------------------- 2>R 2R> 2R@
  20. : T2>R ( -- .... )
  21. 17
  22. 20 5 2>R
  23. 19
  24. 2R@
  25. 37
  26. 2R>
  27. \ 2>R should be the equivalent of SWAP >R >R so this next construct
  28. \ should reduce to a SWAP.
  29. 88 77 2>R R> R>
  30. ;
  31. T{ T2>R }T{ 17 19 20 5 37 20 5 77 88 }T
  32. \ ----------------------------------------------------- :NONAME
  33. T{ :NONAME 100 50 + ; EXECUTE }T{ 150 }T
  34. \ ----------------------------------------------------- <>
  35. T{ 12345 12305 <> }T{ TRUE }T
  36. T{ HEX 98765432 98765432 DECIMAL <> }T{ 0 }T
  37. \ ----------------------------------------------------- ?DO
  38. : T?DO ( n -- sum_n ) 0 SWAP 1+ 0 ?DO i + LOOP ;
  39. T{ 0 T?DO }T{ 0 }T
  40. T{ 4 T?DO }T{ 10 }T
  41. \ ----------------------------------------------------- AGAIN
  42. : T.AGAIN ( n -- )
  43. BEGIN
  44. DUP .
  45. DUP 6 < IF EXIT THEN
  46. 1-
  47. AGAIN
  48. ;
  49. T{ 10 T.AGAIN CR }T{ 5 }T
  50. \ ----------------------------------------------------- C"
  51. : T.C" ( -- $STRING )
  52. C" x5&"
  53. ;
  54. T{ T.C" C@ }T{ 3 }T
  55. T{ T.C" COUNT DROP C@ }T{ CHAR x }T
  56. T{ T.C" COUNT DROP CHAR+ C@ }T{ CHAR 5 }T
  57. T{ T.C" COUNT DROP 2 CHARS + C@ }T{ CHAR & }T
  58. \ ----------------------------------------------------- CASE
  59. : T.CASE ( N -- )
  60. CASE
  61. 1 OF 101 ENDOF
  62. 27 OF 892 ENDOF
  63. 941 SWAP \ default
  64. ENDCASE
  65. ;
  66. T{ 1 T.CASE }T{ 101 }T
  67. T{ 27 T.CASE }T{ 892 }T
  68. T{ 49 T.CASE }T{ 941 }T
  69. \ ----------------------------------------------------- COMPILE,
  70. : COMPILE.SWAP ['] SWAP COMPILE, ; IMMEDIATE
  71. : T.COMPILE,
  72. 19 20 27 COMPILE.SWAP 39
  73. ;
  74. T{ T.COMPILE, }T{ 19 27 20 39 }T
  75. \ ----------------------------------------------------- CONVERT
  76. : T.CONVERT
  77. 0 S>D S" 1234xyz" DROP CONVERT
  78. >R
  79. D>S
  80. R> C@
  81. ;
  82. T{ T.CONVERT }T{ 1234 CHAR x }T
  83. \ ----------------------------------------------------- ERASE
  84. : T.COMMA.SEQ ( n -- , lay down N sequential bytes )
  85. 0 ?DO I C, LOOP
  86. ;
  87. CREATE T-ERASE-DATA 64 T.COMMA.SEQ
  88. T{ T-ERASE-DATA 8 + C@ }T{ 8 }T
  89. T{ T-ERASE-DATA 7 + 3 ERASE
  90. T{ T-ERASE-DATA 6 + C@ }T{ 6 }T
  91. T{ T-ERASE-DATA 7 + C@ }T{ 0 }T
  92. T{ T-ERASE-DATA 8 + C@ }T{ 0 }T
  93. T{ T-ERASE-DATA 9 + C@ }T{ 0 }T
  94. T{ T-ERASE-DATA 10 + C@ }T{ 10 }T
  95. \ ----------------------------------------------------- FALSE
  96. T{ FALSE }T{ 0 }T
  97. \ ----------------------------------------------------- HEX
  98. T{ HEX 10 DECIMAL }T{ 16 }T
  99. \ ----------------------------------------------------- MARKER
  100. : INDIC? ( <name> -- ifInDic , is the following word defined? )
  101. bl word find
  102. swap drop 0= 0=
  103. ;
  104. create FOOBAR
  105. MARKER MYMARK \ create word that forgets itself
  106. create GOOFBALL
  107. MYMARK
  108. T{ indic? foobar indic? mymark indic? goofball }T{ true false false }T
  109. \ ----------------------------------------------------- NIP
  110. T{ 33 44 55 NIP }T{ 33 55 }T
  111. \ ----------------------------------------------------- PARSE
  112. : T.PARSE ( char <string>char -- addr num )
  113. PARSE
  114. >R \ save length
  115. PAD R@ CMOVE \ move string to pad
  116. PAD R>
  117. ;
  118. T{ CHAR % T.PARSE wxyz% SWAP C@ }T{ 4 CHAR w }T
  119. \ ----------------------------------------------------- PICK
  120. T{ 13 12 11 10 2 PICK }T{ 13 12 11 10 12 }T
  121. \ ----------------------------------------------------- QUERY
  122. T{ ' QUERY 0<> }T{ TRUE }T
  123. \ ----------------------------------------------------- REFILL
  124. T{ ' REFILL 0<> }T{ TRUE }T
  125. \ ----------------------------------------------------- RESTORE-INPUT
  126. T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T
  127. \ TESTING SAVE-INPUT and RESTORE-INPUT with a string source
  128. VARIABLE SI_INC 0 SI_INC !
  129. : SI1
  130. SI_INC @ >IN +!
  131. 15 SI_INC !
  132. ;
  133. : S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ;
  134. T{ S$ EVALUATE SI_INC @ }T{ 0 2345 15 }T
  135. \ ----------------------------------------------------- ROLL
  136. T{ 15 14 13 12 11 10 0 ROLL }T{ 15 14 13 12 11 10 }T
  137. T{ 15 14 13 12 11 10 1 ROLL }T{ 15 14 13 12 10 11 }T
  138. T{ 15 14 13 12 11 10 2 ROLL }T{ 15 14 13 11 10 12 }T
  139. T{ 15 14 13 12 11 10 3 ROLL }T{ 15 14 12 11 10 13 }T
  140. T{ 15 14 13 12 11 10 4 ROLL }T{ 15 13 12 11 10 14 }T
  141. \ ----------------------------------------------------- SOURCE-ID
  142. T{ SOURCE-ID 0<> }T{ TRUE }T
  143. T{ : T.SOURCE-ID S" SOURCE-ID" EVALUATE ; T.SOURCE-ID }T{ -1 }T
  144. \ ----------------------------------------------------- SPAN
  145. T{ ' SPAN 0<> }T{ TRUE }T
  146. \ ----------------------------------------------------- TO VALUE
  147. 333 VALUE MY-VALUE
  148. T{ MY-VALUE }T{ 333 }T
  149. T{ 1000 TO MY-VALUE MY-VALUE }T{ 1000 }T
  150. : TEST.VALUE ( -- 19 100 )
  151. 100 TO MY-VALUE
  152. 19
  153. MY-VALUE
  154. ;
  155. T{ TEST.VALUE }T{ 19 100 }T
  156. \ ----------------------------------------------------- TRUE
  157. T{ TRUE }T{ 0 0= }T
  158. \ ----------------------------------------------------- TUCK
  159. T{ 44 55 66 TUCK }T{ 44 66 55 66 }T
  160. \ ----------------------------------------------------- U.R
  161. HEX CR .( ABCD4321 - SHOULD LINE UP WITH NEXT LINE.) CR
  162. ABCD4321 C U.R CR DECIMAL
  163. \ ----------------------------------------------------- U>
  164. T{ -5 3 U> }T{ TRUE }T
  165. T{ 10 8 U> }T{ TRUE }T
  166. \ ----------------------------------------------------- UNUSED
  167. T{ UNUSED 0> }T{ TRUE }T
  168. \ ----------------------------------------------------- WITHIN
  169. T{ 4 5 10 WITHIN }T{ 0 }T
  170. T{ 5 5 10 WITHIN }T{ TRUE }T
  171. T{ 9 5 10 WITHIN }T{ TRUE }T
  172. T{ 10 5 10 WITHIN }T{ 0 }T
  173. T{ 4 10 5 WITHIN }T{ TRUE }T
  174. T{ 5 10 5 WITHIN }T{ 0 }T
  175. T{ 9 10 5 WITHIN }T{ 0 }T
  176. T{ 10 10 5 WITHIN }T{ TRUE }T
  177. T{ -6 -5 10 WITHIN }T{ 0 }T
  178. T{ -5 -5 10 WITHIN }T{ TRUE }T
  179. T{ 9 -5 10 WITHIN }T{ TRUE }T
  180. T{ 10 -5 10 WITHIN }T{ 0 }T
  181. \ ----------------------------------------------------- [COMPILE]
  182. : T.[COMPILE].IF [COMPILE] IF ; IMMEDIATE
  183. : T.[COMPILE] 40 0> T.[COMPILE].IF 97 ELSE 53 THEN 97 = ;
  184. T{ T.[COMPILE] }T{ TRUE }T
  185. \ ----------------------------------------------------- \
  186. \ .( TESTING DO +LOOP with large and small increments )
  187. \ Contributed by Andrew Haley
  188. 0 invert CONSTANT MAX-UINT
  189. 0 INVERT 1 RSHIFT CONSTANT MAX-INT
  190. 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT
  191. MAX-UINT 8 RSHIFT 1+ CONSTANT USTEP
  192. USTEP NEGATE CONSTANT -USTEP
  193. MAX-INT 7 RSHIFT 1+ CONSTANT STEP
  194. STEP NEGATE CONSTANT -STEP
  195. VARIABLE BUMP
  196. T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; }T{ }T
  197. T{ 0 MAX-UINT 0 USTEP GD8 }T{ 256 }T
  198. T{ 0 0 MAX-UINT -USTEP GD8 }T{ 256 }T
  199. T{ 0 MAX-INT MIN-INT STEP GD8 }T{ 256 }T
  200. T{ 0 MIN-INT MAX-INT -STEP GD8 }T{ 256 }T
  201. \ Two's complement arithmetic, wraps around modulo wordsize
  202. \ Only tested if the Forth system does wrap around, use of conditional
  203. \ compilation deliberately avoided
  204. MAX-INT 1+ MIN-INT = CONSTANT +WRAP?
  205. MIN-INT 1- MAX-INT = CONSTANT -WRAP?
  206. MAX-UINT 1+ 0= CONSTANT +UWRAP?
  207. 0 1- MAX-UINT = CONSTANT -UWRAP?
  208. : GD9 ( n limit start step f result -- )
  209. >R IF GD8 ELSE 2DROP 2DROP R@ THEN }T{ R> }T
  210. ;
  211. T{ 0 0 0 USTEP +UWRAP? 256 GD9
  212. T{ 0 0 0 -USTEP -UWRAP? 1 GD9
  213. T{ 0 MIN-INT MAX-INT STEP +WRAP? 1 GD9
  214. T{ 0 MAX-INT MIN-INT -STEP -WRAP? 1 GD9
  215. \ --------------------------------------------------------------------------
  216. \ .( TESTING DO +LOOP with maximum and minimum increments )
  217. : (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ;
  218. (-MI) CONSTANT -MAX-INT
  219. T{ 0 1 0 MAX-INT GD8 }T{ 1 }T
  220. T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8 }T{ 2 }T
  221. T{ 0 MAX-INT 0 MAX-INT GD8 }T{ 1 }T
  222. T{ 0 MAX-INT 1 MAX-INT GD8 }T{ 1 }T
  223. T{ 0 MAX-INT -1 MAX-INT GD8 }T{ 2 }T
  224. T{ 0 MAX-INT DUP 1- MAX-INT GD8 }T{ 1 }T
  225. T{ 0 MIN-INT 1+ 0 MIN-INT GD8 }T{ 1 }T
  226. T{ 0 MIN-INT 1+ -1 MIN-INT GD8 }T{ 1 }T
  227. T{ 0 MIN-INT 1+ 1 MIN-INT GD8 }T{ 2 }T
  228. T{ 0 MIN-INT 1+ DUP MIN-INT GD8 }T{ 1 }T
  229. \ ----------------------------------------------------------------------------
  230. \ .( TESTING number prefixes # $ % and 'c' character input )
  231. \ Adapted from the Forth 200X Draft 14.5 document
  232. VARIABLE OLD-BASE
  233. DECIMAL BASE @ OLD-BASE !
  234. T{ #1289 }T{ 1289 }T
  235. T{ #-1289 }T{ -1289 }T
  236. T{ $12eF }T{ 4847 }T
  237. T{ $-12eF }T{ -4847 }T
  238. T{ %10010110 }T{ 150 }T
  239. T{ %-10010110 }T{ -150 }T
  240. T{ 'z' }T{ 122 }T
  241. T{ 'Z' }T{ 90 }T
  242. \ Check BASE is unchanged
  243. T{ BASE @ OLD-BASE @ = }T{ TRUE }T
  244. \ Repeat in Hex mode
  245. 16 OLD-BASE ! 16 BASE !
  246. T{ #1289 }T{ 509 }T
  247. T{ #-1289 }T{ -509 }T
  248. T{ $12eF }T{ 12EF }T
  249. T{ $-12eF }T{ -12EF }T
  250. T{ %10010110 }T{ 96 }T
  251. T{ %-10010110 }T{ -96 }T
  252. T{ 'z' }T{ 7a }T
  253. T{ 'Z' }T{ 5a }T
  254. \ Check BASE is unchanged
  255. T{ BASE @ OLD-BASE @ = }T{ TRUE }T \ 2
  256. DECIMAL
  257. \ Check number prefixes in compile mode
  258. T{ : nmp #8327 $-2cbe %011010111 ''' ; nmp }T{ 8327 -11454 215 39 }T
  259. \ ----------------------------------------------------- ENVIRONMENT?
  260. T{ s" unknown-query-string" ENVIRONMENT? }T{ FALSE }T
  261. T{ s" MAX-CHAR" ENVIRONMENT? }T{ 255 TRUE }T
  262. T{ s" ADDRESS-UNITS-BITS" ENVIRONMENT? }T{ 8 TRUE }T
  263. }TEST