source: project/release/5/srfi-13/trunk/tests/run.scm @ 34718

Last change on this file since 34718 was 34718, checked in by sjamaan, 21 months ago

release/5: Replace use by import in eggs

File size: 30.0 KB
Line 
1(import (chicken format) srfi-13 srfi-14 test)
2
3(define (fill text)
4  (let* ((len (string-length text))
5         (max-text-len 60)
6         (last-col 70)
7         (text (if (> len max-text-len)
8                   (begin
9                     (set! len max-text-len)
10                     (substring text 0 max-text-len))
11                   text)))
12    (string-append text (make-string (- last-col len) #\.))))
13
14; Tests for SRFI-13 as implemented by the Gauche scheme system.
15;;
16;;   Copyright (c) 2000-2003 Shiro Kawai, All rights reserved.
17;;
18;;   Redistribution and use in source and binary forms, with or without
19;;   modification, are permitted provided that the following conditions
20;;   are met:
21;;
22;;    1. Redistributions of source code must retain the above copyright
23;;       notice, this list of conditions and the following disclaimer.
24;;
25;;    2. Redistributions in binary form must reproduce the above copyright
26;;       notice, this list of conditions and the following disclaimer in the
27;;       documentation and/or other materials provided with the distribution.
28;;
29;;    3. Neither the name of the authors nor the names of its contributors
30;;       may be used to endorse or promote products derived from this
31;;       software without specific prior written permission.
32;;
33;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
34;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
35;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
36;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
37;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
38;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
39;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
40;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
41;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
42;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
43;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
44;;
45;; See http://sourceforge.net/projects/gauche/
46
47(test-begin "SRFI-13")
48
49(test "string-null?" #f (string-null? "abc"))
50(test "string-null?" #t (string-null? ""))
51(test "string-every" #t (string-every #\a ""))
52(test "string-every" #t (string-every #\a "aaaa"))
53(test "string-every" #f (string-every #\a "aaba"))
54(test "string-every" #t (string-every char-set:lower-case "aaba"))
55(test "string-every" #f (string-every char-set:lower-case "aAba"))
56(test "string-every" #t (string-every char-set:lower-case ""))
57(test "string-every" #t (string-every (lambda (x) (char-ci=? x #\a)) "aAaA"))
58(test "string-every" #f (string-every (lambda (x) (char-ci=? x #\a)) "aAbA"))
59(test "string-every" (char->integer #\A)
60       (string-every (lambda (x) (char->integer x)) "aAbA"))
61(test "string-every" #t
62       (string-every (lambda (x) (error "hoge")) ""))
63(test "string-any" #t (string-any #\a "aaaa"))
64(test "string-any" #f (string-any #\a "Abcd"))
65(test "string-any" #f (string-any #\a ""))
66(test "string-any" #t (string-any char-set:lower-case "ABcD"))
67(test "string-any" #f (string-any char-set:lower-case "ABCD"))
68(test "string-any" #f (string-any char-set:lower-case ""))
69(test "string-any" #t (string-any (lambda (x) (char-ci=? x #\a)) "CAaA"))
70(test "string-any" #f (string-any (lambda (x) (char-ci=? x #\a)) "ZBRC"))
71(test "string-any" #f (string-any (lambda (x) (char-ci=? x #\a)) ""))
72(test "string-any" (char->integer #\a)
73       (string-any (lambda (x) (char->integer x)) "aAbA"))
74(test "string-tabulate" "0123456789"
75       (string-tabulate (lambda (code)
76                          (integer->char (+ code (char->integer #\0))))
77                        10))
78(test "string-tabulate" ""
79       (string-tabulate (lambda (code)
80                          (integer->char (+ code (char->integer #\0))))
81                        0))
82(test "reverse-list->string" "cBa"
83       (reverse-list->string '(#\a #\B #\c)))
84(test "reverse-list->string" ""
85       (reverse-list->string '()))
86; string-join : Gauche builtin.
87(test "substring/shared" "cde" (substring/shared "abcde" 2))
88(test "substring/shared" "cd"  (substring/shared "abcde" 2 4))
89(test "string-copy!" "abCDEfg"
90       (let ((x (string-copy "abcdefg")))
91         (string-copy! x 2 "CDE")
92         x))
93(test "string-copy!" "abCDEfg"
94       (let ((x (string-copy "abcdefg")))
95         (string-copy! x 2 "ZABCDE" 3)
96         x))
97(test "string-copy!" "abCDEfg"
98       (let ((x (string-copy "abcdefg")))
99         (string-copy! x 2 "ZABCDEFG" 3 6)
100         x))
101
102;; From Guile.  Thanks to Mark H Weaver.
103(test "string-copy!: overlapping src and dest, moving right"
104      "aabce"
105      (let ((str (string-copy "abcde")))
106        (string-copy! str 1 str 0 3) str))
107
108(test "string-copy!: overlapping src and dest, moving left"
109      "bcdde"
110      (let ((str (string-copy "abcde")))
111        (string-copy! str 0 str 1 4) str))
112
113(test "string-take" "Pete S"  (string-take "Pete Szilagyi" 6))
114(test "string-take" ""        (string-take "Pete Szilagyi" 0))
115(test "string-take" "Pete Szilagyi" (string-take "Pete Szilagyi" 13))
116(test "string-drop" "zilagyi" (string-drop "Pete Szilagyi" 6))
117(test "string-drop" "Pete Szilagyi" (string-drop "Pete Szilagyi" 0))
118(test "string-drop" ""        (string-drop "Pete Szilagyi" 13))
119
120(test "string-take-right" "rules" (string-take-right "Beta rules" 5))
121(test "string-take-right" ""      (string-take-right "Beta rules" 0))
122(test "string-take-right" "Beta rules" (string-take-right "Beta rules" 10))
123(test "string-drop-right" "Beta " (string-drop-right "Beta rules" 5))
124(test "string-drop-right" "Beta rules" (string-drop-right "Beta rules" 0))
125(test "string-drop-right" ""      (string-drop-right "Beta rules" 10))
126
127(test "string-pad" "  325" (string-pad "325" 5))
128(test "string-pad" "71325" (string-pad "71325" 5))
129(test "string-pad" "71325" (string-pad "8871325" 5))
130(test "string-pad" "~~325" (string-pad "325" 5 #\~))
131(test "string-pad" "~~~25" (string-pad "325" 5 #\~ 1))
132(test "string-pad" "~~~~2" (string-pad "325" 5 #\~ 1 2))
133(test "string-pad-right" "325  " (string-pad-right "325" 5))
134(test "string-pad-right" "71325" (string-pad-right "71325" 5))
135(test "string-pad-right" "88713" (string-pad-right "8871325" 5))
136(test "string-pad-right" "325~~" (string-pad-right "325" 5 #\~))
137(test "string-pad-right" "25~~~" (string-pad-right "325" 5 #\~ 1))
138(test "string-pad-right" "2~~~~" (string-pad-right "325" 5 #\~ 1 2))
139
140(test "string-trim"  "a b c d  \n"
141       (string-trim "  \t  a b c d  \n"))
142(test "string-trim"  "\t  a b c d  \n"
143       (string-trim "  \t  a b c d  \n" #\space))
144(test "string-trim"  "a b c d  \n"
145       (string-trim "4358948a b c d  \n" char-set:digit))
146
147(test "string-trim-right"  "  \t  a b c d"
148       (string-trim-right "  \t  a b c d  \n"))
149(test "string-trim-right"  "  \t  a b c d  "
150       (string-trim-right "  \t  a b c d  \n" (char-set #\newline)))
151(test "string-trim-right"  "349853a b c d"
152       (string-trim-right "349853a b c d03490" char-set:digit))
153
154(test "string-trim-both"  "a b c d"
155       (string-trim-both "  \t  a b c d  \n"))
156(test "string-trim-both"  "  \t  a b c d  "
157       (string-trim-both "  \t  a b c d  \n" (char-set #\newline)))
158(test "string-trim-both"  "a b c d"
159       (string-trim-both "349853a b c d03490" char-set:digit))
160
161;; string-fill - in string.scm
162
163(test "string-compare" 5
164       (string-compare "The cat in the hat" "abcdefgh"
165                       values values values
166                       4 6 2 4))
167(test "string-compare-ci" 5
168       (string-compare-ci "The cat in the hat" "ABCDEFGH"
169                          values values values
170                          4 6 2 4))
171
172;; TODO: bunch of string= families
173
174(test "string-prefix-length" 5
175       (string-prefix-length "cancaNCAM" "cancancan"))
176(test "string-prefix-length-ci" 8
177       (string-prefix-length-ci "cancaNCAM" "cancancan"))
178(test "string-suffix-length" 2
179       (string-suffix-length "CanCan" "cankancan"))
180(test "string-suffix-length-ci" 5
181       (string-suffix-length-ci "CanCan" "cankancan"))
182
183(test "string-prefix?" #t    (string-prefix? "abcd" "abcdefg"))
184(test "string-prefix?" #f    (string-prefix? "abcf" "abcdefg"))
185(test "string-prefix-ci?" #t (string-prefix-ci? "abcd" "aBCDEfg"))
186(test "string-prefix-ci?" #f (string-prefix-ci? "abcf" "aBCDEfg"))
187(test "string-suffix?" #t    (string-suffix? "defg" "abcdefg"))
188(test "string-suffix?" #f    (string-suffix? "aefg" "abcdefg"))
189(test "string-suffix-ci?" #t (string-suffix-ci? "defg" "aBCDEfg"))
190(test "string-suffix-ci?" #f (string-suffix-ci? "aefg" "aBCDEfg"))
191
192(test "string-index #1" 4
193       (string-index "abcd:efgh:ijkl" #\:))
194(test "string-index #2" 4
195       (string-index "abcd:efgh;ijkl" (char-set-complement char-set:letter)))
196(test "string-index #3" #f
197       (string-index "abcd:efgh;ijkl" char-set:digit))
198(test "string-index #4" 9
199       (string-index "abcd:efgh:ijkl" #\: 5))
200(test "string-index-right #1" 4
201       (string-index-right "abcd:efgh;ijkl" #\:))
202(test "string-index-right #2" 9
203       (string-index-right "abcd:efgh;ijkl" (char-set-complement char-set:letter)))
204(test "string-index-right #3" #f
205       (string-index-right "abcd:efgh;ijkl" char-set:digit))
206(test "string-index-right #4" 4
207       (string-index-right "abcd:efgh;ijkl" (char-set-complement char-set:letter) 2 5))
208
209(test "string-count #1" 2
210       (string-count "abc def\tghi jkl" #\space))
211(test "string-count #2" 3
212       (string-count "abc def\tghi jkl" char-set:whitespace))
213(test "string-count #3" 2
214       (string-count "abc def\tghi jkl" char-set:whitespace 4))
215(test "string-count #4" 1
216       (string-count "abc def\tghi jkl" char-set:whitespace 4 9))
217(test "string-contains" 3
218       (string-contains "Ma mere l'oye" "mer"))
219(test "string-contains" #f
220       (string-contains "Ma mere l'oye" "Mer"))
221(test "string-contains-ci" 3
222       (string-contains-ci "Ma mere l'oye" "Mer"))
223(test "string-contains-ci" #f
224       (string-contains-ci "Ma mere l'oye" "Meer"))
225
226(test "string-titlecase" "--Capitalize This Sentence."
227       (string-titlecase "--capitalize tHIS sentence."))
228(test "string-titlecase" "3Com Makes Routers."
229       (string-titlecase "3com makes routers."))
230(test "string-titlecase!" "alSo Whatever"
231       (let ((s (string-copy "also whatever")))
232         (string-titlecase! s 2 9)
233         s))
234
235(test "string-upcase" "SPEAK LOUDLY"
236       (string-upcase "speak loudly"))
237(test "string-upcase" "PEAK"
238       (string-upcase "speak loudly" 1 5))
239(test "string-upcase!" "sPEAK loudly"
240       (let ((s (string-copy "speak loudly")))
241         (string-upcase! s 1 5)
242         s))
243
244(test "string-downcase" "speak softly"
245       (string-downcase "SPEAK SOFTLY"))
246(test "string-downcase" "peak"
247       (string-downcase "SPEAK SOFTLY" 1 5))
248(test "string-downcase!" "Speak SOFTLY"
249       (let ((s (string-copy "SPEAK SOFTLY")))
250         (string-downcase! s 1 5)
251         s))
252
253(test "string-reverse" "nomel on nolem on"
254       (string-reverse "no melon no lemon"))
255(test "string-reverse" "nomel on"
256       (string-reverse "no melon no lemon" 9))
257(test "string-reverse" "on"
258       (string-reverse "no melon no lemon" 9 11))
259(test "string-reverse!" "nomel on nolem on"
260       (let ((s (string-copy "no melon no lemon")))
261         (string-reverse! s) s))
262(test "string-reverse!" "no melon nomel on"
263       (let ((s (string-copy "no melon no lemon")))
264         (string-reverse! s 9) s))
265(test "string-reverse!" "no melon on lemon"
266       (let ((s (string-copy "no melon no lemon")))
267         (string-reverse! s 9 11) s))
268
269(test "string-append" #f
270       (let ((s "test")) (eq? s (string-append s))))
271(test "string-concatenate" #f
272       (let ((s "test")) (eq? s (string-concatenate (list s)))))
273(test "string-concatenate" "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
274       (string-concatenate
275        '("A" "B" "C" "D" "E" "F" "G" "H"
276          "I" "J" "K" "L" "M" "N" "O" "P"
277          "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
278          "a" "b" "c" "d" "e" "f" "g" "h"
279          "i" "j" "k" "l" "m" "n" "o" "p"
280          "q" "r" "s" "t" "u" "v" "w" "x" "y" "z")))
281(test "string-concatenate/shared" "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
282       (string-concatenate/shared
283        '("A" "B" "C" "D" "E" "F" "G" "H"
284          "I" "J" "K" "L" "M" "N" "O" "P"
285          "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
286          "a" "b" "c" "d" "e" "f" "g" "h"
287          "i" "j" "k" "l" "m" "n" "o" "p"
288          "q" "r" "s" "t" "u" "v" "w" "x" "y" "z")))
289(test "string-concatenate-reverse" "zyxwvutsrqponmlkjihgfedcbaZYXWVUTSRQPONMLKJIHGFEDCBA"
290       (string-concatenate-reverse
291        '("A" "B" "C" "D" "E" "F" "G" "H"
292          "I" "J" "K" "L" "M" "N" "O" "P"
293          "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
294          "a" "b" "c" "d" "e" "f" "g" "h"
295          "i" "j" "k" "l" "m" "n" "o" "p"
296          "q" "r" "s" "t" "u" "v" "w" "x" "y" "z")))
297(test "string-concatenate-reverse" #f
298       (let ((s "test"))
299         (eq? s (string-concatenate-reverse (list s)))))
300(test "string-concatenate-reverse/shared" "zyxwvutsrqponmlkjihgfedcbaZYXWVUTSRQPONMLKJIHGFEDCBA"
301       (string-concatenate-reverse/shared
302        '("A" "B" "C" "D" "E" "F" "G" "H"
303          "I" "J" "K" "L" "M" "N" "O" "P"
304          "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
305          "a" "b" "c" "d" "e" "f" "g" "h"
306          "i" "j" "k" "l" "m" "n" "o" "p"
307          "q" "r" "s" "t" "u" "v" "w" "x" "y" "z")))
308
309(test "string-map" "svool"
310       (string-map (lambda (c)
311                     (integer->char (- 219 (char->integer c))))
312                   "hello"))
313(test "string-map" "vool"
314       (string-map (lambda (c)
315                     (integer->char (- 219 (char->integer c))))
316                   "hello" 1))
317(test "string-map" "vo"
318       (string-map (lambda (c)
319                     (integer->char (- 219 (char->integer c))))
320                   "hello" 1 3))
321(test "string-map!" "svool"
322       (let ((s (string-copy "hello")))
323         (string-map! (lambda (c)
324                        (integer->char (- 219 (char->integer c))))
325                      s)
326         s))
327(test "string-map!" "hvool"
328       (let ((s (string-copy "hello")))
329         (string-map! (lambda (c)
330                        (integer->char (- 219 (char->integer c))))
331                      s 1)
332         s))
333(test "string-map!" "hvolo"
334       (let ((s (string-copy "hello")))
335         (string-map! (lambda (c)
336                        (integer->char (- 219 (char->integer c))))
337                      s 1 3)
338         s))
339
340(test "string-fold" '(#\o #\l #\l #\e #\h . #t)
341       (string-fold cons #t "hello"))
342(test "string-fold" '(#\l #\e . #t)
343       (string-fold cons #t "hello" 1 3))
344(test "string-fold-right" '(#\h #\e #\l #\l #\o . #t)
345       (string-fold-right cons #t "hello"))
346(test "string-fold-right" '(#\e #\l . #t)
347       (string-fold-right cons #t "hello" 1 3))
348
349(test "string-unfold" "hello"
350       (string-unfold null? car cdr '(#\h #\e #\l #\l #\o)))
351(test "string-unfold" "hi hello"
352       (string-unfold null? car cdr '(#\h #\e #\l #\l #\o) "hi "))
353(test "string-unfold" "hi hello ho"
354       (string-unfold null? car cdr
355                      '(#\h #\e #\l #\l #\o) "hi "
356                      (lambda (x) " ho")))
357
358(test "string-unfold-right" "olleh"
359       (string-unfold-right null? car cdr '(#\h #\e #\l #\l #\o)))
360(test "string-unfold-right" "olleh hi"
361       (string-unfold-right null? car cdr '(#\h #\e #\l #\l #\o) " hi"))
362(test "string-unfold-right" "ho olleh hi"
363       (string-unfold-right null? car cdr
364                            '(#\h #\e #\l #\l #\o) " hi"
365                            (lambda (x) "ho ")))
366
367(test "string-for-each" "CLtL"
368       (let ((out (open-output-string))
369             (prev #f))
370         (string-for-each (lambda (c)
371                            (if (or (not prev)
372                                    (char-whitespace? prev))
373                                (write-char c out))
374                            (set! prev c))
375                          "Common Lisp, the Language")
376
377         (get-output-string out)))
378(test "string-for-each" "oLtL"
379       (let ((out (open-output-string))
380             (prev #f))
381         (string-for-each (lambda (c)
382                            (if (or (not prev)
383                                    (char-whitespace? prev))
384                                (write-char c out))
385                            (set! prev c))
386                          "Common Lisp, the Language" 1)
387         (get-output-string out)))
388(test "string-for-each" "oL"
389       (let ((out (open-output-string))
390             (prev #f))
391         (string-for-each (lambda (c)
392                            (if (or (not prev)
393                                    (char-whitespace? prev))
394                                (write-char c out))
395                            (set! prev c))
396                          "Common Lisp, the Language" 1 10)
397         (get-output-string out)))
398(test "string-for-each-index" '(4 3 2 1 0)
399       (let ((r '()))
400         (string-for-each-index (lambda (i) (set! r (cons i r))) "hello")
401         r))
402(test "string-for-each-index" '(4 3 2 1)
403       (let ((r '()))
404         (string-for-each-index (lambda (i) (set! r (cons i r))) "hello" 1)
405         r))
406(test "string-for-each-index" '(2 1)
407       (let ((r '()))
408         (string-for-each-index (lambda (i) (set! r (cons i r))) "hello" 1 3)
409         r))
410
411(test "xsubstring" "cdefab"
412       (xsubstring "abcdef" 2))
413(test "xsubstring" "efabcd"
414       (xsubstring "abcdef" -2))
415(test "xsubstring" "abcabca"
416       (xsubstring "abc" 0 7))
417;; (test "xsubstring" "abcabca"
418;;        (xsubstring "abc"
419;;                    30000000000000000000000000000000
420;;                    30000000000000000000000000000007))
421(test "xsubstring" "defdefd"
422       (xsubstring "abcdefg" 0 7 3 6))
423(test "xsubstring" ""
424       (xsubstring "abcdefg" 9 9 3 6))
425
426(test "string-xcopy!" "ZZcdefabZZ"
427       (let ((s (make-string 10 #\Z)))
428         (string-xcopy! s 2 "abcdef" 2)
429         s))
430(test "string-xcopy!" "ZZdefdefZZ"
431       (let ((s (make-string 10 #\Z)))
432         (string-xcopy! s 2 "abcdef" 0 6 3)
433         s))
434
435(test "string-replace" "abcdXYZghi"
436       (string-replace "abcdefghi" "XYZ" 4 6))
437(test "string-replace" "abcdZghi"
438       (string-replace "abcdefghi" "XYZ" 4 6 2))
439(test "string-replace" "abcdZefghi"
440       (string-replace "abcdefghi" "XYZ" 4 4 2))
441(test "string-replace" "abcdefghi"
442       (string-replace "abcdefghi" "XYZ" 4 4 1 1))
443(test "string-replace" "abcdhi"
444       (string-replace "abcdefghi" "" 4 7))
445
446(test "string-tokenize" '("Help" "make" "programs" "run," "run," "RUN!")
447       (string-tokenize "Help make programs run, run, RUN!"))
448(test "string-tokenize" '("Help" "make" "programs" "run" "run" "RUN")
449       (string-tokenize "Help make programs run, run, RUN!"
450                        char-set:letter))
451(test "string-tokenize" '("programs" "run" "run" "RUN")
452       (string-tokenize "Help make programs run, run, RUN!"
453                        char-set:letter 10))
454(test "string-tokenize" '("elp" "make" "programs" "run" "run")
455       (string-tokenize "Help make programs run, run, RUN!"
456                        char-set:lower-case))
457
458(test "string-filter" "rrrr"
459       (string-filter #\r "Help make programs run, run, RUN!"))
460(test "string-filter" "HelpmakeprogramsrunrunRUN"
461       (string-filter char-set:letter "Help make programs run, run, RUN!"))
462
463(test "string-filter" "programsrunrun"
464       (string-filter (lambda (c) (char-lower-case? c))
465                      "Help make programs run, run, RUN!"
466                      10))
467(test "string-filter" ""
468       (string-filter (lambda (c) (char-lower-case? c)) ""))
469(test "string-delete" "Help make pogams un, un, RUN!"
470       (string-delete #\r "Help make programs run, run, RUN!"))
471(test "string-delete" "   , , !"
472       (string-delete char-set:letter "Help make programs run, run, RUN!"))
473(test "string-delete" " , , RUN!"
474       (string-delete (lambda (c) (char-lower-case? c))
475                      "Help make programs run, run, RUN!"
476                      10))
477(test "string-delete" ""
478       (string-delete (lambda (c) (char-lower-case? c)) ""))
479
480;;; Additional tests so that the suite at least touches all
481;;; the functions.
482
483(test "string-hash" #t (<= 0 (string-hash "abracadabra" 20) 19))
484
485(test "string-hash" #t (= (string-hash "abracadabra" 20) (string-hash "abracadabra" 20)))
486
487(test "string-hash" #t (= (string-hash "abracadabra" 20 2 7)
488                          (string-hash (substring "abracadabra" 2 7) 20)))
489
490(test "string-hash-ci" #t (= (string-hash-ci "aBrAcAdAbRa" 20)
491                             (string-hash-ci "AbRaCaDaBrA" 20)))
492
493(test "string-hash-ci" #t (= (string-hash-ci "aBrAcAdAbRa" 20 2 7)
494                             (string-hash-ci (substring "AbRaCaDaBrA" 2 7) 20)))
495
496(test "string=" #t (string= "foo" "foo"))
497(test "string=" #t (string= "foobar" "foo" 0 3))
498(test "string=" #t (string= "foobar" "barfoo" 0 3 3))
499(test "string=" #t (not (string= "foobar" "barfoo" 0 3 2 5)))
500
501(test "string<>" #t (string<> "flo" "foo"))
502(test "string<>" #t (string<> "flobar" "foo" 0 3))
503(test "string<>" #t (string<> "flobar" "barfoo" 0 3 3))
504(test "string<>" #t (not (string<> "foobar" "foobar" 0 3 0 3)))
505
506(test "string<=" #t (string<= "fol" "foo"))
507(test "string<=" #t (string<= "folbar" "foo" 0 3))
508(test "string<=" #t (string<= "foobar" "barfoo" 0 3 3))
509(test "string<=" #f (string<= "foobar" "barfoo" 0 3 1 4))
510
511(test "string<" #t (string< "fol" "foo"))
512(test "string<" #t (string< "folbar" "foo" 0 3))
513(test "string<" #t (string< "folbar" "barfoo" 0 3 3))
514(test "string<" #t (not (string< "foobar" "barfoo" 0 3 1 4)))
515
516(test "string>=" #t (string>= "foo" "fol"))
517(test "string>=" #t (string>= "foo" "folbar" 0 3 0 3))
518(test "string>=" #t (string>= "barfoo" "foo" 3 6 0))
519(test "string>=" #t (not (string>= "barfoo" "foobar" 1 4 0 3)))
520
521(test "string>" #t (string> "foo" "fol"))
522(test "string>" #t (string> "foo" "folbar" 0 3 0 3))
523(test "string>" #t (string> "barfoo" "fol" 3 6 0))
524(test "string>" #t (not (string> "barfoo" "foobar" 1 4 0 3)))
525
526(test "string-ci=" #t (string-ci= "Foo" "foO"))
527(test "string-ci=" #t (string-ci= "Foobar" "fOo" 0 3))
528(test "string-ci=" #t (string-ci= "Foobar" "bArfOo" 0 3 3))
529(test "string-ci=" #t (not (string-ci= "foobar" "BARFOO" 0 3 2 5)))
530
531(test "string-ci<>" #t (string-ci<> "flo" "FOO"))
532(test "string-ci<>" #t (string-ci<> "FLOBAR" "foo" 0 3))
533(test "string-ci<>" #t (string-ci<> "flobar" "BARFOO" 0 3 3))
534(test "string-ci<>" #t (not (string-ci<> "foobar" "FOOBAR" 0 3 0 3)))
535
536(test "string-ci<=" #t (string-ci<= "FOL" "foo"))
537(test "string-ci<=" #t (string-ci<= "folBAR" "fOO" 0 3))
538(test "string-ci<=" #t (string-ci<= "fOOBAR" "BARFOO" 0 3 3))
539(test "string-ci<=" #t (not (string-ci<= "foobar" "BARFOO" 0 3 1 4)))
540
541(test "string-ci<" #t (string-ci< "fol" "FOO"))
542(test "string-ci<" #t (string-ci< "folbar" "FOO" 0 3))
543(test "string-ci<" #t (string-ci< "folbar" "BARFOO" 0 3 3))
544(test "string-ci<" #t (not (string-ci< "foobar" "BARFOO" 0 3 1 4)))
545
546(test "string-ci>=" #t (string-ci>= "FOO" "fol"))
547(test "string-ci>=" #t (string-ci>= "foo" "FOLBAR" 0 3 0 3))
548(test "string-ci>=" #t (string-ci>= "BARFOO" "foo" 3 6 0))
549(test "string-ci>=" #t (not (string-ci>= "barfoo" "FOOBAR" 1 4 0 3)))
550
551(test "string-ci>" #t (string-ci> "FOO" "fol"))
552(test "string-ci>" #t (string-ci> "foo" "FOLBAR" 0 3 0 3))
553(test "string-ci>" #t (string-ci> "barfoo" "FOL" 3 6 0))
554(test "string-ci>" #t (not (string-ci> "barfoo" "FOOBAR" 1 4 0 3)))
555
556(test "string=?" #t (string=? "abcd" (string-append/shared "a" "b" "c" "d")))
557
558(test "string-parse-start+end"
559      #t
560      (let-values (((rest start end) (string-parse-start+end #t "foo" '(1 3 fnord))))
561        (and (= start 1)
562             (= end 3)
563             (equal? rest '(fnord)))))
564
565(test "string-parse-start+end"
566      #t
567      (call-with-current-continuation
568       (lambda (k)
569         (handle-exceptions exn
570           (k #t)
571           (string-parse-start+end #t "foo" '(1 4))
572           #f))))
573
574(test "string-parse-start+end"
575      #t
576      (let-values (((start end) (string-parse-final-start+end #t "foo" '(1 3))))
577        (and (= start 1)
578             (= end 3))))
579
580(test "string-parse-start+end"
581      #t
582      (let-string-start+end (start end rest) #t "foo" '(1 3 fnord)
583                            (and (= start 1)
584                                 (= end 3)
585                                 (equal? rest '(fnord)))))
586
587(test-assert "check-substring-spec" (check-substring-spec #t "foo" 1 3))
588
589(test-assert "check-substring-spec"
590             (call-with-current-continuation
591              (lambda (k)
592                (handle-exceptions exn
593                  (k #t)
594                  (check-substring-spec #t "foo" 1 4)
595                  #f))))
596
597(test-assert "substring-spec-ok?" (substring-spec-ok? "foo" 1 3))
598
599(test-assert "substring-spec-ok?" (not (substring-spec-ok? "foo" 1 4)))
600
601(test "make-kmp-restart-vector" '#() (make-kmp-restart-vector ""))
602
603(test "make-kmp-restart-vector" '#(-1) (make-kmp-restart-vector "a"))
604
605(test "make-kmp-restart-vector" '#(-1 0) (make-kmp-restart-vector "ab"))
606
607; The following is from an example in the code.  It is the "optimised"
608; version; it's also valid to return #(-1 0 0 0 1 2), but that will
609; needlessly check the "a" twice before giving up.
610(test "make-kmp-restart-vector"
611      '#(-1 0 0 -1 1 2)
612      (make-kmp-restart-vector "abdabx"))
613
614;; Each entry in kmp-cases is a pattern, a string to match against and
615;; the expected run of the algorithm through the positions in the
616;; pattern.  So for example 0 1 2 means it looks at position 0 first,
617;; then at 1 and then at 2.
618;;
619;; This is easy to verify in simple cases; If there's a shared
620;; substring and matching fails, you try matching again starting at
621;; the end of the shared substring, otherwise you rewind.  For more
622;; complex cases, it's increasingly difficult for humans to verify :)
623(define kmp-cases
624  '(("abc" "xx" #f 0 0)
625    ("abc" "abc" #t 0 1 2)
626    ("abcd" "abc" #f 0 1 2)
627    ("abc" "abcd" #t 0 1 2)
628    ("abc" "aabc" #t 0 1 1 2)
629    ("ab" "aa" #f 0 1)
630    ("ab" "aab" #t 0 1 1)
631    ("abdabx" "abdbbabda" #f 0 1 2 3 0 0 1 2 3)
632    ("aabc" "axaabc" #t 0 1 0 1 2 3)
633    ("aabac" "aabaabac" #t 0 1 2 3 4 2 3 4)))
634
635(for-each
636 (lambda (test-case)
637   (let* ((pat (car test-case))
638          (n (string-length pat))
639          (str (cadr test-case))
640          (match? (caddr test-case))
641          (steps (cdddr test-case))
642          (rv (make-kmp-restart-vector pat)))
643     (let ((p (open-input-string str)))
644       (let lp ((i 0)
645                (step 0)
646                (steps steps))
647         (cond
648           ((or (= i n) (eof-object? (peek-char p)))
649            (test-assert (sprintf "KMP match? ~S, case: ~S" match? test-case)
650                         (eq? (= i n) match?))
651            (test-assert (sprintf "KMP empty remaining steps: ~S, case: ~S"
652                           steps test-case)
653                         (null? steps)))
654           (else
655            (let ((new-i (kmp-step pat rv (read-char p) i char=? 0))
656                  (expected-i (and (not (null? steps)) (car steps))))
657              (test (sprintf "KMP step ~S (exp: ~S, act: ~S), case: ~S"
658                      step expected-i i test-case)
659                    expected-i i)
660              (lp new-i (add1 step) (cdr steps)))))))))
661 kmp-cases)
662
663; FIXME!  Implement tests for these:
664;   string-kmp-partial-search
665;   kmp-step
666
667
668;;; Regression tests: check that reported bugs have been fixed
669
670; From: Matthias Radestock <matthias@sorted.org>
671; Date: Wed, 10 Dec 2003 21:05:22 +0100
672;
673; Chris Double has found the following bug in the reference implementation:
674;
675;  (string-contains "xabc" "ab") => 1    ;good
676;  (string-contains "aabc" "ab") => #f   ;bad
677;
678; Matthias.
679
680(test "string-contains" 1 (string-contains "aabc" "ab"))
681
682(test "string-contains" 5 (string-contains "ababdabdabxxas" "abdabx"))
683
684(test "string-contains-ci" 1 (string-contains-ci "aabc" "ab"))
685
686; (message continues)
687;
688; PS: There is also an off-by-one error in the bounds check of the
689; unoptimized version of string-contains that is included as commented out
690; code in the reference implementation. This breaks things like
691; (string-contains "xab" "ab") and (string-contains "ab" "ab").
692
693; This off-by-one bug has been fixed in the comments of the version
694; of SRFI-13 shipped with Larceny.  In a version of the code without
695; the fix the following test will catch the bug:
696
697(test "string-contains" 0 (string-contains "ab" "ab"))
698
699; From: dvanhorn@emba.uvm.edu
700; Date: Wed, 26 Mar 2003 08:46:41 +0100
701;
702; The SRFI document gives,
703;
704;   string-filter s char/char-set/pred [start end] -> string
705;   string-delete s char/char-set/pred [start end] -> string
706;
707; Yet the reference implementation switches the order giving,
708;
709;   ;;; string-delete char/char-set/pred string [start end]
710;   ;;; string-filter char/char-set/pred string [start end]
711;   ...
712;   (define (string-delete criterion s . maybe-start+end)
713;   ...
714;   (define (string-filter criterion s . maybe-start+end)
715;
716; I reviewed the SRFI-13 mailing list and c.l.scheme, but found no mention of
717; this issue.  Apologies if I've missed something.
718
719(test-assert "string=? + string-filter"
720             (call-with-current-continuation
721              (lambda (k)
722                (handle-exceptions exn
723                  (k #f)
724                  (string=? "ADR" (string-filter char-set:upper-case "abrAcaDabRa"))))))
725
726(test-assert "string=? + string-delete"
727             (call-with-current-continuation
728              (lambda (k)
729                (handle-exceptions exn
730                  (k #f)
731                  (string=? "abrcaaba" (string-delete char-set:upper-case "abrAcaDabRa"))))))
732
733
734; http://srfi.schemers.org/srfi-13/post-mail-archive/msg00007.html
735; From: David Van Horn <address@hidden>
736; Date: Wed, 01 Nov 2006 07:53:34 +0100
737;
738; Both string-index-right and string-skip-right will continue to search
739; left past a given start index.
740;
741;    (string-index-right "abbb" #\a 1) ;; => 0, but should be #f
742;    (string-skip-right  "abbb" #\b 1) ;; => 0, but should be #f
743;
744; This also causes incorrect results for string-trim-right,
745; string-trim-both and string-tokenize when given a non-zero start
746; argument.
747
748(test "string-index-right" #f (string-index-right "abbb" #\a 1))
749(test "string-skip-right" #f (string-skip-right  "abbb" #\b 1))
750
751;; Tests to check the string-trim-right issue found by Seth Alves
752;; http://lists.gnu.org/archive/html/chicken-hackers/2014-01/msg00016.html
753(test "string-trim-right" "" (string-trim-right "" char-whitespace? 0 0))
754(test "string-trim-right" "" (string-trim-right "a" char-whitespace? 0 0))
755(test "string-trim-right" "" (string-trim-right "a " char-whitespace? 0 0))
756(test "string-trim-right" "bc" (string-trim-right "abc   " char-whitespace? 1))
757(test "string-trim-right" "" (string-trim-right "abc   " char-whitespace? 4 4))
758
759(test-end "SRFI-13")
760
761(test-exit)
Note: See TracBrowser for help on using the repository browser.