/anstests/coreexttest.fth

https://github.com/jamesbowman/swapforth · Forth · 816 lines · 648 code · 126 blank · 42 comment · 3 complexity · a93fdabb62bf0eb380231d9699944546 MD5 · raw file

  1. \ To test the ANS Forth Core Extension word set
  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 2015
  11. \ Added tests for PARSE-NAME HOLDS BUFFER:
  12. \ S\" tests added
  13. \ DEFER IS ACTION-OF DEFER! DEFER@ tests added
  14. \ Empty CASE statement test added
  15. \ [COMPILE] tests removed because it is obsolescent in Forth 2012
  16. \ 0.10 1 August 2014
  17. \ Added tests contributed by James Bowman for:
  18. \ <> U> 0<> 0> NIP TUCK ROLL PICK 2>R 2R@ 2R>
  19. \ HEX WITHIN UNUSED AGAIN MARKER
  20. \ Added tests for:
  21. \ .R U.R ERASE PAD REFILL SOURCE-ID
  22. \ Removed ABORT from NeverExecuted to enable Win32
  23. \ to continue after failure of RESTORE-INPUT.
  24. \ Removed max-intx which is no longer used.
  25. \ 0.7 6 June 2012 Extra CASE test added
  26. \ 0.6 1 April 2012 Tests placed in the public domain.
  27. \ SAVE-INPUT & RESTORE-INPUT tests, position
  28. \ of T{ moved so that tests work with ttester.fs
  29. \ CONVERT test deleted - obsolete word removed from Forth 200X
  30. \ IMMEDIATE VALUEs tested
  31. \ RECURSE with :NONAME tested
  32. \ PARSE and .( tested
  33. \ Parsing behaviour of C" added
  34. \ 0.5 14 September 2011 Removed the double [ELSE] from the
  35. \ initial SAVE-INPUT & RESTORE-INPUT test
  36. \ 0.4 30 November 2009 max-int replaced with max-intx to
  37. \ avoid redefinition warnings.
  38. \ 0.3 6 March 2009 { and } replaced with T{ and }T
  39. \ CONVERT test now independent of cell size
  40. \ 0.2 20 April 2007 ANS Forth words changed to upper case
  41. \ Tests qd3 to qd6 by Reinhold Straub
  42. \ 0.1 Oct 2006 First version released
  43. \ -----------------------------------------------------------------------------
  44. \ The tests are based on John Hayes test program for the core word set
  45. \ Words tested in this file are:
  46. \ .( .R 0<> 0> 2>R 2R> 2R@ :NONAME <> ?DO AGAIN C" CASE COMPILE, ENDCASE
  47. \ ENDOF ERASE FALSE HEX MARKER NIP OF PAD PARSE PICK REFILL
  48. \ RESTORE-INPUT ROLL SAVE-INPUT SOURCE-ID TO TRUE TUCK U.R U> UNUSED
  49. \ VALUE WITHIN [COMPILE]
  50. \ Words not tested or partially tested:
  51. \ \ because it has been extensively used already and is, hence, unnecessary
  52. \ REFILL and SOURCE-ID from the user input device which are not possible
  53. \ when testing from a file such as this one
  54. \ UNUSED as the value returned is system dependent
  55. \ Obsolescent words #TIB CONVERT EXPECT QUERY SPAN TIB as they have been
  56. \ removed from the Forth 200X standard
  57. \ Results from words that output to the user output device have to visually
  58. \ checked for correctness. These are .R U.R .(
  59. \ -----------------------------------------------------------------------------
  60. \ Assumptions:
  61. \ - tester.fr (or ttester.fs) and core-fr have been included prior to this
  62. \ file
  63. \ -----------------------------------------------------------------------------
  64. TESTING Core Extension words
  65. DECIMAL
  66. TESTING TRUE FALSE
  67. T{ TRUE -> 0 INVERT }T
  68. T{ FALSE -> 0 }T
  69. \ -----------------------------------------------------------------------------
  70. TESTING <> U> (contributed by James Bowman)
  71. T{ 0 0 <> -> <FALSE> }T
  72. T{ 1 1 <> -> <FALSE> }T
  73. T{ -1 -1 <> -> <FALSE> }T
  74. T{ 1 0 <> -> <TRUE> }T
  75. T{ -1 0 <> -> <TRUE> }T
  76. T{ 0 1 <> -> <TRUE> }T
  77. T{ 0 -1 <> -> <TRUE> }T
  78. T{ 0 1 U> -> <FALSE> }T
  79. T{ 1 2 U> -> <FALSE> }T
  80. T{ 0 MID-UINT U> -> <FALSE> }T
  81. T{ 0 MAX-UINT U> -> <FALSE> }T
  82. T{ MID-UINT MAX-UINT U> -> <FALSE> }T
  83. T{ 0 0 U> -> <FALSE> }T
  84. T{ 1 1 U> -> <FALSE> }T
  85. T{ 1 0 U> -> <TRUE> }T
  86. T{ 2 1 U> -> <TRUE> }T
  87. T{ MID-UINT 0 U> -> <TRUE> }T
  88. T{ MAX-UINT 0 U> -> <TRUE> }T
  89. T{ MAX-UINT MID-UINT U> -> <TRUE> }T
  90. \ -----------------------------------------------------------------------------
  91. TESTING 0<> 0> (contributed by James Bowman)
  92. T{ 0 0<> -> <FALSE> }T
  93. T{ 1 0<> -> <TRUE> }T
  94. T{ 2 0<> -> <TRUE> }T
  95. T{ -1 0<> -> <TRUE> }T
  96. T{ MAX-UINT 0<> -> <TRUE> }T
  97. T{ MIN-INT 0<> -> <TRUE> }T
  98. T{ MAX-INT 0<> -> <TRUE> }T
  99. T{ 0 0> -> <FALSE> }T
  100. T{ -1 0> -> <FALSE> }T
  101. T{ MIN-INT 0> -> <FALSE> }T
  102. T{ 1 0> -> <TRUE> }T
  103. T{ MAX-INT 0> -> <TRUE> }T
  104. \ -----------------------------------------------------------------------------
  105. TESTING NIP TUCK ROLL PICK (contributed by James Bowman)
  106. T{ 1 2 NIP -> 2 }T
  107. T{ 1 2 3 NIP -> 1 3 }T
  108. T{ 1 2 TUCK -> 2 1 2 }T
  109. T{ 1 2 3 TUCK -> 1 3 2 3 }T
  110. T{ : RO5 100 200 300 400 500 ; -> }T
  111. T{ RO5 3 ROLL -> 100 300 400 500 200 }T
  112. T{ RO5 2 ROLL -> RO5 ROT }T
  113. T{ RO5 1 ROLL -> RO5 SWAP }T
  114. T{ RO5 0 ROLL -> RO5 }T
  115. T{ RO5 2 PICK -> 100 200 300 400 500 300 }T
  116. T{ RO5 1 PICK -> RO5 OVER }T
  117. T{ RO5 0 PICK -> RO5 DUP }T
  118. \ -----------------------------------------------------------------------------
  119. TESTING 2>R 2R@ 2R> (contributed by James Bowman)
  120. T{ : RR0 2>R 100 R> R> ; -> }T
  121. T{ 300 400 RR0 -> 100 400 300 }T
  122. T{ 200 300 400 RR0 -> 200 100 400 300 }T
  123. T{ : RR1 2>R 100 2R@ R> R> ; -> }T
  124. T{ 300 400 RR1 -> 100 300 400 400 300 }T
  125. T{ 200 300 400 RR1 -> 200 100 300 400 400 300 }T
  126. T{ : RR2 2>R 100 2R> ; -> }T
  127. T{ 300 400 RR2 -> 100 300 400 }T
  128. T{ 200 300 400 RR2 -> 200 100 300 400 }T
  129. \ -----------------------------------------------------------------------------
  130. TESTING HEX (contributed by James Bowman)
  131. T{ BASE @ HEX BASE @ DECIMAL BASE @ - SWAP BASE ! -> 6 }T
  132. \ -----------------------------------------------------------------------------
  133. TESTING WITHIN (contributed by James Bowman)
  134. T{ 0 0 0 WITHIN -> <FALSE> }T
  135. T{ 0 0 MID-UINT WITHIN -> <TRUE> }T
  136. T{ 0 0 MID-UINT+1 WITHIN -> <TRUE> }T
  137. T{ 0 0 MAX-UINT WITHIN -> <TRUE> }T
  138. T{ 0 MID-UINT 0 WITHIN -> <FALSE> }T
  139. T{ 0 MID-UINT MID-UINT WITHIN -> <FALSE> }T
  140. T{ 0 MID-UINT MID-UINT+1 WITHIN -> <FALSE> }T
  141. T{ 0 MID-UINT MAX-UINT WITHIN -> <FALSE> }T
  142. T{ 0 MID-UINT+1 0 WITHIN -> <FALSE> }T
  143. T{ 0 MID-UINT+1 MID-UINT WITHIN -> <TRUE> }T
  144. T{ 0 MID-UINT+1 MID-UINT+1 WITHIN -> <FALSE> }T
  145. T{ 0 MID-UINT+1 MAX-UINT WITHIN -> <FALSE> }T
  146. T{ 0 MAX-UINT 0 WITHIN -> <FALSE> }T
  147. T{ 0 MAX-UINT MID-UINT WITHIN -> <TRUE> }T
  148. T{ 0 MAX-UINT MID-UINT+1 WITHIN -> <TRUE> }T
  149. T{ 0 MAX-UINT MAX-UINT WITHIN -> <FALSE> }T
  150. T{ MID-UINT 0 0 WITHIN -> <FALSE> }T
  151. T{ MID-UINT 0 MID-UINT WITHIN -> <FALSE> }T
  152. T{ MID-UINT 0 MID-UINT+1 WITHIN -> <TRUE> }T
  153. T{ MID-UINT 0 MAX-UINT WITHIN -> <TRUE> }T
  154. T{ MID-UINT MID-UINT 0 WITHIN -> <TRUE> }T
  155. T{ MID-UINT MID-UINT MID-UINT WITHIN -> <FALSE> }T
  156. T{ MID-UINT MID-UINT MID-UINT+1 WITHIN -> <TRUE> }T
  157. T{ MID-UINT MID-UINT MAX-UINT WITHIN -> <TRUE> }T
  158. T{ MID-UINT MID-UINT+1 0 WITHIN -> <FALSE> }T
  159. T{ MID-UINT MID-UINT+1 MID-UINT WITHIN -> <FALSE> }T
  160. T{ MID-UINT MID-UINT+1 MID-UINT+1 WITHIN -> <FALSE> }T
  161. T{ MID-UINT MID-UINT+1 MAX-UINT WITHIN -> <FALSE> }T
  162. T{ MID-UINT MAX-UINT 0 WITHIN -> <FALSE> }T
  163. T{ MID-UINT MAX-UINT MID-UINT WITHIN -> <FALSE> }T
  164. T{ MID-UINT MAX-UINT MID-UINT+1 WITHIN -> <TRUE> }T
  165. T{ MID-UINT MAX-UINT MAX-UINT WITHIN -> <FALSE> }T
  166. T{ MID-UINT+1 0 0 WITHIN -> <FALSE> }T
  167. T{ MID-UINT+1 0 MID-UINT WITHIN -> <FALSE> }T
  168. T{ MID-UINT+1 0 MID-UINT+1 WITHIN -> <FALSE> }T
  169. T{ MID-UINT+1 0 MAX-UINT WITHIN -> <TRUE> }T
  170. T{ MID-UINT+1 MID-UINT 0 WITHIN -> <TRUE> }T
  171. T{ MID-UINT+1 MID-UINT MID-UINT WITHIN -> <FALSE> }T
  172. T{ MID-UINT+1 MID-UINT MID-UINT+1 WITHIN -> <FALSE> }T
  173. T{ MID-UINT+1 MID-UINT MAX-UINT WITHIN -> <TRUE> }T
  174. T{ MID-UINT+1 MID-UINT+1 0 WITHIN -> <TRUE> }T
  175. T{ MID-UINT+1 MID-UINT+1 MID-UINT WITHIN -> <TRUE> }T
  176. T{ MID-UINT+1 MID-UINT+1 MID-UINT+1 WITHIN -> <FALSE> }T
  177. T{ MID-UINT+1 MID-UINT+1 MAX-UINT WITHIN -> <TRUE> }T
  178. T{ MID-UINT+1 MAX-UINT 0 WITHIN -> <FALSE> }T
  179. T{ MID-UINT+1 MAX-UINT MID-UINT WITHIN -> <FALSE> }T
  180. T{ MID-UINT+1 MAX-UINT MID-UINT+1 WITHIN -> <FALSE> }T
  181. T{ MID-UINT+1 MAX-UINT MAX-UINT WITHIN -> <FALSE> }T
  182. T{ MAX-UINT 0 0 WITHIN -> <FALSE> }T
  183. T{ MAX-UINT 0 MID-UINT WITHIN -> <FALSE> }T
  184. T{ MAX-UINT 0 MID-UINT+1 WITHIN -> <FALSE> }T
  185. T{ MAX-UINT 0 MAX-UINT WITHIN -> <FALSE> }T
  186. T{ MAX-UINT MID-UINT 0 WITHIN -> <TRUE> }T
  187. T{ MAX-UINT MID-UINT MID-UINT WITHIN -> <FALSE> }T
  188. T{ MAX-UINT MID-UINT MID-UINT+1 WITHIN -> <FALSE> }T
  189. T{ MAX-UINT MID-UINT MAX-UINT WITHIN -> <FALSE> }T
  190. T{ MAX-UINT MID-UINT+1 0 WITHIN -> <TRUE> }T
  191. T{ MAX-UINT MID-UINT+1 MID-UINT WITHIN -> <TRUE> }T
  192. T{ MAX-UINT MID-UINT+1 MID-UINT+1 WITHIN -> <FALSE> }T
  193. T{ MAX-UINT MID-UINT+1 MAX-UINT WITHIN -> <FALSE> }T
  194. T{ MAX-UINT MAX-UINT 0 WITHIN -> <TRUE> }T
  195. T{ MAX-UINT MAX-UINT MID-UINT WITHIN -> <TRUE> }T
  196. T{ MAX-UINT MAX-UINT MID-UINT+1 WITHIN -> <TRUE> }T
  197. T{ MAX-UINT MAX-UINT MAX-UINT WITHIN -> <FALSE> }T
  198. T{ MIN-INT MIN-INT MIN-INT WITHIN -> <FALSE> }T
  199. T{ MIN-INT MIN-INT 0 WITHIN -> <TRUE> }T
  200. T{ MIN-INT MIN-INT 1 WITHIN -> <TRUE> }T
  201. T{ MIN-INT MIN-INT MAX-INT WITHIN -> <TRUE> }T
  202. T{ MIN-INT 0 MIN-INT WITHIN -> <FALSE> }T
  203. T{ MIN-INT 0 0 WITHIN -> <FALSE> }T
  204. T{ MIN-INT 0 1 WITHIN -> <FALSE> }T
  205. T{ MIN-INT 0 MAX-INT WITHIN -> <FALSE> }T
  206. T{ MIN-INT 1 MIN-INT WITHIN -> <FALSE> }T
  207. T{ MIN-INT 1 0 WITHIN -> <TRUE> }T
  208. T{ MIN-INT 1 1 WITHIN -> <FALSE> }T
  209. T{ MIN-INT 1 MAX-INT WITHIN -> <FALSE> }T
  210. T{ MIN-INT MAX-INT MIN-INT WITHIN -> <FALSE> }T
  211. T{ MIN-INT MAX-INT 0 WITHIN -> <TRUE> }T
  212. T{ MIN-INT MAX-INT 1 WITHIN -> <TRUE> }T
  213. T{ MIN-INT MAX-INT MAX-INT WITHIN -> <FALSE> }T
  214. T{ 0 MIN-INT MIN-INT WITHIN -> <FALSE> }T
  215. T{ 0 MIN-INT 0 WITHIN -> <FALSE> }T
  216. T{ 0 MIN-INT 1 WITHIN -> <TRUE> }T
  217. T{ 0 MIN-INT MAX-INT WITHIN -> <TRUE> }T
  218. T{ 0 0 MIN-INT WITHIN -> <TRUE> }T
  219. T{ 0 0 0 WITHIN -> <FALSE> }T
  220. T{ 0 0 1 WITHIN -> <TRUE> }T
  221. T{ 0 0 MAX-INT WITHIN -> <TRUE> }T
  222. T{ 0 1 MIN-INT WITHIN -> <FALSE> }T
  223. T{ 0 1 0 WITHIN -> <FALSE> }T
  224. T{ 0 1 1 WITHIN -> <FALSE> }T
  225. T{ 0 1 MAX-INT WITHIN -> <FALSE> }T
  226. T{ 0 MAX-INT MIN-INT WITHIN -> <FALSE> }T
  227. T{ 0 MAX-INT 0 WITHIN -> <FALSE> }T
  228. T{ 0 MAX-INT 1 WITHIN -> <TRUE> }T
  229. T{ 0 MAX-INT MAX-INT WITHIN -> <FALSE> }T
  230. T{ 1 MIN-INT MIN-INT WITHIN -> <FALSE> }T
  231. T{ 1 MIN-INT 0 WITHIN -> <FALSE> }T
  232. T{ 1 MIN-INT 1 WITHIN -> <FALSE> }T
  233. T{ 1 MIN-INT MAX-INT WITHIN -> <TRUE> }T
  234. T{ 1 0 MIN-INT WITHIN -> <TRUE> }T
  235. T{ 1 0 0 WITHIN -> <FALSE> }T
  236. T{ 1 0 1 WITHIN -> <FALSE> }T
  237. T{ 1 0 MAX-INT WITHIN -> <TRUE> }T
  238. T{ 1 1 MIN-INT WITHIN -> <TRUE> }T
  239. T{ 1 1 0 WITHIN -> <TRUE> }T
  240. T{ 1 1 1 WITHIN -> <FALSE> }T
  241. T{ 1 1 MAX-INT WITHIN -> <TRUE> }T
  242. T{ 1 MAX-INT MIN-INT WITHIN -> <FALSE> }T
  243. T{ 1 MAX-INT 0 WITHIN -> <FALSE> }T
  244. T{ 1 MAX-INT 1 WITHIN -> <FALSE> }T
  245. T{ 1 MAX-INT MAX-INT WITHIN -> <FALSE> }T
  246. T{ MAX-INT MIN-INT MIN-INT WITHIN -> <FALSE> }T
  247. T{ MAX-INT MIN-INT 0 WITHIN -> <FALSE> }T
  248. T{ MAX-INT MIN-INT 1 WITHIN -> <FALSE> }T
  249. T{ MAX-INT MIN-INT MAX-INT WITHIN -> <FALSE> }T
  250. T{ MAX-INT 0 MIN-INT WITHIN -> <TRUE> }T
  251. T{ MAX-INT 0 0 WITHIN -> <FALSE> }T
  252. T{ MAX-INT 0 1 WITHIN -> <FALSE> }T
  253. T{ MAX-INT 0 MAX-INT WITHIN -> <FALSE> }T
  254. T{ MAX-INT 1 MIN-INT WITHIN -> <TRUE> }T
  255. T{ MAX-INT 1 0 WITHIN -> <TRUE> }T
  256. T{ MAX-INT 1 1 WITHIN -> <FALSE> }T
  257. T{ MAX-INT 1 MAX-INT WITHIN -> <FALSE> }T
  258. T{ MAX-INT MAX-INT MIN-INT WITHIN -> <TRUE> }T
  259. T{ MAX-INT MAX-INT 0 WITHIN -> <TRUE> }T
  260. T{ MAX-INT MAX-INT 1 WITHIN -> <TRUE> }T
  261. T{ MAX-INT MAX-INT MAX-INT WITHIN -> <FALSE> }T
  262. \ -----------------------------------------------------------------------------
  263. TESTING UNUSED (contributed by James Bowman & Peter Knaggs)
  264. T{ UNUSED DROP -> }T
  265. T{ ALIGN UNUSED 0 , UNUSED CELL+ = -> TRUE }T
  266. T{ UNUSED 0 C, UNUSED CHAR+ = -> TRUE }T \ aligned -> unaligned
  267. T{ UNUSED 0 C, UNUSED CHAR+ = -> TRUE }T \ unaligned -> ?
  268. \ -----------------------------------------------------------------------------
  269. TESTING AGAIN (contributed by James Bowman)
  270. T{ : AG0 701 BEGIN DUP 7 MOD 0= IF EXIT THEN 1+ AGAIN ; -> }T
  271. T{ AG0 -> 707 }T
  272. \ -----------------------------------------------------------------------------
  273. TESTING MARKER (contributed by James Bowman)
  274. T{ : MA? BL WORD FIND NIP 0<> ; -> }T
  275. T{ MARKER MA0 -> }T
  276. T{ : MA1 111 ; -> }T
  277. T{ MARKER MA2 -> }T
  278. T{ : MA1 222 ; -> }T
  279. T{ MA? MA0 MA? MA1 MA? MA2 -> <TRUE> <TRUE> <TRUE> }T
  280. T{ MA1 MA2 MA1 -> 222 111 }T
  281. T{ MA? MA0 MA? MA1 MA? MA2 -> <TRUE> <TRUE> <FALSE> }T
  282. T{ MA0 -> }T
  283. T{ MA? MA0 MA? MA1 MA? MA2 -> <FALSE> <FALSE> <FALSE> }T
  284. \ -----------------------------------------------------------------------------
  285. TESTING ?DO
  286. : QD ?DO I LOOP ;
  287. T{ 789 789 QD -> }T
  288. T{ -9876 -9876 QD -> }T
  289. T{ 5 0 QD -> 0 1 2 3 4 }T
  290. : QD1 ?DO I 10 +LOOP ;
  291. T{ 50 1 QD1 -> 1 11 21 31 41 }T
  292. T{ 50 0 QD1 -> 0 10 20 30 40 }T
  293. : QD2 ?DO I 3 > IF LEAVE ELSE I THEN LOOP ;
  294. T{ 5 -1 QD2 -> -1 0 1 2 3 }T
  295. : QD3 ?DO I 1 +LOOP ;
  296. T{ 4 4 QD3 -> }T
  297. T{ 4 1 QD3 -> 1 2 3 }T
  298. T{ 2 -1 QD3 -> -1 0 1 }T
  299. : QD4 ?DO I -1 +LOOP ;
  300. T{ 4 4 QD4 -> }T
  301. T{ 1 4 QD4 -> 4 3 2 1 }T
  302. T{ -1 2 QD4 -> 2 1 0 -1 }T
  303. : QD5 ?DO I -10 +LOOP ;
  304. T{ 1 50 QD5 -> 50 40 30 20 10 }T
  305. T{ 0 50 QD5 -> 50 40 30 20 10 0 }T
  306. T{ -25 10 QD5 -> 10 0 -10 -20 }T
  307. VARIABLE ITERS
  308. VARIABLE INCRMNT
  309. : QD6 ( limit start increment -- )
  310. INCRMNT !
  311. 0 ITERS !
  312. ?DO
  313. 1 ITERS +!
  314. I
  315. ITERS @ 6 = IF LEAVE THEN
  316. INCRMNT @
  317. +LOOP ITERS @
  318. ;
  319. T{ 4 4 -1 QD6 -> 0 }T
  320. T{ 1 4 -1 QD6 -> 4 3 2 1 4 }T
  321. T{ 4 1 -1 QD6 -> 1 0 -1 -2 -3 -4 6 }T
  322. T{ 4 1 0 QD6 -> 1 1 1 1 1 1 6 }T
  323. T{ 0 0 0 QD6 -> 0 }T
  324. T{ 1 4 0 QD6 -> 4 4 4 4 4 4 6 }T
  325. T{ 1 4 1 QD6 -> 4 5 6 7 8 9 6 }T
  326. T{ 4 1 1 QD6 -> 1 2 3 3 }T
  327. T{ 4 4 1 QD6 -> 0 }T
  328. T{ 2 -1 -1 QD6 -> -1 -2 -3 -4 -5 -6 6 }T
  329. T{ -1 2 -1 QD6 -> 2 1 0 -1 4 }T
  330. T{ 2 -1 0 QD6 -> -1 -1 -1 -1 -1 -1 6 }T
  331. T{ -1 2 0 QD6 -> 2 2 2 2 2 2 6 }T
  332. T{ -1 2 1 QD6 -> 2 3 4 5 6 7 6 }T
  333. T{ 2 -1 1 QD6 -> -1 0 1 3 }T
  334. \ -----------------------------------------------------------------------------
  335. TESTING BUFFER:
  336. T{ 8 BUFFER: BUF:TEST -> }T
  337. T{ BUF:TEST DUP ALIGNED = -> TRUE }T
  338. T{ 111 BUF:TEST ! 222 BUF:TEST CELL+ ! -> }T
  339. T{ BUF:TEST @ BUF:TEST CELL+ @ -> 111 222 }T
  340. \ -----------------------------------------------------------------------------
  341. TESTING VALUE TO
  342. T{ 111 VALUE VAL1 -999 VALUE VAL2 -> }T
  343. T{ VAL1 -> 111 }T
  344. T{ VAL2 -> -999 }T
  345. T{ 222 TO VAL1 -> }T
  346. T{ VAL1 -> 222 }T
  347. T{ : VD1 VAL1 ; -> }T
  348. T{ VD1 -> 222 }T
  349. T{ : VD2 TO VAL2 ; -> }T
  350. T{ VAL2 -> -999 }T
  351. T{ -333 VD2 -> }T
  352. T{ VAL2 -> -333 }T
  353. T{ VAL1 -> 222 }T
  354. T{ 123 VALUE VAL3 IMMEDIATE VAL3 -> 123 }T
  355. T{ : VD3 VAL3 LITERAL ; VD3 -> 123 }T
  356. \ -----------------------------------------------------------------------------
  357. TESTING CASE OF ENDOF ENDCASE
  358. : CS1 CASE 1 OF 111 ENDOF
  359. 2 OF 222 ENDOF
  360. 3 OF 333 ENDOF
  361. >R 999 R>
  362. ENDCASE
  363. ;
  364. T{ 1 CS1 -> 111 }T
  365. T{ 2 CS1 -> 222 }T
  366. T{ 3 CS1 -> 333 }T
  367. T{ 4 CS1 -> 999 }T
  368. \ Nested CASE's
  369. : CS2 >R CASE -1 OF CASE R@ 1 OF 100 ENDOF
  370. 2 OF 200 ENDOF
  371. >R -300 R>
  372. ENDCASE
  373. ENDOF
  374. -2 OF CASE R@ 1 OF -99 ENDOF
  375. >R -199 R>
  376. ENDCASE
  377. ENDOF
  378. >R 299 R>
  379. ENDCASE R> DROP
  380. ;
  381. T{ -1 1 CS2 -> 100 }T
  382. T{ -1 2 CS2 -> 200 }T
  383. T{ -1 3 CS2 -> -300 }T
  384. T{ -2 1 CS2 -> -99 }T
  385. T{ -2 2 CS2 -> -199 }T
  386. T{ 0 2 CS2 -> 299 }T
  387. \ Boolean short circuiting using CASE
  388. : CS3 ( N1 -- N2 )
  389. CASE 1- FALSE OF 11 ENDOF
  390. 1- FALSE OF 22 ENDOF
  391. 1- FALSE OF 33 ENDOF
  392. 44 SWAP
  393. ENDCASE
  394. ;
  395. T{ 1 CS3 -> 11 }T
  396. T{ 2 CS3 -> 22 }T
  397. T{ 3 CS3 -> 33 }T
  398. T{ 9 CS3 -> 44 }T
  399. \ Empty CASE statements with/without default
  400. T{ : CS4 CASE ENDCASE ; 1 CS4 -> }T
  401. T{ : CS5 CASE 2 SWAP ENDCASE ; 1 CS5 -> 2 }T
  402. T{ : CS6 CASE 1 OF ENDOF 2 ENDCASE ; 1 CS6 -> }T
  403. T{ : CS7 CASE 3 OF ENDOF 2 ENDCASE ; 1 CS7 -> 1 }T
  404. \ -----------------------------------------------------------------------------
  405. TESTING :NONAME RECURSE
  406. VARIABLE NN1
  407. VARIABLE NN2
  408. :NONAME 1234 ; NN1 !
  409. :NONAME 9876 ; NN2 !
  410. T{ NN1 @ EXECUTE -> 1234 }T
  411. T{ NN2 @ EXECUTE -> 9876 }T
  412. T{ :NONAME ( n -- 0,1,..n ) DUP IF DUP >R 1- RECURSE R> THEN ;
  413. CONSTANT RN1 -> }T
  414. T{ 0 RN1 EXECUTE -> 0 }T
  415. T{ 4 RN1 EXECUTE -> 0 1 2 3 4 }T
  416. :NONAME ( n -- n1 ) \ Multiple RECURSEs in one definition
  417. 1- DUP
  418. CASE 0 OF EXIT ENDOF
  419. 1 OF 11 SWAP RECURSE ENDOF
  420. 2 OF 22 SWAP RECURSE ENDOF
  421. 3 OF 33 SWAP RECURSE ENDOF
  422. DROP ABS RECURSE EXIT
  423. ENDCASE
  424. ; CONSTANT RN2
  425. T{ 1 RN2 EXECUTE -> 0 }T
  426. T{ 2 RN2 EXECUTE -> 11 0 }T
  427. T{ 4 RN2 EXECUTE -> 33 22 11 0 }T
  428. T{ 25 RN2 EXECUTE -> 33 22 11 0 }T
  429. \ -----------------------------------------------------------------------------
  430. TESTING C"
  431. T{ : CQ1 C" 123" ; -> }T
  432. T{ CQ1 COUNT EVALUATE -> 123 }T
  433. T{ : CQ2 C" " ; -> }T
  434. T{ CQ2 COUNT EVALUATE -> }T
  435. T{ : CQ3 C" 2345"COUNT EVALUATE ; CQ3 -> 2345 }T
  436. \ -----------------------------------------------------------------------------
  437. TESTING COMPILE,
  438. :NONAME DUP + ; CONSTANT DUP+
  439. T{ : Q DUP+ COMPILE, ; -> }T
  440. T{ : AS1 [ Q ] ; -> }T
  441. T{ 123 AS1 -> 246 }T
  442. \ -----------------------------------------------------------------------------
  443. \ Cannot automatically test SAVE-INPUT and RESTORE-INPUT from a console source
  444. TESTING SAVE-INPUT and RESTORE-INPUT with a file source
  445. 0 [IF]
  446. VARIABLE SIV -1 SIV !
  447. : NEVEREXECUTED
  448. CR ." This should never be executed" CR
  449. ;
  450. T{ 11111 SAVE-INPUT
  451. SIV @
  452. [IF]
  453. 0 SIV !
  454. RESTORE-INPUT
  455. NEVEREXECUTED
  456. 33333
  457. [ELSE]
  458. TESTING the -[ELSE]- part is executed
  459. 22222
  460. [THEN]
  461. -> 11111 0 22222 }T \ 0 comes from RESTORE-INPUT
  462. TESTING SAVE-INPUT and RESTORE-INPUT with a string source
  463. VARIABLE SI_INC 0 SI_INC !
  464. : SI1
  465. SI_INC @ >IN +!
  466. 15 SI_INC !
  467. ;
  468. : S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ;
  469. T{ S$ EVALUATE SI_INC @ -> 0 2345 15 }T
  470. TESTING nested SAVE-INPUT, RESTORE-INPUT and REFILL from a file
  471. : READ_A_LINE
  472. REFILL 0=
  473. ABORT" REFILL FAILED"
  474. ;
  475. 0 SI_INC !
  476. 2VARIABLE 2RES -1. 2RES 2!
  477. : SI2
  478. READ_A_LINE
  479. READ_A_LINE
  480. SAVE-INPUT
  481. READ_A_LINE
  482. READ_A_LINE
  483. S$ EVALUATE 2RES 2!
  484. RESTORE-INPUT
  485. ;
  486. \ WARNING: do not delete or insert lines of text after si2 is called
  487. \ otherwise the next test will fail
  488. T{ SI2
  489. 33333 \ This line should be ignored
  490. 2RES 2@ 44444 \ RESTORE-INPUT should return to this line
  491. 55555
  492. TESTING the nested results
  493. -> 0 0 2345 44444 55555 }T
  494. \ End of warning
  495. [THEN]
  496. \ -----------------------------------------------------------------------------
  497. TESTING .(
  498. CR CR .( Output from .()
  499. T{ CR .( You should see -9876: ) -9876 . -> }T
  500. T{ CR .( and again: ).( -9876)CR -> }T
  501. CR CR .( On the next 2 lines you should see First then Second messages:)
  502. T{ : DOTP CR ." Second message via ." [CHAR] " EMIT \ Check .( is immediate
  503. [ CR ] .( First message via .( ) ; dotp -> }T
  504. CR CR
  505. T{ : IMM? BL WORD FIND NIP ; IMM? .( -> 1 }T
  506. \ -----------------------------------------------------------------------------
  507. TESTING .R and U.R - has to handle different cell sizes
  508. \ Create some large integers
  509. MAX-INT 73 79 */ CONSTANT LI1
  510. MIN-INT 71 73 */ CONSTANT LI2
  511. LI1 0 <# #S #> NIP CONSTANT LENLI1
  512. : (.R&U.R) ( u1 u2 -- ) \ u1 <= string length, u2 is required indentation
  513. TUCK + >R
  514. LI1 OVER SPACES . CR R@ LI1 SWAP .R CR
  515. LI2 OVER SPACES . CR R@ 1+ LI2 SWAP .R CR
  516. LI1 OVER SPACES U. CR R@ LI1 SWAP U.R CR
  517. LI2 SWAP SPACES U. CR R> LI2 SWAP U.R CR
  518. ;
  519. : .R&U.R ( -- )
  520. CR ." You should see lines duplicated:" CR
  521. ." indented by 0 spaces" CR 0 0 (.R&U.R) CR
  522. ." indented by 0 spaces" CR LENLI1 0 (.R&U.R) CR \ Just fits required width
  523. ." indented by 5 spaces" CR LENLI1 5 (.R&U.R) CR
  524. ;
  525. CR CR .( Output from .R and U.R)
  526. T{ .R&U.R -> }T
  527. \ -----------------------------------------------------------------------------
  528. TESTING PAD ERASE
  529. \ Must handle different size characters i.e. 1 CHARS >= 1
  530. 84 CONSTANT CHARS/PAD \ Minimum size of PAD in chars
  531. CHARS/PAD CHARS CONSTANT AUS/PAD
  532. : CHECKPAD ( caddr u ch -- f ) \ f = TRUE if u chars = ch
  533. SWAP 0
  534. ?DO
  535. OVER I CHARS + C@ OVER <>
  536. IF 2DROP UNLOOP FALSE EXIT THEN
  537. LOOP
  538. 2DROP TRUE
  539. ;
  540. T{ PAD DROP -> }T
  541. T{ 0 INVERT PAD C! -> }T
  542. T{ PAD C@ CONSTANT MAXCHAR -> }T
  543. T{ PAD CHARS/PAD 2DUP MAXCHAR FILL MAXCHAR CHECKPAD -> TRUE }T
  544. T{ PAD CHARS/PAD 2DUP CHARS ERASE 0 CHECKPAD -> TRUE }T
  545. T{ PAD CHARS/PAD 2DUP MAXCHAR FILL PAD 0 ERASE MAXCHAR CHECKPAD -> TRUE }T
  546. T{ PAD 43 CHARS + 9 CHARS ERASE -> }T
  547. T{ PAD 43 MAXCHAR CHECKPAD -> TRUE }T
  548. T{ PAD 43 CHARS + 9 0 CHECKPAD -> TRUE }T
  549. T{ PAD 52 CHARS + CHARS/PAD 52 - MAXCHAR CHECKPAD -> TRUE }T
  550. \ Check that use of WORD and pictured numeric output do not corrupt PAD
  551. \ Minimum size of buffers for these are 33 chars and (2*n)+2 chars respectively
  552. \ where n is number of bits per cell
  553. PAD CHARS/PAD ERASE
  554. 2 BASE !
  555. MAX-UINT MAX-UINT <# #S CHAR 1 DUP HOLD HOLD #> 2DROP
  556. DECIMAL
  557. BL WORD 12345678123456781234567812345678 DROP
  558. T{ PAD CHARS/PAD 0 CHECKPAD -> TRUE }T
  559. \ -----------------------------------------------------------------------------
  560. TESTING PARSE
  561. T{ CHAR | PARSE 1234| DUP ROT ROT EVALUATE -> 4 1234 }T
  562. T{ CHAR ^ PARSE 23 45 ^ DUP ROT ROT EVALUATE -> 7 23 45 }T
  563. : PA1 [CHAR] $ PARSE DUP >R PAD SWAP CHARS MOVE PAD R> ;
  564. T{ PA1 3456
  565. DUP ROT ROT EVALUATE -> 4 3456 }T
  566. T{ CHAR A PARSE A SWAP DROP -> 0 }T
  567. T{ CHAR Z PARSE
  568. SWAP DROP -> 0 }T
  569. T{ CHAR " PARSE 4567 "DUP ROT ROT EVALUATE -> 5 4567 }T
  570. \ -----------------------------------------------------------------------------
  571. TESTING PARSE-NAME (Forth 2012)
  572. \ Adapted from the PARSE-NAME RfD tests
  573. T{ PARSE-NAME abcd s" abcd" COMPARE -> 0 }T \ No leading spaces
  574. T{ PARSE-NAME abcde s" abcde" COMPARE -> 0 }T \ Leading spaces
  575. \ Test empty parse area, new lines are necessary
  576. T{ PARSE-NAME
  577. NIP -> 0 }T
  578. \ Empty parse area with spaces after PARSE-NAME
  579. T{ PARSE-NAME
  580. NIP -> 0 }T
  581. T{ : PARSE-NAME-TEST ( "name1" "name2" -- n )
  582. PARSE-NAME PARSE-NAME COMPARE ; -> }T
  583. T{ PARSE-NAME-TEST abcd abcd -> 0 }T
  584. T{ PARSE-NAME-TEST abcd abcd -> 0 }T
  585. T{ PARSE-NAME-TEST abcde abcdf -> -1 }T
  586. T{ PARSE-NAME-TEST abcdf abcde -> 1 }T
  587. T{ PARSE-NAME-TEST abcde abcde
  588. -> 0 }T
  589. T{ PARSE-NAME-TEST abcde abcde
  590. -> 0 }T
  591. \ -----------------------------------------------------------------------------
  592. TESTING DEFER DEFER@ DEFER! IS ACTION-OF (Forth 2012)
  593. \ Adapted from the Forth 200X RfD tests
  594. T{ DEFER DEFER1 -> }T
  595. T{ : MY-DEFER DEFER ; -> }T
  596. T{ : IS-DEFER1 IS DEFER1 ; -> }T
  597. T{ : ACTION-DEFER1 ACTION-OF DEFER1 ; -> }T
  598. T{ : DEF! DEFER! ; -> }T
  599. T{ : DEF@ DEFER@ ; -> }T
  600. T{ ' * ' DEFER1 DEFER! -> }T
  601. T{ 2 3 DEFER1 -> 6 }T
  602. T{ ' DEFER1 DEFER@ -> ' * }T
  603. T{ ' DEFER1 DEF@ -> ' * }T
  604. T{ ACTION-OF DEFER1 -> ' * }T
  605. T{ ACTION-DEFER1 -> ' * }T
  606. T{ ' + IS DEFER1 -> }T
  607. T{ 1 2 DEFER1 -> 3 }T
  608. T{ ' DEFER1 DEFER@ -> ' + }T
  609. T{ ' DEFER1 DEF@ -> ' + }T
  610. T{ ACTION-OF DEFER1 -> ' + }T
  611. T{ ACTION-DEFER1 -> ' + }T
  612. T{ ' - IS-DEFER1 -> }T
  613. T{ 1 2 DEFER1 -> -1 }T
  614. T{ ' DEFER1 DEFER@ -> ' - }T
  615. T{ ' DEFER1 DEF@ -> ' - }T
  616. T{ ACTION-OF DEFER1 -> ' - }T
  617. T{ ACTION-DEFER1 -> ' - }T
  618. T{ MY-DEFER DEFER2 -> }T
  619. T{ ' DUP IS DEFER2 -> }T
  620. T{ 1 DEFER2 -> 1 1 }T
  621. \ -----------------------------------------------------------------------------
  622. TESTING HOLDS (Forth 2012)
  623. : HTEST S" Testing HOLDS" ;
  624. : HTEST2 S" works" ;
  625. : HTEST3 S" Testing HOLDS works 123" ;
  626. T{ 0. <# HTEST HOLDS #> HTEST COMPARE -> 0 }T
  627. T{ 123. <# #S BL HOLD HTEST2 HOLDS BL HOLD htest HOLDS #> HTEST3 COMPARE -> 0 }T
  628. T{ : HLD HOLDS ; -> }T
  629. T{ 0. <# HTEST HLD #> HTEST COMPARE -> 0 }T
  630. \ -----------------------------------------------------------------------------
  631. TESTING REFILL SOURCE-ID
  632. \ REFILL and SOURCE-ID from the user input device can't be tested from a file,
  633. \ can only be tested from a string via EVALUATE
  634. T{ : RF1 S" REFILL" EVALUATE ; RF1 -> FALSE }T
  635. T{ : SID1 S" SOURCE-ID" EVALUATE ; SID1 -> -1 }T
  636. \ ------------------------------------------------------------------------------
  637. TESTING S\" (Forth 2012 compilation mode)
  638. \ Extended the Forth 200X RfD tests
  639. \ Note this tests the Core Ext definition of S\" which has unedfined
  640. \ interpretation semantics. S\" in interpretation mode is tested in the tests on
  641. \ the File-Access word set
  642. T{ : SSQ1 S\" abc" s" abc" COMPARE ; -> }T \ No escapes
  643. T{ SSQ1 -> 0 }T
  644. T{ : SSQ2 S\" " ; SSQ2 SWAP DROP -> 0 }T \ Empty string
  645. T{ : SSQ3 S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; -> }T
  646. T{ SSQ3 SWAP DROP -> 20 }T \ String length
  647. T{ SSQ3 DROP C@ -> 7 }T \ \a BEL Bell
  648. T{ SSQ3 DROP 1 CHARS + C@ -> 8 }T \ \b BS Backspace
  649. T{ SSQ3 DROP 2 CHARS + C@ -> 27 }T \ \e ESC Escape
  650. T{ SSQ3 DROP 3 CHARS + C@ -> 12 }T \ \f FF Form feed
  651. T{ SSQ3 DROP 4 CHARS + C@ -> 10 }T \ \l LF Line feed
  652. T{ SSQ3 DROP 5 CHARS + C@ -> 13 }T \ \m CR of CR/LF pair
  653. T{ SSQ3 DROP 6 CHARS + C@ -> 10 }T \ LF of CR/LF pair
  654. T{ SSQ3 DROP 7 CHARS + C@ -> 34 }T \ \q " Double Quote
  655. T{ SSQ3 DROP 8 CHARS + C@ -> 13 }T \ \r CR Carriage Return
  656. T{ SSQ3 DROP 9 CHARS + C@ -> 9 }T \ \t TAB Horizontal Tab
  657. T{ SSQ3 DROP 10 CHARS + C@ -> 11 }T \ \v VT Vertical Tab
  658. T{ SSQ3 DROP 11 CHARS + C@ -> 15 }T \ \x0F Given Char
  659. T{ SSQ3 DROP 12 CHARS + C@ -> 48 }T \ 0 0 Digit follow on
  660. T{ SSQ3 DROP 13 CHARS + C@ -> 31 }T \ \x1F Given Char
  661. T{ SSQ3 DROP 14 CHARS + C@ -> 97 }T \ a a Hex follow on
  662. T{ SSQ3 DROP 15 CHARS + C@ -> 171 }T \ \xaB Insensitive Given Char
  663. T{ SSQ3 DROP 16 CHARS + C@ -> 120 }T \ x x Non hex follow on
  664. T{ SSQ3 DROP 17 CHARS + C@ -> 0 }T \ \z NUL No Character
  665. T{ SSQ3 DROP 18 CHARS + C@ -> 34 }T \ \" " Double Quote
  666. T{ SSQ3 DROP 19 CHARS + C@ -> 92 }T \ \\ \ Back Slash
  667. \ The above does not test \n as this is a system dependent value.
  668. \ Check it displays a new line
  669. CR .( The next test should display:)
  670. CR .( One line...)
  671. CR .( another line)
  672. T{ : SSQ4 S\" \nOne line...\nanotherLine\n" type ; SSQ4 -> }T
  673. \ Test bare escapable characters appear as themselves
  674. t{ : SSQ5 s\" abeflmnqrtvxz" ; SSQ5 s" abeflmnqrtvxz" COMPARE -> 0 }t
  675. t{ : SSQ6 s\" a\""2DROP 1111 ; SSQ6 -> 1111 }t \ Parsing behaviour
  676. T{ : SSQ7 S\" 111 : SSQ8 s\\\" 222\" EVALUATE ; SSQ8 333" EVALUATE ; -> }T
  677. T{ SSQ7 -> 111 222 333 }T
  678. T{ : SSQ9 S\" 11 : SSQ10 s\\\" \\x32\\x32\" EVALUATE ; SSQ10 33" EVALUATE ; -> }T
  679. T{ SSQ9 -> 11 22 33 }T
  680. \ -----------------------------------------------------------------------------
  681. CORE-EXT-ERRORS SET-ERROR-COUNT
  682. CR .( End of Core Extension word tests) CR