>From 9b090d353e4c3f3c0c60eac39ba1612fde3bce22 Mon Sep 17 00:00:00 2001 From: Mario Domenech Goulart Date: Fri, 29 Jun 2012 20:24:19 -0300 Subject: [PATCH] Add tests for SRFI-13 (adapted from Gauche) --- tests/runtests.bat | 4 + tests/runtests.sh | 3 + tests/srfi-13-tests.scm | 690 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 697 insertions(+), 0 deletions(-) create mode 100644 tests/srfi-13-tests.scm diff --git a/tests/runtests.bat b/tests/runtests.bat index ecd8d05..93efb4d 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 63790ef..a87d750 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 0000000..29d6b80 --- /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 +; 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: address@hidden +; 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")))))) -- 1.7.0.4