/anstests/toolstest.fth

https://github.com/jamesbowman/swapforth · Forth · 319 lines · 255 code · 64 blank · 0 comment · 8 complexity · b85772f9c0630b92cf5bbfd4b244f662 MD5 · raw file

  1. \ To test some of the ANS Forth Programming Tools and extension wordset
  2. \ This program was written by Gerry Jackson in 2006, with contributions from
  3. \ others where indicated, and is in the public domain - it can be distributed
  4. \ and/or modified in any way but please retain this notice.
  5. \ This program is distributed in the hope that it will be useful,
  6. \ but WITHOUT ANY WARRANTY; without even the implied warranty of
  7. \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  8. \ The tests are not claimed to be comprehensive or correct
  9. \ ------------------------------------------------------------------------------
  10. \ Version 0.11 25 April Added tests for N>R NR> SYNONYM TRAVERSE-WORDLIST
  11. \ NAME>COMPILE NAME>INTERPRET NAME>STRING
  12. \ 0.6 1 April 2012 Tests placed in the public domain.
  13. \ Further tests on [IF] [ELSE] [THEN]
  14. \ 0.5 30 November 2009 <true> and <false> replaced with TRUE and FALSE
  15. \ 0.4 6 March 2009 ENDIF changed to THEN. {...} changed to T{...}T
  16. \ 0.3 20 April 2007 ANS Forth words changed to upper case
  17. \ 0.2 30 Oct 2006 updated following GForth test to avoid
  18. \ changing stack depth during a colon definition
  19. \ 0.1 Oct 2006 First version released
  20. \ ------------------------------------------------------------------------------
  21. \ The tests are based on John Hayes test program
  22. \ Words tested in this file are:
  23. \ AHEAD [IF] [ELSE] [THEN] CS-PICK CS-ROLL [DEFINED] [UNDEFINED]
  24. \ N>R NR> SYNONYM TRAVERSE-WORDLIST NAME>COMPILE NAME>INTERPRET
  25. \ NAME>STRING
  26. \
  27. \ Words not tested:
  28. \ .S ? DUMP SEE WORDS
  29. \ ;CODE ASSEMBLER BYE CODE EDITOR FORGET STATE
  30. \ ------------------------------------------------------------------------------
  31. \ Assumptions and dependencies:
  32. \ - tester.fr or ttester.fs has been loaded prior to this file
  33. \ - testing TRAVERSE-WORDLIST uses WORDLIST SEARCH-WORDLIST GET-CURRENT
  34. \ SET-CURRENT and FORTH-WORDLIST from the Search-order word set
  35. \ ------------------------------------------------------------------------------
  36. DECIMAL
  37. \ ------------------------------------------------------------------------------
  38. TESTING AHEAD
  39. T{ : PT1 AHEAD 1111 2222 THEN 3333 ; -> }T
  40. T{ PT1 -> 3333 }T
  41. \ ------------------------------------------------------------------------------
  42. TESTING [IF] [ELSE] [THEN]
  43. T{ TRUE [IF] 111 [ELSE] 222 [THEN] -> 111 }T
  44. T{ FALSE [IF] 111 [ELSE] 222 [THEN] -> 222 }T
  45. T{ TRUE [IF] 1 \ Code spread over more than 1 line
  46. 2
  47. [ELSE]
  48. 3
  49. 4
  50. [THEN] -> 1 2 }T
  51. T{ FALSE [IF]
  52. 1 2
  53. [ELSE]
  54. 3 4
  55. [THEN] -> 3 4 }T
  56. T{ TRUE [IF] 1 TRUE [IF] 2 [ELSE] 3 [THEN] [ELSE] 4 [THEN] -> 1 2 }T
  57. T{ FALSE [IF] 1 TRUE [IF] 2 [ELSE] 3 [THEN] [ELSE] 4 [THEN] -> 4 }T
  58. T{ TRUE [IF] 1 FALSE [IF] 2 [ELSE] 3 [THEN] [ELSE] 4 [THEN] -> 1 3 }T
  59. T{ FALSE [IF] 1 FALSE [IF] 2 [ELSE] 3 [THEN] [ELSE] 4 [THEN] -> 4 }T
  60. \ ------------------------------------------------------------------------------
  61. TESTING immediacy of [IF] [ELSE] [THEN]
  62. T{ : PT2 [ 0 ] [IF] 1111 [ELSE] 2222 [THEN] ; PT2 -> 2222 }T
  63. T{ : PT3 [ -1 ] [IF] 3333 [ELSE] 4444 [THEN] ; PT3 -> 3333 }T
  64. : PT9 BL WORD FIND ;
  65. T{ PT9 [IF] NIP -> 1 }T
  66. T{ PT9 [ELSE] NIP -> 1 }T
  67. T{ PT9 [THEN] NIP -> 1 }T
  68. \ -----------------------------------------------------------------------------
  69. TESTING [IF] and [ELSE] carry out a text scan by parsing and discarding words
  70. \ so that an [ELSE] or [THEN] in a comment or string is recognised
  71. : PT10 REFILL DROP REFILL DROP ;
  72. T{ 0 [IF] \ WORDS IGNORED UP TO [ELSE] 2
  73. [THEN] -> 2 }T
  74. T{ -1 [IF] 2 [ELSE] 3 S" [THEN] 4 PT10 IGNORED TO END OF LINE"
  75. [THEN] \ PRECAUTION IN CASE [THEN] IN STRING ISN'T RECOGNISED
  76. -> 2 4 }T
  77. \ ------------------------------------------------------------------------------
  78. TESTING CS-PICK and CS-ROLL
  79. \ Test pt5 based on example in ANS document p 176.
  80. : ?REPEAT
  81. 0 CS-PICK POSTPONE UNTIL
  82. ; IMMEDIATE
  83. VARIABLE PT4
  84. T{ : PT5 ( N1 -- )
  85. PT4 !
  86. BEGIN
  87. -1 PT4 +!
  88. PT4 @ 4 > 0= ?REPEAT \ BACK TO BEGIN IF FALSE
  89. 111
  90. PT4 @ 3 > 0= ?REPEAT
  91. 222
  92. PT4 @ 2 > 0= ?REPEAT
  93. 333
  94. PT4 @ 1 =
  95. UNTIL
  96. ; -> }T
  97. T{ 6 PT5 -> 111 111 222 111 222 333 111 222 333 }T
  98. T{ : ?DONE POSTPONE IF 1 CS-ROLL ; IMMEDIATE -> }T \ Same as WHILE
  99. T{ : PT6
  100. >R
  101. BEGIN
  102. R@
  103. ?DONE
  104. R@
  105. R> 1- >R
  106. REPEAT
  107. R> DROP
  108. ; -> }T
  109. T{ 5 PT6 -> 5 4 3 2 1 }T
  110. : MIX_UP 2 CS-ROLL ; IMMEDIATE \ CS-ROT
  111. : PT7 ( f3 f2 f1 -- ? )
  112. IF 1111 ROT ROT ( -- 1111 f3 f2 ) ( cs: -- orig1 )
  113. IF 2222 SWAP ( -- 1111 2222 f3 ) ( cs: -- orig1 orig2 )
  114. IF ( cs: -- orig1 orig2 orig3 )
  115. 3333 MIX_UP ( -- 1111 2222 3333 ) ( cs: -- orig2 orig3 orig1 )
  116. THEN ( cs: -- orig2 orig3 )
  117. 4444 \ Hence failure of first IF comes here and falls through
  118. THEN ( cs: -- orig2 )
  119. 5555 \ Failure of 3rd IF comes here
  120. THEN ( cs: -- )
  121. 6666 \ Failure of 2nd IF comes here
  122. ;
  123. T{ -1 -1 -1 PT7 -> 1111 2222 3333 4444 5555 6666 }T
  124. T{ 0 -1 -1 PT7 -> 1111 2222 5555 6666 }T
  125. T{ 0 0 -1 PT7 -> 1111 0 6666 }T
  126. T{ 0 0 0 PT7 -> 0 0 4444 5555 6666 }T
  127. : [1CS-ROLL] 1 CS-ROLL ; IMMEDIATE
  128. T{ : PT8
  129. >R
  130. AHEAD 111
  131. BEGIN 222
  132. [1CS-ROLL]
  133. THEN
  134. 333
  135. R> 1- >R
  136. R@ 0<
  137. UNTIL
  138. R> DROP
  139. ; -> }T
  140. T{ 1 PT8 -> 333 222 333 }T
  141. \ ------------------------------------------------------------------------------
  142. TESTING [DEFINED] [UNDEFINED]
  143. CREATE DEF1
  144. T{ [DEFINED] DEF1 -> TRUE }T
  145. T{ [UNDEFINED] DEF1 -> FALSE }T
  146. T{ [DEFINED] 12345678901234567890 -> FALSE }T
  147. T{ [UNDEFINED] 12345678901234567890 -> TRUE }T
  148. T{ : DEF2 [DEFINED] DEF1 [IF] 1 [ELSE] 2 [THEN] ; -> }T
  149. T{ : DEF3 [UNDEFINED] DEF1 [IF] 3 [ELSE] 4 [THEN] ; -> }T
  150. T{ DEF2 -> 1 }T
  151. T{ DEF3 -> 4 }T
  152. 0 [IF] \ { xxx not yet in swapforth
  153. \ ------------------------------------------------------------------------------
  154. TESTING N>R NR>
  155. T{ : NTR N>R -1 NR> ; -> }T
  156. T{ 1 2 3 4 5 6 7 4 NTR -> 1 2 3 -1 4 5 6 7 4 }T
  157. T{ 1 0 NTR -> 1 -1 0 }T
  158. T{ : NTR2 N>R N>R -1 NR> -2 NR> ;
  159. T{ 1 2 2 3 4 5 3 NTR2 -> -1 1 2 2 -2 3 4 5 3 }T
  160. T{ 1 0 0 NTR2 -> 1 -1 0 -2 0 }T
  161. \ ------------------------------------------------------------------------------
  162. TESTING SYNONYM
  163. : SYN1 1234 ;
  164. T{ SYNONYM NEW-SYN1 SYN1 -> }T
  165. T{ NEW-SYN1 -> 1234 }T
  166. : SYN2 2345 ; IMMEDIATE
  167. T{ SYNONYM NEW-SYN2 SYN2 -> }T
  168. T{ NEW-SYN2 -> 2345 }T
  169. T{ : SYN3 SYN2 LITERAL ; SYN3 -> 2345 }T
  170. \ ------------------------------------------------------------------------------
  171. TESTING TRAVERSE-WORDLIST NAME>COMPILE NAME>INTERPRET NAME>STRING
  172. GET-CURRENT CONSTANT CURR-WL
  173. WORDLIST CONSTANT TRAV-WL
  174. : WDCT ( n nt -- n+1 f ) DROP 1+ TRUE ;
  175. T{ 0 ' WDCT TRAV-WL TRAVERSE-WORDLIST -> 0 }T
  176. TRAV-WL SET-CURRENT
  177. : TRAV1 1 ;
  178. T{ 0 ' WDCT TRAV-WL TRAVERSE-WORDLIST -> 1 }T
  179. : TRAV2 2 ; : TRAV3 3 ; : TRAV4 4 ; : TRAV5 5 ; : TRAV6 6 ; IMMEDIATE
  180. CURR-WL SET-CURRENT
  181. T{ 0 ' WDCT TRAV-WL TRAVERSE-WORDLIST -> 6 }T \ Traverse whole wordlist
  182. \ Terminate TRAVERSE-WORDLIST after n words & check it compiles
  183. : (PART-OF-WL) ( ct n nt -- ct+1 n-1 ) DROP DUP IF SWAP 1+ SWAP 1- THEN DUP ;
  184. : PART-OF-WL ( n -- ct 0 | ct+1 n-1)
  185. 0 SWAP ['] (PART-OF-WL) TRAV-WL TRAVERSE-WORDLIST DROP
  186. ;
  187. T{ 0 PART-OF-WL -> 0 }T
  188. T{ 1 PART-OF-WL -> 1 }T
  189. T{ 4 PART-OF-WL -> 4 }T
  190. T{ 9 PART-OF-WL -> 6 }T \ Traverse whole wordlist
  191. \ Testing NAME>.. words require a name token. It will be easier to test them
  192. \ if there is a way of obtaining the name token of a given word. To get this we
  193. \ need a definition to compare a given name with the result of NAME>STRING.
  194. \ The output from NAME>STRING has to be copied into a buffer and converted to a
  195. \ known case as a given Forth system may store names as lower, upper or mixed case.
  196. CREATE UCBUF 32 CHARS ALLOT \ The buffer
  197. \ Convert string to upper case and save in the buffer.
  198. : >UPPERCASE ( caddr u -- caddr2 u2 )
  199. 32 MIN DUP >R UCBUF ROT ROT
  200. OVER + SWAP
  201. DO
  202. I C@ DUP [CHAR] a [CHAR] z 1+ WITHIN IF 32 INVERT AND THEN
  203. OVER C! CHAR+
  204. LOOP DROP
  205. UCBUF R>
  206. ;
  207. \ Compare string (caddr u) with name associated with nt, f=0 if the same
  208. : NAME? ( caddr u nt -- caddr u f ) \ f = true for name = (caddr u) string
  209. NAME>STRING >UPPERCASE 2OVER COMPARE 0=
  210. ;
  211. \ The word to be executed by TRAVERSE-WORDLIST
  212. : GET-NT ( caddr u 0 nt -- caddr u nt false | caddr u 0 nt ) \ nt <> 0
  213. 2>R R@ NAME? IF R> R> ELSE 2R> THEN
  214. ;
  215. \ Get name token of (caddr u) in wordlist wid, return 0 if not present
  216. : GET-NAME-TOKEN ( caddr u wid -- nt | 0 )
  217. 0 ['] GET-NT ROT TRAVERSE-WORDLIST >R 2DROP R>
  218. ;
  219. \ Test NAME>STRING via TRAVERSE-WORDLIST
  220. T{ S" ABCDE" TRAV-WL GET-NAME-TOKEN 0= -> TRUE }T \ Not in wordlist
  221. T{ S" TRAV4" TRAV-WL GET-NAME-TOKEN 0= -> FALSE }T
  222. \ Test NAME>INTERPRET on a word with interpretation semantics
  223. T{ S" TRAV3" TRAV-WL GET-NAME-TOKEN NAME>INTERPRET EXECUTE -> 3 }T
  224. \ Test NAME>INTERPRET on a word without interpretation semantics. It is
  225. \ difficult to choose a suitable word because:
  226. \ - a user cannot define one in a standard system
  227. \ - a Forth system may choose to define interpretation semantics for a word
  228. \ despite the standard stating they are undefined.
  229. \ Standard words that are not likely to have interpretation semantics defined
  230. \ could be: ; EXIT ['] [CHAR] RECURSE
  231. \ ['] will be used since it has an equivalent in interpretation mode, if that
  232. \ doesn't work in a given system choose another word for that system.
  233. \ FORTH-WORDLIST is needed
  234. T{ S" [']" FORTH-WORDLIST GET-NAME-TOKEN NAME>INTERPRET -> 0 }T
  235. \ Test NAME>COMPILE
  236. : N>C ( caddr u -- ) TRAV-WL GET-NAME-TOKEN NAME>COMPILE EXECUTE ; IMMEDIATE
  237. T{ : N>C1 ( -- n ) [ S" TRAV2" ] N>C ; N>C1 -> 2 }T \ Not immediate
  238. T{ : N>C2 ( -- n ) [ S" TRAV6" ] N>C LITERAL ; N>C2 -> 6 }T \ Immediate word
  239. T{ S" TRAV6" TRAV-WL GET-NAME-TOKEN NAME>COMPILE EXECUTE -> 6 }T
  240. \ Test the order of finding words with the same name
  241. TRAV-WL SET-CURRENT
  242. : TRAV3 33 ; : TRAV3 333 ; : TRAV7 7 ; : TRAV3 3333 ;
  243. CURR-WL SET-CURRENT
  244. : GET-ALL ( caddr u nt -- [n] caddr u true )
  245. DUP >R NAME? IF R@ NAME>INTERPRET EXECUTE ROT ROT THEN
  246. R> DROP TRUE
  247. ;
  248. : GET-ALL ( caddr u -- i*x )
  249. ['] GET-ALL TRAV-WL TRAVERSE-WORDLIST 2DROP
  250. ;
  251. T{ S" TRAV3" GET-ALL -> 3333 333 33 3 }T
  252. \ ------------------------------------------------------------------------------
  253. [THEN] \ }
  254. TOOLS-ERRORS SET-ERROR-COUNT
  255. CR .( End of Programming Tools word tests) CR