~ chicken-core (chicken-5) 56d2581de632754f20ea964a4a735174dee22994
commit 56d2581de632754f20ea964a4a735174dee22994
Author: Mario Domenech Goulart <mario.goulart@gmail.com>
AuthorDate: Fri Jun 29 20:24:19 2012 -0300
Commit: Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sat Jun 30 11:32:59 2012 +0200
Add tests for SRFI-13 (adapted from Gauche)
Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
diff --git a/tests/runtests.bat b/tests/runtests.bat
index ecd8d059..93efb4d3 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -335,6 +335,10 @@ echo ======================================== srfi-4 tests ...
%interpret% -s srfi-4-tests.scm
if errorlevel 1 exit /b 1
+echo ======================================== srfi-13 tests ...
+%interpret% -s srfi-13-tests.scm
+if errorlevel 1 exit /b 1
+
echo ======================================== condition tests ...
%interpret% -s condition-tests.scm
if errorlevel 1 exit /b 1
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 63790ef5..a87d750b 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -293,6 +293,9 @@ $compile numbers-string-conversion-tests.scm
echo "======================================== srfi-4 tests ..."
$interpret -s srfi-4-tests.scm
+echo "======================================== srfi-13 tests ..."
+$interpret -s srfi-13-tests.scm
+
echo "======================================== condition tests ..."
$interpret -s condition-tests.scm
diff --git a/tests/srfi-13-tests.scm b/tests/srfi-13-tests.scm
new file mode 100644
index 00000000..29d6b80b
--- /dev/null
+++ b/tests/srfi-13-tests.scm
@@ -0,0 +1,690 @@
+(define (fill text)
+ (let* ((len (string-length text))
+ (max-text-len 60)
+ (last-col 70)
+ (text (if (> len max-text-len)
+ (begin
+ (set! len max-text-len)
+ (substring text 0 max-text-len))
+ text)))
+ (string-append text (make-string (- last-col len) #\.))))
+
+(define-syntax test
+ (syntax-rules ()
+ ((_ comment expect form)
+ (begin
+ (display (fill (or comment "")))
+ (cond ((equal? expect form)
+ (display "[ok]"))
+ (else
+ (display "[fail]")
+ (newline)
+ (exit 13)))
+ (newline)
+ (flush-output)))))
+
+(define-syntax test-assert
+ (syntax-rules ()
+ ((_ comment form)
+ (test comment #t (and form #t)))))
+
+(use srfi-13)
+
+; Tests for SRFI-13 as implemented by the Gauche scheme system.
+;;
+;; Copyright (c) 2000-2003 Shiro Kawai, All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; 3. Neither the name of the authors nor the names of its contributors
+;; may be used to endorse or promote products derived from this
+;; software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
+;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;
+;; See http://sourceforge.net/projects/gauche/
+
+(test "string-null?" #f (string-null? "abc"))
+(test "string-null?" #t (string-null? ""))
+(test "string-every" #t (string-every #\a ""))
+(test "string-every" #t (string-every #\a "aaaa"))
+(test "string-every" #f (string-every #\a "aaba"))
+(test "string-every" #t (string-every char-set:lower-case "aaba"))
+(test "string-every" #f (string-every char-set:lower-case "aAba"))
+(test "string-every" #t (string-every char-set:lower-case ""))
+(test "string-every" #t (string-every (lambda (x) (char-ci=? x #\a)) "aAaA"))
+(test "string-every" #f (string-every (lambda (x) (char-ci=? x #\a)) "aAbA"))
+(test "string-every" (char->integer #\A)
+ (string-every (lambda (x) (char->integer x)) "aAbA"))
+(test "string-every" #t
+ (string-every (lambda (x) (error "hoge")) ""))
+(test "string-any" #t (string-any #\a "aaaa"))
+(test "string-any" #f (string-any #\a "Abcd"))
+(test "string-any" #f (string-any #\a ""))
+(test "string-any" #t (string-any char-set:lower-case "ABcD"))
+(test "string-any" #f (string-any char-set:lower-case "ABCD"))
+(test "string-any" #f (string-any char-set:lower-case ""))
+(test "string-any" #t (string-any (lambda (x) (char-ci=? x #\a)) "CAaA"))
+(test "string-any" #f (string-any (lambda (x) (char-ci=? x #\a)) "ZBRC"))
+(test "string-any" #f (string-any (lambda (x) (char-ci=? x #\a)) ""))
+(test "string-any" (char->integer #\a)
+ (string-any (lambda (x) (char->integer x)) "aAbA"))
+(test "string-tabulate" "0123456789"
+ (string-tabulate (lambda (code)
+ (integer->char (+ code (char->integer #\0))))
+ 10))
+(test "string-tabulate" ""
+ (string-tabulate (lambda (code)
+ (integer->char (+ code (char->integer #\0))))
+ 0))
+(test "reverse-list->string" "cBa"
+ (reverse-list->string '(#\a #\B #\c)))
+(test "reverse-list->string" ""
+ (reverse-list->string '()))
+; string-join : Gauche builtin.
+(test "substring/shared" "cde" (substring/shared "abcde" 2))
+(test "substring/shared" "cd" (substring/shared "abcde" 2 4))
+(test "string-copy!" "abCDEfg"
+ (let ((x (string-copy "abcdefg")))
+ (string-copy! x 2 "CDE")
+ x))
+(test "string-copy!" "abCDEfg"
+ (let ((x (string-copy "abcdefg")))
+ (string-copy! x 2 "ZABCDE" 3)
+ x))
+(test "string-copy!" "abCDEfg"
+ (let ((x (string-copy "abcdefg")))
+ (string-copy! x 2 "ZABCDEFG" 3 6)
+ x))
+(test "string-take" "Pete S" (string-take "Pete Szilagyi" 6))
+(test "string-take" "" (string-take "Pete Szilagyi" 0))
+(test "string-take" "Pete Szilagyi" (string-take "Pete Szilagyi" 13))
+(test "string-drop" "zilagyi" (string-drop "Pete Szilagyi" 6))
+(test "string-drop" "Pete Szilagyi" (string-drop "Pete Szilagyi" 0))
+(test "string-drop" "" (string-drop "Pete Szilagyi" 13))
+
+(test "string-take-right" "rules" (string-take-right "Beta rules" 5))
+(test "string-take-right" "" (string-take-right "Beta rules" 0))
+(test "string-take-right" "Beta rules" (string-take-right "Beta rules" 10))
+(test "string-drop-right" "Beta " (string-drop-right "Beta rules" 5))
+(test "string-drop-right" "Beta rules" (string-drop-right "Beta rules" 0))
+(test "string-drop-right" "" (string-drop-right "Beta rules" 10))
+
+(test "string-pad" " 325" (string-pad "325" 5))
+(test "string-pad" "71325" (string-pad "71325" 5))
+(test "string-pad" "71325" (string-pad "8871325" 5))
+(test "string-pad" "~~325" (string-pad "325" 5 #\~))
+(test "string-pad" "~~~25" (string-pad "325" 5 #\~ 1))
+(test "string-pad" "~~~~2" (string-pad "325" 5 #\~ 1 2))
+(test "string-pad-right" "325 " (string-pad-right "325" 5))
+(test "string-pad-right" "71325" (string-pad-right "71325" 5))
+(test "string-pad-right" "88713" (string-pad-right "8871325" 5))
+(test "string-pad-right" "325~~" (string-pad-right "325" 5 #\~))
+(test "string-pad-right" "25~~~" (string-pad-right "325" 5 #\~ 1))
+(test "string-pad-right" "2~~~~" (string-pad-right "325" 5 #\~ 1 2))
+
+(test "string-trim" "a b c d \n"
+ (string-trim " \t a b c d \n"))
+(test "string-trim" "\t a b c d \n"
+ (string-trim " \t a b c d \n" #\space))
+(test "string-trim" "a b c d \n"
+ (string-trim "4358948a b c d \n" char-set:digit))
+
+(test "string-trim-right" " \t a b c d"
+ (string-trim-right " \t a b c d \n"))
+(test "string-trim-right" " \t a b c d "
+ (string-trim-right " \t a b c d \n" (char-set #\newline)))
+(test "string-trim-right" "349853a b c d"
+ (string-trim-right "349853a b c d03490" char-set:digit))
+
+(test "string-trim-both" "a b c d"
+ (string-trim-both " \t a b c d \n"))
+(test "string-trim-both" " \t a b c d "
+ (string-trim-both " \t a b c d \n" (char-set #\newline)))
+(test "string-trim-both" "a b c d"
+ (string-trim-both "349853a b c d03490" char-set:digit))
+
+;; string-fill - in string.scm
+
+(test "string-compare" 5
+ (string-compare "The cat in the hat" "abcdefgh"
+ values values values
+ 4 6 2 4))
+(test "string-compare-ci" 5
+ (string-compare-ci "The cat in the hat" "ABCDEFGH"
+ values values values
+ 4 6 2 4))
+
+;; TODO: bunch of string= families
+
+(test "string-prefix-length" 5
+ (string-prefix-length "cancaNCAM" "cancancan"))
+(test "string-prefix-length-ci" 8
+ (string-prefix-length-ci "cancaNCAM" "cancancan"))
+(test "string-suffix-length" 2
+ (string-suffix-length "CanCan" "cankancan"))
+(test "string-suffix-length-ci" 5
+ (string-suffix-length-ci "CanCan" "cankancan"))
+
+(test "string-prefix?" #t (string-prefix? "abcd" "abcdefg"))
+(test "string-prefix?" #f (string-prefix? "abcf" "abcdefg"))
+(test "string-prefix-ci?" #t (string-prefix-ci? "abcd" "aBCDEfg"))
+(test "string-prefix-ci?" #f (string-prefix-ci? "abcf" "aBCDEfg"))
+(test "string-suffix?" #t (string-suffix? "defg" "abcdefg"))
+(test "string-suffix?" #f (string-suffix? "aefg" "abcdefg"))
+(test "string-suffix-ci?" #t (string-suffix-ci? "defg" "aBCDEfg"))
+(test "string-suffix-ci?" #f (string-suffix-ci? "aefg" "aBCDEfg"))
+
+(test "string-index #1" 4
+ (string-index "abcd:efgh:ijkl" #\:))
+(test "string-index #2" 4
+ (string-index "abcd:efgh;ijkl" (char-set-complement char-set:letter)))
+(test "string-index #3" #f
+ (string-index "abcd:efgh;ijkl" char-set:digit))
+(test "string-index #4" 9
+ (string-index "abcd:efgh:ijkl" #\: 5))
+(test "string-index-right #1" 4
+ (string-index-right "abcd:efgh;ijkl" #\:))
+(test "string-index-right #2" 9
+ (string-index-right "abcd:efgh;ijkl" (char-set-complement char-set:letter)))
+(test "string-index-right #3" #f
+ (string-index-right "abcd:efgh;ijkl" char-set:digit))
+(test "string-index-right #4" 4
+ (string-index-right "abcd:efgh;ijkl" (char-set-complement char-set:letter) 2 5))
+
+(test "string-count #1" 2
+ (string-count "abc def\tghi jkl" #\space))
+(test "string-count #2" 3
+ (string-count "abc def\tghi jkl" char-set:whitespace))
+(test "string-count #3" 2
+ (string-count "abc def\tghi jkl" char-set:whitespace 4))
+(test "string-count #4" 1
+ (string-count "abc def\tghi jkl" char-set:whitespace 4 9))
+(test "string-contains" 3
+ (string-contains "Ma mere l'oye" "mer"))
+(test "string-contains" #f
+ (string-contains "Ma mere l'oye" "Mer"))
+(test "string-contains-ci" 3
+ (string-contains-ci "Ma mere l'oye" "Mer"))
+(test "string-contains-ci" #f
+ (string-contains-ci "Ma mere l'oye" "Meer"))
+
+(test "string-titlecase" "--Capitalize This Sentence."
+ (string-titlecase "--capitalize tHIS sentence."))
+(test "string-titlecase" "3Com Makes Routers."
+ (string-titlecase "3com makes routers."))
+(test "string-titlecase!" "alSo Whatever"
+ (let ((s (string-copy "also whatever")))
+ (string-titlecase! s 2 9)
+ s))
+
+(test "string-upcase" "SPEAK LOUDLY"
+ (string-upcase "speak loudly"))
+(test "string-upcase" "PEAK"
+ (string-upcase "speak loudly" 1 5))
+(test "string-upcase!" "sPEAK loudly"
+ (let ((s (string-copy "speak loudly")))
+ (string-upcase! s 1 5)
+ s))
+
+(test "string-downcase" "speak softly"
+ (string-downcase "SPEAK SOFTLY"))
+(test "string-downcase" "peak"
+ (string-downcase "SPEAK SOFTLY" 1 5))
+(test "string-downcase!" "Speak SOFTLY"
+ (let ((s (string-copy "SPEAK SOFTLY")))
+ (string-downcase! s 1 5)
+ s))
+
+(test "string-reverse" "nomel on nolem on"
+ (string-reverse "no melon no lemon"))
+(test "string-reverse" "nomel on"
+ (string-reverse "no melon no lemon" 9))
+(test "string-reverse" "on"
+ (string-reverse "no melon no lemon" 9 11))
+(test "string-reverse!" "nomel on nolem on"
+ (let ((s (string-copy "no melon no lemon")))
+ (string-reverse! s) s))
+(test "string-reverse!" "no melon nomel on"
+ (let ((s (string-copy "no melon no lemon")))
+ (string-reverse! s 9) s))
+(test "string-reverse!" "no melon on lemon"
+ (let ((s (string-copy "no melon no lemon")))
+ (string-reverse! s 9 11) s))
+
+(test "string-append" #f
+ (let ((s "test")) (eq? s (string-append s))))
+(test "string-concatenate" #f
+ (let ((s "test")) (eq? s (string-concatenate (list s)))))
+(test "string-concatenate" "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
+ (string-concatenate
+ '("A" "B" "C" "D" "E" "F" "G" "H"
+ "I" "J" "K" "L" "M" "N" "O" "P"
+ "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
+ "a" "b" "c" "d" "e" "f" "g" "h"
+ "i" "j" "k" "l" "m" "n" "o" "p"
+ "q" "r" "s" "t" "u" "v" "w" "x" "y" "z")))
+(test "string-concatenate/shared" "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
+ (string-concatenate/shared
+ '("A" "B" "C" "D" "E" "F" "G" "H"
+ "I" "J" "K" "L" "M" "N" "O" "P"
+ "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
+ "a" "b" "c" "d" "e" "f" "g" "h"
+ "i" "j" "k" "l" "m" "n" "o" "p"
+ "q" "r" "s" "t" "u" "v" "w" "x" "y" "z")))
+(test "string-concatenate-reverse" "zyxwvutsrqponmlkjihgfedcbaZYXWVUTSRQPONMLKJIHGFEDCBA"
+ (string-concatenate-reverse
+ '("A" "B" "C" "D" "E" "F" "G" "H"
+ "I" "J" "K" "L" "M" "N" "O" "P"
+ "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
+ "a" "b" "c" "d" "e" "f" "g" "h"
+ "i" "j" "k" "l" "m" "n" "o" "p"
+ "q" "r" "s" "t" "u" "v" "w" "x" "y" "z")))
+(test "string-concatenate-reverse" #f
+ (let ((s "test"))
+ (eq? s (string-concatenate-reverse (list s)))))
+(test "string-concatenate-reverse/shared" "zyxwvutsrqponmlkjihgfedcbaZYXWVUTSRQPONMLKJIHGFEDCBA"
+ (string-concatenate-reverse/shared
+ '("A" "B" "C" "D" "E" "F" "G" "H"
+ "I" "J" "K" "L" "M" "N" "O" "P"
+ "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
+ "a" "b" "c" "d" "e" "f" "g" "h"
+ "i" "j" "k" "l" "m" "n" "o" "p"
+ "q" "r" "s" "t" "u" "v" "w" "x" "y" "z")))
+
+(test "string-map" "svool"
+ (string-map (lambda (c)
+ (integer->char (- 219 (char->integer c))))
+ "hello"))
+(test "string-map" "vool"
+ (string-map (lambda (c)
+ (integer->char (- 219 (char->integer c))))
+ "hello" 1))
+(test "string-map" "vo"
+ (string-map (lambda (c)
+ (integer->char (- 219 (char->integer c))))
+ "hello" 1 3))
+(test "string-map!" "svool"
+ (let ((s (string-copy "hello")))
+ (string-map! (lambda (c)
+ (integer->char (- 219 (char->integer c))))
+ s)
+ s))
+(test "string-map!" "hvool"
+ (let ((s (string-copy "hello")))
+ (string-map! (lambda (c)
+ (integer->char (- 219 (char->integer c))))
+ s 1)
+ s))
+(test "string-map!" "hvolo"
+ (let ((s (string-copy "hello")))
+ (string-map! (lambda (c)
+ (integer->char (- 219 (char->integer c))))
+ s 1 3)
+ s))
+
+(test "string-fold" '(#\o #\l #\l #\e #\h . #t)
+ (string-fold cons #t "hello"))
+(test "string-fold" '(#\l #\e . #t)
+ (string-fold cons #t "hello" 1 3))
+(test "string-fold-right" '(#\h #\e #\l #\l #\o . #t)
+ (string-fold-right cons #t "hello"))
+(test "string-fold-right" '(#\e #\l . #t)
+ (string-fold-right cons #t "hello" 1 3))
+
+(test "string-unfold" "hello"
+ (string-unfold null? car cdr '(#\h #\e #\l #\l #\o)))
+(test "string-unfold" "hi hello"
+ (string-unfold null? car cdr '(#\h #\e #\l #\l #\o) "hi "))
+(test "string-unfold" "hi hello ho"
+ (string-unfold null? car cdr
+ '(#\h #\e #\l #\l #\o) "hi "
+ (lambda (x) " ho")))
+
+(test "string-unfold-right" "olleh"
+ (string-unfold-right null? car cdr '(#\h #\e #\l #\l #\o)))
+(test "string-unfold-right" "olleh hi"
+ (string-unfold-right null? car cdr '(#\h #\e #\l #\l #\o) " hi"))
+(test "string-unfold-right" "ho olleh hi"
+ (string-unfold-right null? car cdr
+ '(#\h #\e #\l #\l #\o) " hi"
+ (lambda (x) "ho ")))
+
+(test "string-for-each" "CLtL"
+ (let ((out (open-output-string))
+ (prev #f))
+ (string-for-each (lambda (c)
+ (if (or (not prev)
+ (char-whitespace? prev))
+ (write-char c out))
+ (set! prev c))
+ "Common Lisp, the Language")
+
+ (get-output-string out)))
+(test "string-for-each" "oLtL"
+ (let ((out (open-output-string))
+ (prev #f))
+ (string-for-each (lambda (c)
+ (if (or (not prev)
+ (char-whitespace? prev))
+ (write-char c out))
+ (set! prev c))
+ "Common Lisp, the Language" 1)
+ (get-output-string out)))
+(test "string-for-each" "oL"
+ (let ((out (open-output-string))
+ (prev #f))
+ (string-for-each (lambda (c)
+ (if (or (not prev)
+ (char-whitespace? prev))
+ (write-char c out))
+ (set! prev c))
+ "Common Lisp, the Language" 1 10)
+ (get-output-string out)))
+(test "string-for-each-index" '(4 3 2 1 0)
+ (let ((r '()))
+ (string-for-each-index (lambda (i) (set! r (cons i r))) "hello")
+ r))
+(test "string-for-each-index" '(4 3 2 1)
+ (let ((r '()))
+ (string-for-each-index (lambda (i) (set! r (cons i r))) "hello" 1)
+ r))
+(test "string-for-each-index" '(2 1)
+ (let ((r '()))
+ (string-for-each-index (lambda (i) (set! r (cons i r))) "hello" 1 3)
+ r))
+
+(test "xsubstring" "cdefab"
+ (xsubstring "abcdef" 2))
+(test "xsubstring" "efabcd"
+ (xsubstring "abcdef" -2))
+(test "xsubstring" "abcabca"
+ (xsubstring "abc" 0 7))
+;; (test "xsubstring" "abcabca"
+;; (xsubstring "abc"
+;; 30000000000000000000000000000000
+;; 30000000000000000000000000000007))
+(test "xsubstring" "defdefd"
+ (xsubstring "abcdefg" 0 7 3 6))
+(test "xsubstring" ""
+ (xsubstring "abcdefg" 9 9 3 6))
+
+(test "string-xcopy!" "ZZcdefabZZ"
+ (let ((s (make-string 10 #\Z)))
+ (string-xcopy! s 2 "abcdef" 2)
+ s))
+(test "string-xcopy!" "ZZdefdefZZ"
+ (let ((s (make-string 10 #\Z)))
+ (string-xcopy! s 2 "abcdef" 0 6 3)
+ s))
+
+(test "string-replace" "abcdXYZghi"
+ (string-replace "abcdefghi" "XYZ" 4 6))
+(test "string-replace" "abcdZghi"
+ (string-replace "abcdefghi" "XYZ" 4 6 2))
+(test "string-replace" "abcdZefghi"
+ (string-replace "abcdefghi" "XYZ" 4 4 2))
+(test "string-replace" "abcdefghi"
+ (string-replace "abcdefghi" "XYZ" 4 4 1 1))
+(test "string-replace" "abcdhi"
+ (string-replace "abcdefghi" "" 4 7))
+
+(test "string-tokenize" '("Help" "make" "programs" "run," "run," "RUN!")
+ (string-tokenize "Help make programs run, run, RUN!"))
+(test "string-tokenize" '("Help" "make" "programs" "run" "run" "RUN")
+ (string-tokenize "Help make programs run, run, RUN!"
+ char-set:letter))
+(test "string-tokenize" '("programs" "run" "run" "RUN")
+ (string-tokenize "Help make programs run, run, RUN!"
+ char-set:letter 10))
+(test "string-tokenize" '("elp" "make" "programs" "run" "run")
+ (string-tokenize "Help make programs run, run, RUN!"
+ char-set:lower-case))
+
+(test "string-filter" "rrrr"
+ (string-filter #\r "Help make programs run, run, RUN!"))
+(test "string-filter" "HelpmakeprogramsrunrunRUN"
+ (string-filter char-set:letter "Help make programs run, run, RUN!"))
+
+(test "string-filter" "programsrunrun"
+ (string-filter (lambda (c) (char-lower-case? c))
+ "Help make programs run, run, RUN!"
+ 10))
+(test "string-filter" ""
+ (string-filter (lambda (c) (char-lower-case? c)) ""))
+(test "string-delete" "Help make pogams un, un, RUN!"
+ (string-delete #\r "Help make programs run, run, RUN!"))
+(test "string-delete" " , , !"
+ (string-delete char-set:letter "Help make programs run, run, RUN!"))
+(test "string-delete" " , , RUN!"
+ (string-delete (lambda (c) (char-lower-case? c))
+ "Help make programs run, run, RUN!"
+ 10))
+(test "string-delete" ""
+ (string-delete (lambda (c) (char-lower-case? c)) ""))
+
+ ;;; Additional tests so that the suite at least touches all
+;;; the functions.
+
+(test "string-hash" #t (<= 0 (string-hash "abracadabra" 20) 19))
+
+(test "string-hash" #t (= (string-hash "abracadabra" 20) (string-hash "abracadabra" 20)))
+
+(test "string-hash" #t (= (string-hash "abracadabra" 20 2 7)
+ (string-hash (substring "abracadabra" 2 7) 20)))
+
+(test "string-hash-ci" #t (= (string-hash-ci "aBrAcAdAbRa" 20)
+ (string-hash-ci "AbRaCaDaBrA" 20)))
+
+(test "string-hash-ci" #t (= (string-hash-ci "aBrAcAdAbRa" 20 2 7)
+ (string-hash-ci (substring "AbRaCaDaBrA" 2 7) 20)))
+
+(test "string=" #t (string= "foo" "foo"))
+(test "string=" #t (string= "foobar" "foo" 0 3))
+(test "string=" #t (string= "foobar" "barfoo" 0 3 3))
+(test "string=" #t (not (string= "foobar" "barfoo" 0 3 2 5)))
+
+(test "string<>" #t (string<> "flo" "foo"))
+(test "string<>" #t (string<> "flobar" "foo" 0 3))
+(test "string<>" #t (string<> "flobar" "barfoo" 0 3 3))
+(test "string<>" #t (not (string<> "foobar" "foobar" 0 3 0 3)))
+
+(test "string<=" #t (string<= "fol" "foo"))
+(test "string<=" #t (string<= "folbar" "foo" 0 3))
+(test "string<=" #t (string<= "foobar" "barfoo" 0 3 3))
+(test "string<=" #f (string<= "foobar" "barfoo" 0 3 1 4))
+
+(test "string<" #t (string< "fol" "foo"))
+(test "string<" #t (string< "folbar" "foo" 0 3))
+(test "string<" #t (string< "folbar" "barfoo" 0 3 3))
+(test "string<" #t (not (string< "foobar" "barfoo" 0 3 1 4)))
+
+(test "string>=" #t (string>= "foo" "fol"))
+(test "string>=" #t (string>= "foo" "folbar" 0 3 0 3))
+(test "string>=" #t (string>= "barfoo" "foo" 3 6 0))
+(test "string>=" #t (not (string>= "barfoo" "foobar" 1 4 0 3)))
+
+(test "string>" #t (string> "foo" "fol"))
+(test "string>" #t (string> "foo" "folbar" 0 3 0 3))
+(test "string>" #t (string> "barfoo" "fol" 3 6 0))
+(test "string>" #t (not (string> "barfoo" "foobar" 1 4 0 3)))
+
+(test "string-ci=" #t (string-ci= "Foo" "foO"))
+(test "string-ci=" #t (string-ci= "Foobar" "fOo" 0 3))
+(test "string-ci=" #t (string-ci= "Foobar" "bArfOo" 0 3 3))
+(test "string-ci=" #t (not (string-ci= "foobar" "BARFOO" 0 3 2 5)))
+
+(test "string-ci<>" #t (string-ci<> "flo" "FOO"))
+(test "string-ci<>" #t (string-ci<> "FLOBAR" "foo" 0 3))
+(test "string-ci<>" #t (string-ci<> "flobar" "BARFOO" 0 3 3))
+(test "string-ci<>" #t (not (string-ci<> "foobar" "FOOBAR" 0 3 0 3)))
+
+(test "string-ci<=" #t (string-ci<= "FOL" "foo"))
+(test "string-ci<=" #t (string-ci<= "folBAR" "fOO" 0 3))
+(test "string-ci<=" #t (string-ci<= "fOOBAR" "BARFOO" 0 3 3))
+(test "string-ci<=" #t (not (string-ci<= "foobar" "BARFOO" 0 3 1 4)))
+
+(test "string-ci<" #t (string-ci< "fol" "FOO"))
+(test "string-ci<" #t (string-ci< "folbar" "FOO" 0 3))
+(test "string-ci<" #t (string-ci< "folbar" "BARFOO" 0 3 3))
+(test "string-ci<" #t (not (string-ci< "foobar" "BARFOO" 0 3 1 4)))
+
+(test "string-ci>=" #t (string-ci>= "FOO" "fol"))
+(test "string-ci>=" #t (string-ci>= "foo" "FOLBAR" 0 3 0 3))
+(test "string-ci>=" #t (string-ci>= "BARFOO" "foo" 3 6 0))
+(test "string-ci>=" #t (not (string-ci>= "barfoo" "FOOBAR" 1 4 0 3)))
+
+(test "string-ci>" #t (string-ci> "FOO" "fol"))
+(test "string-ci>" #t (string-ci> "foo" "FOLBAR" 0 3 0 3))
+(test "string-ci>" #t (string-ci> "barfoo" "FOL" 3 6 0))
+(test "string-ci>" #t (not (string-ci> "barfoo" "FOOBAR" 1 4 0 3)))
+
+(test "string=?" #t (string=? "abcd" (string-append/shared "a" "b" "c" "d")))
+
+(test "string-parse-start+end"
+ #t
+ (let-values (((rest start end) (string-parse-start+end #t "foo" '(1 3 fnord))))
+ (and (= start 1)
+ (= end 3)
+ (equal? rest '(fnord)))))
+
+(test "string-parse-start+end"
+ #t
+ (call-with-current-continuation
+ (lambda (k)
+ (handle-exceptions exn
+ (k #t)
+ (string-parse-start+end #t "foo" '(1 4))
+ #f))))
+
+(test "string-parse-start+end"
+ #t
+ (let-values (((start end) (string-parse-final-start+end #t "foo" '(1 3))))
+ (and (= start 1)
+ (= end 3))))
+
+(test "string-parse-start+end"
+ #t
+ (let-string-start+end (start end rest) #t "foo" '(1 3 fnord)
+ (and (= start 1)
+ (= end 3)
+ (equal? rest '(fnord)))))
+
+(test-assert "check-substring-spec" (check-substring-spec #t "foo" 1 3))
+
+(test-assert "check-substring-spec"
+ (call-with-current-continuation
+ (lambda (k)
+ (handle-exceptions exn
+ (k #t)
+ (check-substring-spec #t "foo" 1 4)
+ #f))))
+
+(test-assert "substring-spec-ok?" (substring-spec-ok? "foo" 1 3))
+
+(test-assert "substring-spec-ok?" (not (substring-spec-ok? "foo" 1 4)))
+
+(test "make-kmp-restart-vector" '#() (make-kmp-restart-vector ""))
+
+(test "make-kmp-restart-vector" '#(-1) (make-kmp-restart-vector "a"))
+
+;;; The following two tests for make-kmp-restart-vector are
+;;; intentionally commented (see http://bugs.call-cc.org/ticket/878)
+;;; -- mario
+
+; This seems right to me, but is it?
+; (test "make-kmp-restart-vector" '#(-1 0) (make-kmp-restart-vector "ab"))
+
+; The following is from an example in the code, but I expect it is not right.
+; (test "make-kmp-restart-vector" '#(-1 0 0 -1 1 2) (make-kmp-restart-vector "abdabx"))
+
+
+
+; FIXME! Implement tests for these:
+; string-kmp-partial-search
+; kmp-step
+
+
+ ;;; Regression tests: check that reported bugs have been fixed
+
+; From: Matthias Radestock <matthias@sorted.org>
+; Date: Wed, 10 Dec 2003 21:05:22 +0100
+;
+; Chris Double has found the following bug in the reference implementation:
+;
+; (string-contains "xabc" "ab") => 1 ;good
+; (string-contains "aabc" "ab") => #f ;bad
+;
+; Matthias.
+
+(test "string-contains" 1 (string-contains "aabc" "ab"))
+
+(test "string-contains" 5 (string-contains "ababdabdabxxas" "abdabx"))
+
+(test "string-contains-ci" 1 (string-contains-ci "aabc" "ab"))
+
+; (message continues)
+;
+; PS: There is also an off-by-one error in the bounds check of the
+; unoptimized version of string-contains that is included as commented out
+; code in the reference implementation. This breaks things like
+; (string-contains "xab" "ab") and (string-contains "ab" "ab").
+
+; This off-by-one bug has been fixed in the comments of the version
+; of SRFI-13 shipped with Larceny. In a version of the code without
+; the fix the following test will catch the bug:
+
+(test "string-contains" 0 (string-contains "ab" "ab"))
+
+; From: dvanhorn@emba.uvm.edu
+; Date: Wed, 26 Mar 2003 08:46:41 +0100
+;
+; The SRFI document gives,
+;
+; string-filter s char/char-set/pred [start end] -> string
+; string-delete s char/char-set/pred [start end] -> string
+;
+; Yet the reference implementation switches the order giving,
+;
+; ;;; string-delete char/char-set/pred string [start end]
+; ;;; string-filter char/char-set/pred string [start end]
+; ...
+; (define (string-delete criterion s . maybe-start+end)
+; ...
+; (define (string-filter criterion s . maybe-start+end)
+;
+; I reviewed the SRFI-13 mailing list and c.l.scheme, but found no mention of
+; this issue. Apologies if I've missed something.
+
+(test-assert "string=? + string-filter"
+ (call-with-current-continuation
+ (lambda (k)
+ (handle-exceptions exn
+ (k #f)
+ (string=? "ADR" (string-filter char-set:upper-case "abrAcaDabRa"))))))
+
+(test-assert "string=? + string-delete"
+ (call-with-current-continuation
+ (lambda (k)
+ (handle-exceptions exn
+ (k #f)
+ (string=? "abrcaaba" (string-delete char-set:upper-case "abrAcaDabRa"))))))
Trap