/anstests/stringtest.fth

https://github.com/jamesbowman/swapforth · Forth · 304 lines · 252 code · 52 blank · 0 comment · 8 complexity · 9281fde7bdbe0140cee40d876fe697ee MD5 · raw file

  1. \ To test the ANS Forth String 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 Tests for REPLACES SUBSTITUTE UNESCAPE added
  11. \ 0.6 1 April 2012 Tests placed in the public domain.
  12. \ 0.5 29 April 2010 Added tests for SEARCH and COMPARE with
  13. \ all strings zero length (suggested by Krishna Myneni).
  14. \ SLITERAL test amended in line with comp.lang.forth
  15. \ discussion
  16. \ 0.4 30 November 2009 <true> and <false> replaced with TRUE
  17. \ and FALSE
  18. \ 0.3 6 March 2009 { and } replaced with T{ and }T
  19. \ 0.2 20 April 2007 ANS Forth words changed to upper case
  20. \ 0.1 Oct 2006 First version released
  21. \ ------------------------------------------------------------------------------
  22. \ The tests are based on John Hayes test program for the core word set
  23. \ and requires those files to have been loaded
  24. \ Words tested in this file are:
  25. \ -TRAILING /STRING BLANK CMOVE CMOVE> COMPARE SEARCH SLITERAL
  26. \ REPLACES SUBSTITUTE UNESCAPE
  27. \
  28. \ ------------------------------------------------------------------------------
  29. \ Assumptions and dependencies:
  30. \ - tester.fr or ttester.fs has been loaded prior to this file
  31. \ - COMPARE is case sensitive
  32. \ ------------------------------------------------------------------------------
  33. TESTING String word set
  34. DECIMAL
  35. T{ : S1 S" abcdefghijklmnopqrstuvwxyz" ; -> }T
  36. T{ : S2 S" abc" ; -> }T
  37. T{ : S3 S" jklmn" ; -> }T
  38. T{ : S4 S" z" ; -> }T
  39. T{ : S5 S" mnoq" ; -> }T
  40. T{ : S6 S" 12345" ; -> }T
  41. T{ : S7 S" " ; -> }T
  42. T{ : S8 S" abc " ; -> }T
  43. T{ : S9 S" " ; -> }T
  44. T{ : S10 S" a " ; -> }T
  45. \ ------------------------------------------------------------------------------
  46. TESTING -TRAILING
  47. T{ S1 -TRAILING -> S1 }T
  48. T{ S8 -TRAILING -> S8 2 - }T
  49. T{ S7 -TRAILING -> S7 }T
  50. T{ S9 -TRAILING -> S9 DROP 0 }T
  51. T{ S10 -TRAILING -> S10 1- }T
  52. \ ------------------------------------------------------------------------------
  53. TESTING /STRING
  54. T{ S1 5 /STRING -> S1 SWAP 5 + SWAP 5 - }T
  55. T{ S1 10 /STRING -4 /STRING -> S1 6 /STRING }T
  56. T{ S1 0 /STRING -> S1 }T
  57. \ ------------------------------------------------------------------------------
  58. TESTING SEARCH
  59. T{ S1 S2 SEARCH -> S1 TRUE }T
  60. T{ S1 S3 SEARCH -> S1 9 /STRING TRUE }T
  61. T{ S1 S4 SEARCH -> S1 25 /STRING TRUE }T
  62. T{ S1 S5 SEARCH -> S1 FALSE }T
  63. T{ S1 S6 SEARCH -> S1 FALSE }T
  64. T{ S1 S7 SEARCH -> S1 TRUE }T
  65. T{ S7 PAD 0 SEARCH -> S7 TRUE }T
  66. \ ------------------------------------------------------------------------------
  67. TESTING COMPARE
  68. T{ S1 S1 COMPARE -> 0 }T
  69. T{ S1 PAD SWAP CMOVE -> }T
  70. T{ S1 PAD OVER COMPARE -> 0 }T
  71. T{ S1 PAD 6 COMPARE -> 1 }T
  72. T{ PAD 10 S1 COMPARE -> -1 }T
  73. T{ S1 PAD 0 COMPARE -> 1 }T
  74. T{ PAD 0 S1 COMPARE -> -1 }T
  75. T{ S1 S6 COMPARE -> 1 }T
  76. T{ S6 S1 COMPARE -> -1 }T
  77. T{ S7 PAD 0 COMPARE -> 0 }T
  78. : "abdde" S" abdde" ;
  79. : "abbde" S" abbde" ;
  80. : "abcdf" S" abcdf" ;
  81. : "abcdee" S" abcdee" ;
  82. T{ S1 "abdde" COMPARE -> -1 }T
  83. T{ S1 "abbde" COMPARE -> 1 }T
  84. T{ S1 "abcdf" COMPARE -> -1 }T
  85. T{ S1 "abcdee" COMPARE -> 1 }T
  86. : S11 S" 0abc" ;
  87. : S12 S" 0aBc" ;
  88. T{ S11 S12 COMPARE -> 1 }T
  89. T{ S12 S11 COMPARE -> -1 }T
  90. \ ------------------------------------------------------------------------------
  91. TESTING CMOVE and CMOVE>
  92. PAD 30 CHARS 0 FILL
  93. T{ S1 PAD SWAP CMOVE -> }T
  94. T{ S1 PAD S1 SWAP DROP COMPARE -> 0 }T
  95. T{ S6 PAD 10 CHARS + SWAP CMOVE -> }T
  96. T{ S" abcdefghij12345pqrstuvwxyz" PAD S1 SWAP DROP COMPARE -> 0 }T
  97. T{ PAD 15 CHARS + PAD CHAR+ 6 CMOVE -> }T
  98. T{ S" apqrstuhij12345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T
  99. T{ PAD PAD 3 CHARS + 7 CMOVE -> }T
  100. T{ S" apqapqapqa12345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T
  101. T{ PAD PAD CHAR+ 10 CMOVE -> }T
  102. T{ S" aaaaaaaaaaa2345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T
  103. T{ S7 PAD 14 CHARS + SWAP CMOVE -> }T
  104. T{ S" aaaaaaaaaaa2345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T
  105. PAD 30 CHARS 0 FILL
  106. T{ S1 PAD SWAP CMOVE> -> }T
  107. T{ S1 PAD S1 SWAP DROP COMPARE -> 0 }T
  108. T{ S6 PAD 10 CHARS + SWAP CMOVE> -> }T
  109. T{ S" abcdefghij12345pqrstuvwxyz" PAD S1 SWAP DROP COMPARE -> 0 }T
  110. T{ PAD 15 CHARS + PAD CHAR+ 6 CMOVE> -> }T
  111. T{ S" apqrstuhij12345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T
  112. T{ PAD 13 CHARS + PAD 10 CHARS + 7 CMOVE> -> }T
  113. T{ S" apqrstuhijtrstrstrstuvwxyz" PAD 26 COMPARE -> 0 }T
  114. T{ PAD 12 CHARS + PAD 11 CHARS + 10 CMOVE> -> }T
  115. T{ S" apqrstuhijtvvvvvvvvvvvwxyz" PAD 26 COMPARE -> 0 }T
  116. T{ S7 PAD 14 CHARS + SWAP CMOVE> -> }T
  117. T{ S" apqrstuhijtvvvvvvvvvvvwxyz" PAD 26 COMPARE -> 0 }T
  118. \ ------------------------------------------------------------------------------
  119. TESTING BLANK
  120. : S13 S" aaaaa a" ; \ Don't move this down or might corrupt PAD
  121. T{ PAD 25 CHAR a FILL -> }T
  122. T{ PAD 5 CHARS + 6 BLANK -> }T
  123. T{ PAD 12 S13 COMPARE -> 0 }T
  124. \ ------------------------------------------------------------------------------
  125. TESTING SLITERAL
  126. T{ HERE DUP S1 DUP ALLOT ROT SWAP CMOVE S1 SWAP DROP 2CONSTANT S1A -> }T
  127. T{ : S14 [ S1A ] SLITERAL ; -> }T
  128. T{ S1A S14 COMPARE -> 0 }T
  129. T{ S1A DROP S14 DROP = -> FALSE }T
  130. \ ------------------------------------------------------------------------------
  131. 0 [IF] \ {
  132. TESTING UNESCAPE
  133. CREATE BUF 48 CHARS ALLOT
  134. \ $CHECK AND $CHECKN return f = 0 if caddr1 = buf and string1 = string2
  135. : $CHECK ( caddr1 u1 caddr2 u2 -- f ) 2SWAP OVER buf <> >R COMPARE R> or ;
  136. : $CHECKN ( caddr1 u1 n caddr2 u2 -- f n ) ROT >R $CHECK R> ;
  137. T{ 123 BUF C! S" " BUF UNESCAPE BUF 0 $CHECK -> FALSE }T
  138. T{ BUF C@ -> 123 }T
  139. T{ S" unchanged" buf UNESCAPE S" unchanged" $CHECK -> FALSE }T
  140. T{ S" %" BUF UNESCAPE S" %%" $CHECK -> FALSE }T
  141. T{ S" %%%" BUF UNESCAPE S" %%%%%%" $CHECK -> FALSE }T
  142. T{ S" abc%def" BUF UNESCAPE S" abc%%def" $CHECK -> FALSE }T
  143. T{ : TEST-UNESCAPE S" %abc%def%%ghi%" BUF UNESCAPE ; -> }T \ Compile check
  144. T{ TEST-UNESCAPE S" %%abc%%def%%%%ghi%%" $CHECK -> FALSE }T
  145. TESTING SUBSTITUTE REPLACES
  146. T{ S" abcdef" BUF 20 SUBSTITUTE S" abcdef" $CHECKN -> FALSE 0 }T \ Unchanged
  147. T{ S" " BUF 20 SUBSTITUTE S" " $CHECKN -> FALSE 0 }T \ Zero length string
  148. T{ S" %%" BUF 20 SUBSTITUTE S" %" $CHECKN -> FALSE 0 }T \ %% --> %
  149. T{ S" %%%%%%" BUF 25 SUBSTITUTE S" %%%" $CHECKN -> FALSE 0 }T
  150. T{ S" %%%%%%%" BUF 25 SUBSTITUTE S" %%%%" $CHECKN -> FALSE 0 }T \ Odd no. %'s
  151. : MAC1 S" mac1" ; : MAC2 S" mac2" ; : MAC3 S" mac3" ;
  152. T{ S" wxyz" MAC1 REPLACES -> }T
  153. T{ S" %mac1%" BUF 20 SUBSTITUTE S" wxyz" $CHECKN -> FALSE 1 }T
  154. T{ S" abc%mac1%d" BUF 20 SUBSTITUTE S" abcwxyzd" $CHECKN -> FALSE 1 }T
  155. T{ : SUBST BUF 20 SUBSTITUTE ; -> }T \ Check it compiles
  156. T{ S" defg%mac1%hi" SUBST S" defgwxyzhi" $CHECKN -> FALSE 1 }T
  157. T{ S" 12" MAC2 REPLACES -> }T
  158. T{ S" %mac1%mac2" BUF 20 SUBSTITUTE S" wxyzmac2" $CHECKN -> FALSE 1 }T
  159. T{ S" abc %mac2% def%mac1%gh" BUF 20 SUBSTITUTE S" abc 12 defwxyzgh" $CHECKN
  160. -> FALSE 2 }T
  161. T{ : REPL ( caddr1 u1 "name" -- ) PARSE-NAME REPLACES ; -> }T
  162. T{ S" " REPL MAC3 -> }T \ Check compiled version
  163. T{ S" abc%mac3%def%mac1%gh" BUF 20 SUBSTITUTE S" abcdefwxyzgh" $CHECKN
  164. -> FALSE 2 }T \ Zero length string substituted
  165. T{ S" %mac3%" BUF 10 SUBSTITUTE S" " $CHECKN
  166. -> FALSE 1 }T \ Zero length string substituted
  167. T{ S" abc%%mac1%%%mac2%" BUF 20 SUBSTITUTE S" abc%mac1%12" $CHECKN
  168. -> FALSE 1 }T \ Check substitution is single pass
  169. T{ S" %mac3%" MAC3 REPLACES -> }T
  170. T{ S" a%mac3%b" BUF 20 SUBSTITUTE S" a%mac3%b" $CHECKN
  171. -> FALSE 1 }T \ Check non-recursive
  172. T{ S" %%" MAC3 REPLACES -> }T
  173. T{ S" abc%mac1%de%mac3%g%mac2%%%%mac1%hij" BUF 30 SUBSTITUTE
  174. S" abcwxyzde%%g12%wxyzhij" $CHECKN -> FALSE 4 }T
  175. T{ S" ab%mac4%c" BUF 20 SUBSTITUTE S" ab%mac4%c" $CHECKN
  176. -> FALSE 0 }T \ Non-substitution name passed unchanged
  177. T{ S" %mac2%%mac5%" BUF 20 SUBSTITUTE S" 12%mac5%" $CHECKN
  178. -> FALSE 1 }T \ Non-substitution name passed unchanged
  179. T{ S" %mac5%" BUF 20 SUBSTITUTE S" %mac5%" $CHECKN
  180. -> FALSE 0 }T \ Non-substitution name passed unchanged
  181. \ Check UNESCAPE SUBSTITUTE leaves a string unchanged
  182. T{ S" %mac1%" BUF 30 CHARS + UNESCAPE BUF 10 SUBSTITUTE S" %mac1%" $CHECKN
  183. -> FALSE 0 }T
  184. \ Check with odd numbers of % characters, last is passed unchanged
  185. T{ S" %" BUF 10 SUBSTITUTE S" %" $CHECKN -> FALSE 0 }T
  186. T{ S" %abc" BUF 10 SUBSTITUTE S" %abc" $CHECKN -> FALSE 0 }T
  187. T{ S" abc%" BUF 10 SUBSTITUTE S" abc%" $CHECKN -> FALSE 0 }T
  188. T{ S" abc%mac1" BUF 10 SUBSTITUTE S" abc%mac1" $CHECKN -> FALSE 0 }T
  189. T{ S" abc%mac1%d%%e%mac2%%mac3" BUF 20 SUBSTITUTE
  190. S" abcwxyzd%e12%mac3" $CHECKN -> FALSE 2 }T
  191. \ Check for errors
  192. T{ S" abcd" BUF 4 SUBSTITUTE S" abcd" $CHECKN -> FALSE 0 }T \ Just fits
  193. T{ S" abcd" BUF 3 SUBSTITUTE ROT ROT 2DROP 0< -> TRUE }T \ Just too long
  194. T{ S" abcd" BUF 0 SUBSTITUTE ROT ROT 2DROP 0< -> TRUE }T
  195. T{ S" zyxwvutsr" MAC3 REPLACES -> }T
  196. T{ S" abc%mac3%d" BUF 10 SUBSTITUTE ROT ROT 2DROP 0< -> TRUE }T
  197. \ Conditional test for overlapping strings to go here including the case where
  198. \ caddr1 = caddr2. If a system cannot handle overlapping strings it should
  199. \ return n < 0 with (caddr2 u2) undefined. If it can handle them correctly
  200. \ it should return the usual results for success. The following definition
  201. \ applies the appropriate tests depending on whether n < 0 or not.
  202. \ Return ( f n ) where f = TRUE if:
  203. \ n >= 0 and (bufad = caddr1)
  204. \ and (string1 = string2)
  205. \ or n < 0
  206. : SUBST-N? ( n1 n2 -- f ) \ True if n1<0 or n1>=0 and n1=n2 )
  207. OVER 0< IF DROP 0< 0= ELSE = THEN
  208. ;
  209. \ Check the result of overlapped-subst
  210. \ n2 is expected number of substitutions, caddr2 u2 the expected result
  211. : CHECK-SUBST ( caddr1 u1 bufad n n2 caddr2 u2 -- f )
  212. >R >R ROT >R SUBST-N? ( -- caddr1 u1 f1 )
  213. IF
  214. OVER R> = \ Check caddr1 = bufad
  215. IF
  216. R> R> COMPARE 0= EXIT \ Check string1 = string2
  217. THEN
  218. ELSE
  219. R> DROP
  220. THEN
  221. R> R> 2DROP 2DROP FALSE
  222. ;
  223. \ Copy string to (buf+u2) and expect substitution result at (buf+u3)
  224. \ u4 is length of result buffer
  225. \ then execute SUBSTITUTE and check the result
  226. : OVERLAPPED-SUBST ( caddr1 u1 u2 u3 u4 -- caddr5 u5 bufad n )
  227. >R >R ( -- caddr1 u1 u2 ) ( R: -- u4 u3 )
  228. CHARS BUF + SWAP ( -- caddr1 buf+u2' u1 )
  229. DUP >R OVER >R MOVE ( -- ) ( R: -- u4 u3 u1 buf+u2')
  230. R> R> BUF R> CHARS + R> ( -- buf+u2 u1 buf+u3' u4 )
  231. OVER >R SUBSTITUTE R> SWAP ( -- caddr5 u5 buf+u3 n )
  232. ;
  233. T{ S" zyxwvut" MAC3 REPLACES -> }T
  234. T{ S" zyx" MAC2 REPLACES -> }T
  235. T{ S" a%mac3%b" 0 9 20 OVERLAPPED-SUBST 1 S" azyxwvutb" CHECK-SUBST -> TRUE }T
  236. T{ S" a%mac3%b" 0 3 20 OVERLAPPED-SUBST 1 S" azyxwvutb" CHECK-SUBST -> TRUE }T
  237. T{ S" a%mac2%b" 0 3 20 OVERLAPPED-SUBST 1 S" azyxb" CHECK-SUBST -> TRUE }T
  238. T{ S" abcdefgh" 0 0 20 OVERLAPPED-SUBST 0 S" abcdefgh" CHECK-SUBST -> TRUE }T
  239. T{ S" a%mac3%b" 3 0 20 OVERLAPPED-SUBST 1 S" azyxwvutb" CHECK-SUBST -> TRUE }T
  240. T{ S" a%mac3%b" 9 0 20 OVERLAPPED-SUBST 1 S" azyxwvutb" CHECK-SUBST -> TRUE }T
  241. \ Definition using a name on the stack
  242. : $CREATE ( caddr u -- )
  243. S" name" REPLACES ( -- )
  244. S" CREATE %name%" BUF 40 SUBSTITUTE
  245. 0 > IF EVALUATE THEN
  246. ;
  247. t{ S" SUBST2" $CREATE 123 , -> }t
  248. t{ SUBST2 @ -> 123 }t
  249. [THEN] \ }
  250. \ ------------------------------------------------------------------------------
  251. STRING-ERRORS SET-ERROR-COUNT
  252. CR .( End of String word tests) CR