>From 4e0514f21ea218e02db047ce4bad8586232fe6ad Mon Sep 17 00:00:00 2001
From: Mario Domenech Goulart <address@hidden>
Date: Sat, 7 Jul 2012 15:39:29 -0300
Subject: [PATCH] Add tests for SRFI-14

Tests by Olin Shivers for the SRFI-14 reference implementation
(http://srfi.schemers.org/srfi-14/srfi-14-tests.scm).

Those tests triggered a compiler bug
(http://bugs.call-cc.org/ticket/874) which has been fixed by
285f53dbca729cffb4c4d9ee84e4ba893c882546
---
 distribution/manifest   |    1 +
 tests/runtests.bat      |    6 ++
 tests/runtests.sh       |    4 +
 tests/srfi-14-tests.scm |  202 +++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 213 insertions(+), 0 deletions(-)
 create mode 100644 tests/srfi-14-tests.scm

diff --git a/distribution/manifest b/distribution/manifest
index efd111e..905aa2e 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -117,6 +117,7 @@ tests/runtests.bat
 tests/runbench.sh
 tests/srfi-4-tests.scm
 tests/srfi-13-tests.scm
+tests/srfi-14-tests.scm
 tests/simple-thread-test.scm
 tests/mutex-test.scm
 tests/hash-table-tests.scm
diff --git a/tests/runtests.bat b/tests/runtests.bat
index 753257a..92b1ce6 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -339,6 +339,12 @@ echo ======================================== srfi-13 tests ...
 %interpret% -s srfi-13-tests.scm
 if errorlevel 1 exit /b 1
 
+echo ======================================== srfi-14 tests ...
+%compile% srfi-14-tests.scm
+if errorlevel 1 exit /b 1
+a.out
+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 093115c..4208c65 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -296,6 +296,10 @@ $interpret -s srfi-4-tests.scm
 echo "======================================== srfi-13 tests ..."
 $interpret -s srfi-13-tests.scm
 
+echo "======================================== srfi-14 tests ..."
+$compile srfi-14-tests.scm
+./a.out
+
 echo "======================================== condition tests ..."
 $interpret -s condition-tests.scm
 
diff --git a/tests/srfi-14-tests.scm b/tests/srfi-14-tests.scm
new file mode 100644
index 0000000..db97c27
--- /dev/null
+++ b/tests/srfi-14-tests.scm
@@ -0,0 +1,202 @@
+;;; This is a regression testing suite for the SRFI-14 char-set library.
+;;; Olin Shivers
+
+(use srfi-14)
+
+(let-syntax ((test (syntax-rules ()
+		     ((test form ...)
+		      (cond ((not form) (error "Test failed" 'form)) ...
+			    (else 'OK))))))
+  (let ((vowel? (lambda (c) (member c '(#\a #\e #\i #\o #\u)))))
+
+(test
+ (not (char-set? 5))
+
+ (char-set? (char-set #\a #\e #\i #\o #\u))
+
+ (char-set=)
+ (char-set= (char-set))
+
+ (char-set= (char-set #\a #\e #\i #\o #\u)
+	    (string->char-set "ioeauaiii"))
+
+ (not (char-set= (char-set #\e #\i #\o #\u)
+		 (string->char-set "ioeauaiii")))
+
+ (char-set<=)
+ (char-set<= (char-set))
+
+ (char-set<= (char-set #\a #\e #\i #\o #\u)
+	     (string->char-set "ioeauaiii"))
+
+ (char-set<= (char-set #\e #\i #\o #\u)
+	     (string->char-set "ioeauaiii"))
+
+ (<= 0 (char-set-hash char-set:graphic 100) 99)
+
+ (= 4 (char-set-fold (lambda (c i) (+ i 1)) 0
+		     (char-set #\e #\i #\o #\u #\e #\e)))
+
+ (char-set= (string->char-set "eiaou2468013579999")
+	    (char-set-unfold null? car cdr '(#\a #\e #\i #\o #\u #\u #\u)
+			     char-set:digit))
+
+ (char-set= (string->char-set "eiaou246801357999")
+	    (char-set-unfold! null? car cdr '(#\a #\e #\i #\o #\u)
+			      (string->char-set "0123456789")))
+
+ (not (char-set= (string->char-set "eiaou246801357")
+		 (char-set-unfold! null? car cdr '(#\a #\e #\i #\o #\u)
+				   (string->char-set "0123456789"))))
+
+ (let ((cs (string->char-set "0123456789")))
+   (char-set-for-each (lambda (c) (set! cs (char-set-delete cs c)))
+		      (string->char-set "02468000"))
+   (char-set= cs (string->char-set "97531")))
+
+ (not (let ((cs (string->char-set "0123456789")))
+	(char-set-for-each (lambda (c) (set! cs (char-set-delete cs c)))
+			   (string->char-set "02468"))
+	(char-set= cs (string->char-set "7531"))))
+
+ (char-set= (char-set-map char-upcase (string->char-set "aeiou"))
+	    (string->char-set "IOUAEEEE"))
+
+ (not (char-set= (char-set-map char-upcase (string->char-set "aeiou"))
+		 (string->char-set "OUAEEEE")))
+
+ (char-set= (char-set-copy (string->char-set "aeiou"))
+	    (string->char-set "aeiou"))
+
+ (char-set= (char-set #\x #\y) (string->char-set "xy"))
+ (not (char-set= (char-set #\x #\y #\z) (string->char-set "xy")))
+
+ (char-set= (string->char-set "xy") (list->char-set '(#\x #\y)))
+ (not (char-set= (string->char-set "axy") (list->char-set '(#\x #\y))))
+
+ (char-set= (string->char-set "xy12345")
+	    (list->char-set '(#\x #\y) (string->char-set "12345")))
+ (not (char-set= (string->char-set "y12345")
+		 (list->char-set '(#\x #\y) (string->char-set "12345"))))
+
+ (char-set= (string->char-set "xy12345")
+	    (list->char-set! '(#\x #\y) (string->char-set "12345")))
+ (not (char-set= (string->char-set "y12345")
+		 (list->char-set! '(#\x #\y) (string->char-set "12345"))))
+
+ (char-set= (string->char-set "aeiou12345")
+	    (char-set-filter vowel? char-set:ascii (string->char-set "12345")))
+ (not (char-set= (string->char-set "aeou12345")
+		 (char-set-filter vowel? char-set:ascii (string->char-set "12345"))))
+
+ (char-set= (string->char-set "aeiou12345")
+	    (char-set-filter! vowel? char-set:ascii (string->char-set "12345")))
+ (not (char-set= (string->char-set "aeou12345")
+		 (char-set-filter! vowel? char-set:ascii (string->char-set "12345"))))
+
+
+ (char-set= (string->char-set "abcdef12345")
+	    (ucs-range->char-set 97 103 #t (string->char-set "12345")))
+ (not (char-set= (string->char-set "abcef12345")
+		 (ucs-range->char-set 97 103 #t (string->char-set "12345"))))
+
+ (char-set= (string->char-set "abcdef12345")
+	    (ucs-range->char-set! 97 103 #t (string->char-set "12345")))
+ (not (char-set= (string->char-set "abcef12345")
+		 (ucs-range->char-set! 97 103 #t (string->char-set "12345"))))
+
+
+ (char-set= (->char-set #\x)
+	    (->char-set "x")
+	    (->char-set (char-set #\x)))
+
+ (not (char-set= (->char-set #\x)
+		 (->char-set "y")
+		 (->char-set (char-set #\x))))
+
+ (= 10 (char-set-size (char-set-intersection char-set:ascii char-set:digit)))
+
+ (= 5 (char-set-count vowel? char-set:ascii))
+
+ (equal? '(#\x) (char-set->list (char-set #\x)))
+ (not (equal? '(#\X) (char-set->list (char-set #\x))))
+
+ (equal? "x" (char-set->string (char-set #\x)))
+ (not (equal? "X" (char-set->string (char-set #\x))))
+
+ (char-set-contains? (->char-set "xyz") #\x)
+ (not (char-set-contains? (->char-set "xyz") #\a))
+
+ (char-set-every char-lower-case? (->char-set "abcd"))
+ (not (char-set-every char-lower-case? (->char-set "abcD")))
+ (char-set-any char-lower-case? (->char-set "abcd"))
+ (not (char-set-any char-lower-case? (->char-set "ABCD")))
+
+ (char-set= (->char-set "ABCD")
+	    (let ((cs (->char-set "abcd")))
+	      (let lp ((cur (char-set-cursor cs)) (ans '()))
+		(if (end-of-char-set? cur) (list->char-set ans)
+		    (lp (char-set-cursor-next cs cur)
+			(cons (char-upcase (char-set-ref cs cur)) ans))))))
+
+
+ (char-set= (char-set-adjoin (->char-set "123") #\x #\a)
+	    (->char-set "123xa"))
+ (not (char-set= (char-set-adjoin (->char-set "123") #\x #\a)
+		 (->char-set "123x")))
+ (char-set= (char-set-adjoin! (->char-set "123") #\x #\a)
+	    (->char-set "123xa"))
+ (not (char-set= (char-set-adjoin! (->char-set "123") #\x #\a)
+		 (->char-set "123x")))
+
+ (char-set= (char-set-delete (->char-set "123") #\2 #\a #\2)
+	    (->char-set "13"))
+ (not (char-set= (char-set-delete (->char-set "123") #\2 #\a #\2)
+		 (->char-set "13a")))
+ (char-set= (char-set-delete! (->char-set "123") #\2 #\a #\2)
+	    (->char-set "13"))
+ (not (char-set= (char-set-delete! (->char-set "123") #\2 #\a #\2)
+		 (->char-set "13a")))
+
+ (char-set= (char-set-intersection char-set:hex-digit (char-set-complement char-set:digit))
+	    (->char-set "abcdefABCDEF"))
+ (char-set= (char-set-intersection! (char-set-complement! (->char-set "0123456789"))
+				    char-set:hex-digit)
+	    (->char-set "abcdefABCDEF"))
+
+ (char-set= (char-set-union char-set:hex-digit
+			    (->char-set "abcdefghijkl"))
+	    (->char-set "abcdefABCDEFghijkl0123456789"))
+ (char-set= (char-set-union! (->char-set "abcdefghijkl")
+			     char-set:hex-digit)
+	    (->char-set "abcdefABCDEFghijkl0123456789"))
+
+ (char-set= (char-set-difference (->char-set "abcdefghijklmn")
+				 char-set:hex-digit)
+	    (->char-set "ghijklmn"))
+ (char-set= (char-set-difference! (->char-set "abcdefghijklmn")
+				  char-set:hex-digit)
+	    (->char-set "ghijklmn"))
+
+ (char-set= (char-set-xor (->char-set "0123456789")
+			  char-set:hex-digit)
+	    (->char-set "abcdefABCDEF"))
+ (char-set= (char-set-xor! (->char-set "0123456789")
+			   char-set:hex-digit)
+	    (->char-set "abcdefABCDEF"))
+
+ (call-with-values (lambda ()
+		     (char-set-diff+intersection char-set:hex-digit
+						 char-set:letter))
+   (lambda (d i)
+     (and (char-set= d (->char-set "0123456789"))
+	  (char-set= i (->char-set "abcdefABCDEF")))))
+
+ (call-with-values (lambda ()
+		     (char-set-diff+intersection! (char-set-copy char-set:hex-digit)
+						  (char-set-copy char-set:letter)))
+   (lambda (d i)
+     (and (char-set= d (->char-set "0123456789"))
+	  (char-set= i (->char-set "abcdefABCDEF"))))))
+
+))
-- 
1.7.0.4