/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. 

  2. 

    3. 

  3. \ This program was written by Gerry Jackson in 2006, with contributions from

    4. 

  4. \ others where indicated, and is in the public domain - it can be distributed

    5. 

  5. \ and/or modified in any way but please retain this notice.

    6. 

  6. 

    7. 

  7. \ This program is distributed in the hope that it will be useful,

    8. 

  8. \ but WITHOUT ANY WARRANTY; without even the implied warranty of

    9. 

  9. \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

    10. 

  10. 

    11. 

  11. \ The tests are not claimed to be comprehensive or correct 

    12. 

  12. 

    13. 

  13. \ ------------------------------------------------------------------------------

    14. 

  14. \ Version 0.11 25 April 2015 Tests for REPLACES SUBSTITUTE UNESCAPE added

    15. 

  15. \         0.6 1 April 2012 Tests placed in the public domain.

    16. 

  16. \         0.5 29 April 2010 Added tests for SEARCH and COMPARE with

    17. 

  17. \             all strings zero length (suggested by Krishna Myneni).

    18. 

  18. \             SLITERAL test amended in line with comp.lang.forth

    19. 

  19. \             discussion

    20. 

  20. \         0.4 30 November 2009 <true> and <false> replaced with TRUE

    21. 

  21. \             and FALSE

    22. 

  22. \         0.3 6 March 2009 { and } replaced with T{ and }T

    23. 

  23. \         0.2 20 April 2007 ANS Forth words changed to upper case

    24. 

  24. \         0.1 Oct 2006 First version released

    25. 

  25. 

    26. 

  26. \ ------------------------------------------------------------------------------

    27. 

  27. \ The tests are based on John Hayes test program for the core word set

    28. 

  28. \ and requires those files to have been loaded

    29. 

  29. 

    30. 

  30. \ Words tested in this file are:

    31. 

  31. \     -TRAILING /STRING BLANK CMOVE CMOVE> COMPARE SEARCH SLITERAL

    32. 

  32. \     REPLACES SUBSTITUTE UNESCAPE

    33. 

  33. \

    34. 

  34. \ ------------------------------------------------------------------------------

    35. 

  35. \ Assumptions and dependencies:

    36. 

  36. \     - tester.fr or ttester.fs has been loaded prior to this file

    37. 

  37. \     - COMPARE is case sensitive

    38. 

  38. \ ------------------------------------------------------------------------------

    39. 

  39. 

    40. 

  40. TESTING String word set

    41. 

  41. 

    42. 

  42. DECIMAL

    43. 

  43. 

    44. 

  44. T{ :  S1 S" abcdefghijklmnopqrstuvwxyz" ; -> }T

    45. 

  45. T{ :  S2 S" abc"   ; -> }T

    46. 

  46. T{ :  S3 S" jklmn" ; -> }T

    47. 

  47. T{ :  S4 S" z"     ; -> }T

    48. 

  48. T{ :  S5 S" mnoq"  ; -> }T

    49. 

  49. T{ :  S6 S" 12345" ; -> }T

    50. 

  50. T{ :  S7 S" "      ; -> }T

    51. 

  51. T{ :  S8 S" abc  " ; -> }T

    52. 

  52. T{ :  S9 S"      " ; -> }T

    53. 

  53. T{ : S10 S"    a " ; -> }T

    54. 

  54. 

    55. 

  55. \ ------------------------------------------------------------------------------

    56. 

  56. TESTING -TRAILING

    57. 

  57. 

    58. 

  58. T{  S1 -TRAILING -> S1 }T

    59. 

  59. T{  S8 -TRAILING -> S8 2 - }T

    60. 

  60. T{  S7 -TRAILING -> S7 }T

    61. 

  61. T{  S9 -TRAILING -> S9 DROP 0 }T

    62. 

  62. T{ S10 -TRAILING -> S10 1- }T

    63. 

  63. 

    64. 

  64. \ ------------------------------------------------------------------------------

    65. 

  65. TESTING /STRING

    66. 

  66. 

    67. 

  67. T{ S1  5 /STRING -> S1 SWAP 5 + SWAP 5 - }T

    68. 

  68. T{ S1 10 /STRING -4 /STRING -> S1 6 /STRING }T

    69. 

  69. T{ S1  0 /STRING -> S1 }T

    70. 

  70. 

    71. 

  71. \ ------------------------------------------------------------------------------

    72. 

  72. TESTING SEARCH

    73. 

  73. 

    74. 

  74. T{ S1 S2 SEARCH -> S1 TRUE }T

    75. 

  75. T{ S1 S3 SEARCH -> S1  9 /STRING TRUE }T

    76. 

  76. T{ S1 S4 SEARCH -> S1 25 /STRING TRUE }T

    77. 

  77. T{ S1 S5 SEARCH -> S1 FALSE }T

    78. 

  78. T{ S1 S6 SEARCH -> S1 FALSE }T

    79. 

  79. T{ S1 S7 SEARCH -> S1 TRUE }T

    80. 

  80. T{ S7 PAD 0 SEARCH -> S7 TRUE }T

    81. 

  81. 

    82. 

  82. \ ------------------------------------------------------------------------------

    83. 

  83. TESTING COMPARE

    84. 

  84. 

    85. 

  85. T{ S1 S1 COMPARE -> 0 }T

    86. 

  86. T{ S1 PAD SWAP CMOVE -> }T

    87. 

  87. T{ S1 PAD OVER COMPARE -> 0 }T

    88. 

  88. T{ S1 PAD 6 COMPARE -> 1 }T

    89. 

  89. T{ PAD 10 S1 COMPARE -> -1 }T

    90. 

  90. T{ S1 PAD 0 COMPARE -> 1 }T

    91. 

  91. T{ PAD 0 S1 COMPARE -> -1 }T

    92. 

  92. T{ S1 S6 COMPARE ->  1 }T

    93. 

  93. T{ S6 S1 COMPARE -> -1 }T

    94. 

  94. T{ S7 PAD 0 COMPARE -> 0 }T

    95. 

  95. 

    96. 

  96. : "abdde"  S" abdde" ;

    97. 

  97. : "abbde"  S" abbde" ;

    98. 

  98. : "abcdf"  S" abcdf" ;

    99. 

  99. : "abcdee" S" abcdee" ;

    100. 

  100. 

    101. 

  101. T{ S1 "abdde" COMPARE -> -1 }T

    102. 

  102. T{ S1 "abbde" COMPARE ->  1 }T

    103. 

  103. T{ S1 "abcdf"  COMPARE -> -1 }T

    104. 

  104. T{ S1 "abcdee" COMPARE ->  1 }T

    105. 

  105. 

    106. 

  106. : S11 S" 0abc" ;

    107. 

  107. : S12 S" 0aBc" ;

    108. 

  108. 

    109. 

  109. T{ S11 S12  COMPARE -> 1 }T

    110. 

  110. T{ S12 S11  COMPARE -> -1 }T

    111. 

  111. 

    112. 

  112. \ ------------------------------------------------------------------------------

    113. 

  113. TESTING CMOVE and CMOVE>

    114. 

  114. 

    115. 

  115. PAD 30 CHARS 0 FILL

    116. 

  116. T{ S1 PAD SWAP CMOVE -> }T

    117. 

  117. T{ S1 PAD S1 SWAP DROP COMPARE -> 0 }T

    118. 

  118. T{ S6 PAD 10 CHARS + SWAP CMOVE -> }T

    119. 

  119. T{ S" abcdefghij12345pqrstuvwxyz" PAD S1 SWAP DROP COMPARE -> 0 }T

    120. 

  120. T{ PAD 15 CHARS + PAD CHAR+ 6 CMOVE -> }T

    121. 

  121. T{ S" apqrstuhij12345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T

    122. 

  122. T{ PAD PAD 3 CHARS + 7 CMOVE -> }T

    123. 

  123. T{ S" apqapqapqa12345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T

    124. 

  124. T{ PAD PAD CHAR+ 10 CMOVE -> }T

    125. 

  125. T{ S" aaaaaaaaaaa2345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T

    126. 

  126. T{ S7 PAD 14 CHARS + SWAP CMOVE -> }T

    127. 

  127. T{ S" aaaaaaaaaaa2345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T

    128. 

  128. 

    129. 

  129. PAD 30 CHARS 0 FILL

    130. 

  130. 

    131. 

  131. T{ S1 PAD SWAP CMOVE> -> }T

    132. 

  132. T{ S1 PAD S1 SWAP DROP COMPARE -> 0 }T

    133. 

  133. T{ S6 PAD 10 CHARS + SWAP CMOVE> -> }T

    134. 

  134. T{ S" abcdefghij12345pqrstuvwxyz" PAD S1 SWAP DROP COMPARE -> 0 }T

    135. 

  135. T{ PAD 15 CHARS + PAD CHAR+ 6 CMOVE> -> }T

    136. 

  136. T{ S" apqrstuhij12345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T

    137. 

  137. T{ PAD 13 CHARS + PAD 10 CHARS + 7 CMOVE> -> }T

    138. 

  138. T{ S" apqrstuhijtrstrstrstuvwxyz" PAD 26 COMPARE -> 0 }T

    139. 

  139. T{ PAD 12 CHARS + PAD 11 CHARS + 10 CMOVE> -> }T

    140. 

  140. T{ S" apqrstuhijtvvvvvvvvvvvwxyz" PAD 26 COMPARE -> 0 }T

    141. 

  141. T{ S7 PAD 14 CHARS + SWAP CMOVE> -> }T

    142. 

  142. T{ S" apqrstuhijtvvvvvvvvvvvwxyz" PAD 26 COMPARE -> 0 }T

    143. 

  143. 

    144. 

  144. \ ------------------------------------------------------------------------------

    145. 

  145. TESTING BLANK

    146. 

  146. 

    147. 

  147. : S13 S" aaaaa      a" ;   \ Don't move this down or might corrupt PAD

    148. 

  148. 

    149. 

  149. T{ PAD 25 CHAR a FILL -> }T

    150. 

  150. T{ PAD 5 CHARS + 6 BLANK -> }T

    151. 

  151. T{ PAD 12 S13 COMPARE -> 0 }T

    152. 

  152. 

    153. 

  153. \ ------------------------------------------------------------------------------

    154. 

  154. TESTING SLITERAL

    155. 

  155. 

    156. 

  156. T{ HERE DUP S1 DUP ALLOT ROT SWAP CMOVE S1 SWAP DROP 2CONSTANT S1A -> }T

    157. 

  157. T{ : S14 [ S1A ] SLITERAL ; -> }T

    158. 

  158. T{ S1A S14 COMPARE -> 0 }T

    159. 

  159. T{ S1A DROP S14 DROP = -> FALSE }T

    160. 

  160. 

    161. 

  161. \ ------------------------------------------------------------------------------

    162. 

  162. 0 [IF]    \ {

    163. 

  163. TESTING UNESCAPE

    164. 

  164. 

    165. 

  165. CREATE BUF 48 CHARS ALLOT

    166. 

  166. 

    167. 

  167. \ $CHECK AND $CHECKN return f = 0 if caddr1 = buf and string1 = string2

    168. 

  168. : $CHECK   ( caddr1 u1 caddr2 u2 -- f )  2SWAP OVER buf <> >R COMPARE R> or ;

    169. 

  169. : $CHECKN  ( caddr1 u1 n caddr2 u2 -- f n )  ROT >R $CHECK R> ;

    170. 

  170. 

    171. 

  171. T{ 123 BUF C! S" " BUF UNESCAPE BUF 0 $CHECK -> FALSE }T

    172. 

  172. T{ BUF C@ -> 123 }T

    173. 

  173. T{ S" unchanged" buf UNESCAPE S" unchanged" $CHECK -> FALSE }T

    174. 

  174. T{ S" %" BUF UNESCAPE S" %%" $CHECK -> FALSE }T

    175. 

  175. T{ S" %%%" BUF UNESCAPE S" %%%%%%" $CHECK -> FALSE }T

    176. 

  176. T{ S" abc%def" BUF UNESCAPE S" abc%%def" $CHECK -> FALSE }T

    177. 

  177. T{ : TEST-UNESCAPE S" %abc%def%%ghi%" BUF UNESCAPE ; -> }T \ Compile check

    178. 

  178. T{ TEST-UNESCAPE S" %%abc%%def%%%%ghi%%" $CHECK -> FALSE }T

    179. 

  179. 

    180. 

  180. TESTING SUBSTITUTE REPLACES

    181. 

  181. 

    182. 

  182. T{ S" abcdef" BUF 20 SUBSTITUTE S" abcdef" $CHECKN -> FALSE 0 }T \ Unchanged

    183. 

  183. T{ S" " BUF 20 SUBSTITUTE S" " $CHECKN -> FALSE 0 }T           \ Zero length string

    184. 

  184. T{ S" %%" BUF 20 SUBSTITUTE S" %" $CHECKN -> FALSE 0 }T         \ %% --> %

    185. 

  185. T{ S" %%%%%%" BUF 25 SUBSTITUTE S" %%%" $CHECKN -> FALSE 0 }T

    186. 

  186. T{ S" %%%%%%%" BUF 25 SUBSTITUTE S" %%%%" $CHECKN -> FALSE 0 }T \ Odd no. %'s

    187. 

  187. 

    188. 

  188. : MAC1 S" mac1" ;  : MAC2 S" mac2" ;  : MAC3 S" mac3" ;

    189. 

  189. 

    190. 

  190. T{ S" wxyz" MAC1 REPLACES -> }T

    191. 

  191. T{ S" %mac1%" BUF 20 SUBSTITUTE S" wxyz" $CHECKN -> FALSE 1 }T

    192. 

  192. T{ S" abc%mac1%d" BUF 20 SUBSTITUTE S" abcwxyzd" $CHECKN -> FALSE 1 }T

    193. 

  193. T{ : SUBST BUF 20 SUBSTITUTE ; -> }T   \ Check it compiles

    194. 

  194. T{ S" defg%mac1%hi" SUBST S" defgwxyzhi" $CHECKN -> FALSE 1 }T

    195. 

  195. T{ S" 12" MAC2 REPLACES -> }T

    196. 

  196. T{ S" %mac1%mac2" BUF 20 SUBSTITUTE S" wxyzmac2" $CHECKN -> FALSE 1 }T

    197. 

  197. T{ S" abc %mac2% def%mac1%gh" BUF 20 SUBSTITUTE S" abc 12 defwxyzgh" $CHECKN

    198. 

  198.       -> FALSE 2 }T

    199. 

  199. T{ : REPL  ( caddr1 u1 "name" -- )  PARSE-NAME REPLACES ; -> }T

    200. 

  200. T{ S" " REPL MAC3 -> }T    \ Check compiled version

    201. 

  201. T{ S" abc%mac3%def%mac1%gh" BUF 20 SUBSTITUTE S" abcdefwxyzgh" $CHECKN

    202. 

  202.       -> FALSE 2 }T      \ Zero length string substituted

    203. 

  203. T{ S" %mac3%" BUF 10 SUBSTITUTE S" " $CHECKN

    204. 

  204.       -> FALSE 1 }T      \ Zero length string substituted

    205. 

  205. T{ S" abc%%mac1%%%mac2%" BUF 20 SUBSTITUTE S" abc%mac1%12" $CHECKN

    206. 

  206.       -> FALSE 1 }T   \ Check substitution is single pass

    207. 

  207. T{ S" %mac3%" MAC3 REPLACES -> }T

    208. 

  208. T{ S" a%mac3%b" BUF 20 SUBSTITUTE S" a%mac3%b" $CHECKN

    209. 

  209.       -> FALSE 1 }T    \ Check non-recursive

    210. 

  210. T{ S" %%" MAC3 REPLACES -> }T

    211. 

  211. T{ S" abc%mac1%de%mac3%g%mac2%%%%mac1%hij" BUF 30 SUBSTITUTE

    212. 

  212.       S" abcwxyzde%%g12%wxyzhij" $CHECKN -> FALSE 4 }T

    213. 

  213. T{ S" ab%mac4%c" BUF 20 SUBSTITUTE S" ab%mac4%c" $CHECKN

    214. 

  214.       -> FALSE 0 }T   \ Non-substitution name passed unchanged

    215. 

  215. T{ S" %mac2%%mac5%" BUF 20 SUBSTITUTE S" 12%mac5%" $CHECKN

    216. 

  216.       -> FALSE 1 }T   \ Non-substitution name passed unchanged

    217. 

  217. T{ S" %mac5%" BUF 20 SUBSTITUTE S" %mac5%" $CHECKN

    218. 

  218.       -> FALSE 0 }T   \ Non-substitution name passed unchanged

    219. 

  219. 

    220. 

  220. \ Check UNESCAPE SUBSTITUTE leaves a string unchanged

    221. 

  221. T{ S" %mac1%" BUF 30 CHARS + UNESCAPE BUF 10 SUBSTITUTE S" %mac1%" $CHECKN

    222. 

  222.    -> FALSE 0 }T

    223. 

  223. 

    224. 

  224. \ Check with odd numbers of % characters, last is passed unchanged

    225. 

  225. T{ S" %" BUF 10 SUBSTITUTE S" %" $CHECKN -> FALSE 0 }T

    226. 

  226. T{ S" %abc" BUF 10 SUBSTITUTE S" %abc" $CHECKN -> FALSE 0 }T

    227. 

  227. T{ S" abc%" BUF 10 SUBSTITUTE S" abc%" $CHECKN -> FALSE 0 }T

    228. 

  228. T{ S" abc%mac1" BUF 10 SUBSTITUTE S" abc%mac1" $CHECKN -> FALSE 0 }T

    229. 

  229. T{ S" abc%mac1%d%%e%mac2%%mac3" BUF 20 SUBSTITUTE

    230. 

  230.       S" abcwxyzd%e12%mac3" $CHECKN -> FALSE 2 }T

    231. 

  231. 

    232. 

  232. \ Check for errors

    233. 

  233. T{ S" abcd" BUF 4 SUBSTITUTE S" abcd" $CHECKN -> FALSE 0 }T  \ Just fits

    234. 

  234. T{ S" abcd" BUF 3 SUBSTITUTE ROT ROT 2DROP 0< -> TRUE }T     \ Just too long

    235. 

  235. T{ S" abcd" BUF 0 SUBSTITUTE ROT ROT 2DROP 0< -> TRUE }T

    236. 

  236. T{ S" zyxwvutsr" MAC3 REPLACES -> }T

    237. 

  237. T{ S" abc%mac3%d" BUF 10 SUBSTITUTE ROT ROT 2DROP 0< -> TRUE }T

    238. 

  238. 

    239. 

  239. \ Conditional test for overlapping strings to go here including the case where

    240. 

  240. \ caddr1 = caddr2. If a system cannot handle overlapping strings it should

    241. 

  241. \ return n < 0 with (caddr2 u2) undefined. If it can handle them correctly

    242. 

  242. \ it should return the usual results for success. The following definition

    243. 

  243. \ applies the appropriate tests depending on whether n < 0 or not.

    244. 

  244. \ Return ( f n ) where f = TRUE if:

    245. 

  245. \   n >= 0 and (bufad = caddr1)

    246. 

  246. \          and (string1 = string2)

    247. 

  247. \   or n < 0

    248. 

  248. 

    249. 

  249. : SUBST-N?  ( n1 n2 -- f )  \ True if n1<0 or n1>=0 and n1=n2 )

    250. 

  250.    OVER 0< IF DROP 0< 0= ELSE = THEN

    251. 

  251. ;

    252. 

  252. 

    253. 

  253. \ Check the result of overlapped-subst

    254. 

  254. \ n2 is expected number of substitutions, caddr2 u2 the expected result

    255. 

  255. : CHECK-SUBST  ( caddr1 u1 bufad n n2 caddr2 u2 -- f )

    256. 

  256.    >R >R ROT >R SUBST-N?         ( -- caddr1 u1 f1 )

    257. 

  257.    IF

    258. 

  258.       OVER R> =                  \ Check caddr1 = bufad

    259. 

  259.       IF

    260. 

  260.          R> R> COMPARE 0= EXIT   \ Check string1 = string2

    261. 

  261.       THEN

    262. 

  262.    ELSE

    263. 

  263.       R> DROP

    264. 

  264.    THEN

    265. 

  265.    R> R> 2DROP 2DROP FALSE

    266. 

  266. ;

    267. 

  267. 

    268. 

  268. \ Copy string to (buf+u2) and expect substitution result at (buf+u3)

    269. 

  269. \ u4 is length of result buffer

    270. 

  270. \ then execute SUBSTITUTE and check the result

    271. 

  271. 

    272. 

  272. : OVERLAPPED-SUBST  ( caddr1 u1 u2 u3 u4 -- caddr5 u5 bufad n )

    273. 

  273.    >R >R                            ( -- caddr1 u1 u2 )  ( R: -- u4 u3 )

    274. 

  274.    CHARS BUF + SWAP                 ( -- caddr1 buf+u2' u1 )

    275. 

  275.    DUP >R OVER >R MOVE              ( -- )  ( R: -- u4 u3 u1 buf+u2') 

    276. 

  276.    R> R> BUF R> CHARS + R>          ( -- buf+u2 u1 buf+u3' u4 )

    277. 

  277.    OVER >R SUBSTITUTE R> SWAP       ( -- caddr5 u5 buf+u3 n )

    278. 

  278. ;

    279. 

  279. 

    280. 

  280. T{ S" zyxwvut" MAC3 REPLACES -> }T

    281. 

  281. T{ S" zyx"     MAC2 REPLACES -> }T

    282. 

  282. T{ S" a%mac3%b" 0 9 20 OVERLAPPED-SUBST 1 S" azyxwvutb" CHECK-SUBST -> TRUE }T

    283. 

  283. T{ S" a%mac3%b" 0 3 20 OVERLAPPED-SUBST 1 S" azyxwvutb" CHECK-SUBST -> TRUE }T

    284. 

  284. T{ S" a%mac2%b" 0 3 20 OVERLAPPED-SUBST 1 S" azyxb"     CHECK-SUBST -> TRUE }T

    285. 

  285. T{ S" abcdefgh" 0 0 20 OVERLAPPED-SUBST 0 S" abcdefgh"  CHECK-SUBST -> TRUE }T

    286. 

  286. T{ S" a%mac3%b" 3 0 20 OVERLAPPED-SUBST 1 S" azyxwvutb" CHECK-SUBST -> TRUE }T

    287. 

  287. T{ S" a%mac3%b" 9 0 20 OVERLAPPED-SUBST 1 S" azyxwvutb" CHECK-SUBST -> TRUE }T

    288. 

  288. 

    289. 

  289. \ Definition using a name on the stack

    290. 

  290. : $CREATE  ( caddr u -- )

    291. 

  291.    S" name" REPLACES          ( -- )

    292. 

  292.    S" CREATE %name%" BUF 40 SUBSTITUTE

    293. 

  293.    0 > IF EVALUATE THEN

    294. 

  294. ;

    295. 

  295. t{ S" SUBST2" $CREATE 123 , -> }t

    296. 

  296. t{ SUBST2 @ -> 123 }t

    297. 

  297. 

    298. 

  298. [THEN]  \ }

    299. 

  299. 

    300. 

  300. \ ------------------------------------------------------------------------------

    301. 

  301. 

    302. 

  302. STRING-ERRORS SET-ERROR-COUNT

    303. 

  303. 

    304. 

  304. CR .( End of String word tests) CR
    305.