/prods/Cognitive/p4th/t_corex.fth

https://github.com/createuniverses/praxis · Forth · 226 lines · 181 code · 45 blank · 0 comment · 0 complexity · 527f26496371f741bae7e39c169a94ca 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. \ STUB because missing definition in pForth - FIXME
  9. : SAVE-INPUT ;
  10. : RESTORE-INPUT -1 ;
  11. TEST{
  12. \ ==========================================================
  13. T{ 1 2 3 }T{ 1 2 3 }T
  14. \ ----------------------------------------------------- .(
  15. T{ 27 .( IF YOU SEE THIS THEN .( WORKED!) }T{ 27 }T
  16. CR .( 1234 - SHOULD LINE UP WITH NEXT LINE.) CR 1234 8 .R CR
  17. T{ .( ) 987 .( TEST NULL STRING IN .( ) CR }T{ 987 }T
  18. \ ----------------------------------------------------- 0<>
  19. T{ 5 0<> }T{ TRUE }T
  20. T{ 0 0<> }T{ 0 }T
  21. T{ -1000 0<> }T{ TRUE }T
  22. \ ----------------------------------------------------- 2>R 2R> 2R@
  23. : T2>R ( -- .... )
  24. 17
  25. 20 5 2>R
  26. 19
  27. 2R@
  28. 37
  29. 2R>
  30. \ 2>R should be the equivalent of SWAP >R >R so this next construct
  31. \ should reduce to a SWAP.
  32. 88 77 2>R R> R>
  33. ;
  34. T{ T2>R }T{ 17 19 20 5 37 20 5 77 88 }T
  35. \ ----------------------------------------------------- :NONAME
  36. T{ :NONAME 100 50 + ; EXECUTE }T{ 150 }T
  37. \ ----------------------------------------------------- <>
  38. T{ 12345 12305 <> }T{ TRUE }T
  39. T{ HEX 98765432 98765432 DECIMAL <> }T{ 0 }T
  40. \ ----------------------------------------------------- ?DO
  41. : T?DO ( n -- sum_n ) 0 SWAP 1+ 0 ?DO i + LOOP ;
  42. T{ 0 T?DO }T{ 0 }T
  43. T{ 4 T?DO }T{ 10 }T
  44. \ ----------------------------------------------------- AGAIN
  45. : T.AGAIN ( n -- )
  46. BEGIN
  47. DUP .
  48. DUP 6 < IF EXIT THEN
  49. 1-
  50. AGAIN
  51. ;
  52. T{ 10 T.AGAIN CR }T{ 5 }T
  53. \ ----------------------------------------------------- C"
  54. : T.C" ( -- $STRING )
  55. C" x5&"
  56. ;
  57. T{ T.C" C@ }T{ 3 }T
  58. T{ T.C" COUNT DROP C@ }T{ CHAR x }T
  59. T{ T.C" COUNT DROP CHAR+ C@ }T{ CHAR 5 }T
  60. T{ T.C" COUNT DROP 2 CHARS + C@ }T{ CHAR & }T
  61. \ ----------------------------------------------------- CASE
  62. : T.CASE ( N -- )
  63. CASE
  64. 1 OF 101 ENDOF
  65. 27 OF 892 ENDOF
  66. 941 SWAP \ default
  67. ENDCASE
  68. ;
  69. T{ 1 T.CASE }T{ 101 }T
  70. T{ 27 T.CASE }T{ 892 }T
  71. T{ 49 T.CASE }T{ 941 }T
  72. \ ----------------------------------------------------- COMPILE,
  73. : COMPILE.SWAP ['] SWAP COMPILE, ; IMMEDIATE
  74. : T.COMPILE,
  75. 19 20 27 COMPILE.SWAP 39
  76. ;
  77. T{ T.COMPILE, }T{ 19 27 20 39 }T
  78. \ ----------------------------------------------------- CONVERT
  79. : T.CONVERT
  80. 0 S>D S" 1234xyz" DROP CONVERT
  81. >R
  82. D>S
  83. R> C@
  84. ;
  85. T{ T.CONVERT }T{ 1234 CHAR x }T
  86. \ ----------------------------------------------------- ERASE
  87. : T.COMMA.SEQ ( n -- , lay down N sequential bytes )
  88. 0 ?DO I C, LOOP
  89. ;
  90. CREATE T-ERASE-DATA 64 T.COMMA.SEQ
  91. T{ T-ERASE-DATA 8 + C@ }T{ 8 }T
  92. T{ T-ERASE-DATA 7 + 3 ERASE
  93. T{ T-ERASE-DATA 6 + C@ }T{ 6 }T
  94. T{ T-ERASE-DATA 7 + C@ }T{ 0 }T
  95. T{ T-ERASE-DATA 8 + C@ }T{ 0 }T
  96. T{ T-ERASE-DATA 9 + C@ }T{ 0 }T
  97. T{ T-ERASE-DATA 10 + C@ }T{ 10 }T
  98. \ ----------------------------------------------------- FALSE
  99. T{ FALSE }T{ 0 }T
  100. \ ----------------------------------------------------- HEX
  101. T{ HEX 10 DECIMAL }T{ 16 }T
  102. \ ----------------------------------------------------- MARKER
  103. : INDIC? ( <name> -- ifInDic , is the following word defined? )
  104. bl word find
  105. swap drop 0= 0=
  106. ;
  107. create FOOBAR
  108. MARKER MYMARK \ create word that forgets itself
  109. create GOOFBALL
  110. MYMARK
  111. T{ indic? foobar indic? mymark indic? goofball }T{ true false false }T
  112. \ ----------------------------------------------------- NIP
  113. T{ 33 44 55 NIP }T{ 33 55 }T
  114. \ ----------------------------------------------------- PARSE
  115. : T.PARSE ( char <string>char -- addr num )
  116. PARSE
  117. >R \ save length
  118. PAD R@ CMOVE \ move string to pad
  119. PAD R>
  120. ;
  121. T{ CHAR % T.PARSE wxyz% SWAP C@ }T{ 4 CHAR w }T
  122. \ ----------------------------------------------------- PICK
  123. T{ 13 12 11 10 2 PICK }T{ 13 12 11 10 12 }T
  124. \ ----------------------------------------------------- QUERY
  125. T{ ' QUERY 0<> }T{ TRUE }T
  126. \ ----------------------------------------------------- REFILL
  127. T{ ' REFILL 0<> }T{ TRUE }T
  128. \ ----------------------------------------------------- RESTORE-INPUT
  129. T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T \ EXPECTED FAILURE
  130. \ ----------------------------------------------------- ROLL
  131. T{ 15 14 13 12 11 10 0 ROLL }T{ 15 14 13 12 11 10 }T
  132. T{ 15 14 13 12 11 10 1 ROLL }T{ 15 14 13 12 10 11 }T
  133. T{ 15 14 13 12 11 10 2 ROLL }T{ 15 14 13 11 10 12 }T
  134. T{ 15 14 13 12 11 10 3 ROLL }T{ 15 14 12 11 10 13 }T
  135. T{ 15 14 13 12 11 10 4 ROLL }T{ 15 13 12 11 10 14 }T
  136. \ ----------------------------------------------------- SOURCE-ID
  137. T{ SOURCE-ID 0<> }T{ TRUE }T
  138. T{ : T.SOURCE-ID S" SOURCE-ID" EVALUATE ; T.SOURCE-ID }T{ -1 }T
  139. \ ----------------------------------------------------- SPAN
  140. T{ ' SPAN 0<> }T{ TRUE }T
  141. \ ----------------------------------------------------- TO VALUE
  142. 333 VALUE MY-VALUE
  143. T{ MY-VALUE }T{ 333 }T
  144. T{ 1000 TO MY-VALUE MY-VALUE }T{ 1000 }T
  145. : TEST.VALUE ( -- 19 100 )
  146. 100 TO MY-VALUE
  147. 19
  148. MY-VALUE
  149. ;
  150. T{ TEST.VALUE }T{ 19 100 }T
  151. \ ----------------------------------------------------- TRUE
  152. T{ TRUE }T{ 0 0= }T
  153. \ ----------------------------------------------------- TUCK
  154. T{ 44 55 66 TUCK }T{ 44 66 55 66 }T
  155. \ ----------------------------------------------------- U.R
  156. HEX CR .( ABCD4321 - SHOULD LINE UP WITH NEXT LINE.) CR
  157. ABCD4321 C U.R CR DECIMAL
  158. \ ----------------------------------------------------- U>
  159. T{ -5 3 U> }T{ TRUE }T
  160. T{ 10 8 U> }T{ TRUE }T
  161. \ ----------------------------------------------------- UNUSED
  162. T{ UNUSED 0> }T{ TRUE }T
  163. \ ----------------------------------------------------- WITHIN
  164. T{ 4 5 10 WITHIN }T{ 0 }T
  165. T{ 5 5 10 WITHIN }T{ TRUE }T
  166. T{ 9 5 10 WITHIN }T{ TRUE }T
  167. T{ 10 5 10 WITHIN }T{ 0 }T
  168. T{ 4 10 5 WITHIN }T{ TRUE }T
  169. T{ 5 10 5 WITHIN }T{ 0 }T
  170. T{ 9 10 5 WITHIN }T{ 0 }T
  171. T{ 10 10 5 WITHIN }T{ TRUE }T
  172. T{ -6 -5 10 WITHIN }T{ 0 }T
  173. T{ -5 -5 10 WITHIN }T{ TRUE }T
  174. T{ 9 -5 10 WITHIN }T{ TRUE }T
  175. T{ 10 -5 10 WITHIN }T{ 0 }T
  176. \ ----------------------------------------------------- [COMPILE]
  177. : T.[COMPILE].IF [COMPILE] IF ; IMMEDIATE
  178. : T.[COMPILE] 40 0> T.[COMPILE].IF 97 ELSE 53 THEN 97 = ;
  179. T{ T.[COMPILE] }T{ TRUE }T
  180. \ ----------------------------------------------------- \
  181. }TEST