From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 24 May 2010 05:09:30 +0000 (-0700)
Subject: Get unit tests working.
X-Git-Tag: 20100708-Gtk~59
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f3e967addfc122dcdf34464d1d57251dedca9c19;p=mit-scheme.git

Get unit tests working.
---

diff --git a/tests/runtime/test-char-set.scm b/tests/runtime/test-char-set.scm
index 87a83e488..a0323d5c8 100644
--- a/tests/runtime/test-char-set.scm
+++ b/tests/runtime/test-char-set.scm
@@ -27,60 +27,74 @@ USA.
 
 (declare (usual-integrations))
 
-(define (test-canonicalize-scalar-value-list n-items n-iter)
-  (run-cpl-test n-items n-iter canonicalize-scalar-value-list))
+(define (make-test:%canonicalize-scalar-value-list n-ranges n-iter)
+  (make-random-svl-tests n-ranges n-iter %canonicalize-scalar-value-list))
 
-(define (test-char-set->scalar-values n-items n-iter)
-  (run-cpl-test n-items n-iter
-		(lambda (cpl)
-		  (char-set->scalar-values (scalar-values->char-set cpl)))))
+(define (make-test:char-set->scalar-values n-ranges n-iter)
+  (make-random-svl-tests n-ranges n-iter
+    (lambda (svl)
+      (char-set->scalar-values (scalar-values->char-set svl)))))
 
-(define (run-cpl-test n-items n-iter procedure)
-  (do ((i 0 (+ i 1))
-       (failures '()
-		 (let ((cpl (make-test-cpl n-items)))
-		   (guarantee-well-formed-scalar-value-list cpl)
-		   (let ((cpl* (procedure cpl)))
-		     (if (canonical-scalar-value-list? cpl*)
-			 failures
-			 (cons (cons cpl cpl*) failures))))))
-      ((not (< i n-iter))
-       (let ((n-failures (length failures)))
-	 (if (> n-failures 0)
-	     (begin
-	       (write-string "Got ")
-	       (write n-failures)
-	       (write-string " failure")
-	       (if (> n-failures 1)
-		   (write-string "s"))
-	       (write-string " out of ")
-	       (write n-iter)
-	       (newline)
-	       (pp failures)))))))
-
-(define (make-test-cpl n-items)
-  (make-initialized-list n-items
+(define (make-random-svl-tests n-ranges n-iter procedure)
+  (make-initialized-list n-iter
     (lambda (i)
-      (let loop ()
-	(let ((n (random #x10000)))
-	  (if (unicode-scalar-value? n)
-	      (let ((m (random #x100)))
-		(if (fix:= m 0)
-		    n
-		    (if (unicode-scalar-value? (fix:+ n m))
-			(fix:+ n m)
-			(loop))))
-	      (loop)))))))
+      i
+      (lambda ()
+	(let ((svl (make-random-svl n-ranges)))
+	  (guarantee-well-formed-scalar-value-list svl)
+	  (let ((svl1 (%canonicalize-scalar-value-list svl))
+		(svl2 (char-set->scalar-values (scalar-values->char-set svl))))
+	    (or (assert-true `(canonical-svl? ,svl1)
+			     (canonical-svl? svl1))
+		(assert-true `(canonical-svl? ,svl2)
+			     (canonical-svl? svl2))
+		(assert-equal svl1 svl2))))))))
+
+(define (make-random-svl n-ranges)
+  ;; Random modulus must exceed %LOW-LIMIT.
+  (let ((modulus #x1000))
+    (make-initialized-list n-ranges
+      (lambda (i)
+	(let loop ()
+	  (let ((n (random (- char-code-limit modulus))))
+	    (let ((m (random modulus)))
+	      (if (= m 0)
+		  n
+		  (cons n (+ n m 1))))))))))
+
+(define (canonical-svl? items)
+  (and (list-of-type? items
+	 (lambda (item)
+	   (if (pair? item)
+	       (and (exact-nonnegative-integer? (car item))
+		    (exact-nonnegative-integer? (cdr item))
+		    (< (car item) (cdr item))
+		    (<= (cdr item) char-code-limit))
+	       (and (exact-nonnegative-integer? item)
+		    (< item char-code-limit)))))
+       (every-tail (lambda (tail)
+		     (if (and (pair? tail)
+			      (pair? (cdr tail)))
+			 (< (let ((a (car tail)))
+			      (if (pair? a)
+				  (cdr a)
+				  (+ a 1)))
+			    (let ((b (cadr tail)))
+			      (if (pair? b)
+				  (car b)
+				  b)))
+			 #t))
+		   items)))
+
+(define (every-tail pred items)
+  (if (pair? items)
+      (and (pred items)
+	   (every-tail pred (cdr items)))
+      (pred items)))
 
-(define (canonical-scalar-value-list? items)
-  (and (well-formed-scalar-value-list? items)
-       (if (pair? items)
-	   (let loop ((a (car items)) (items (cdr items)))
-	     (if (pair? items)
-		 (let ((b (car items))
-		       (items (cdr items)))
-		   (and (fix:< (fix:+ (if (pair? a) (cdr a) a) 1)
-			       (if (pair? b) (car b) b))
-			(loop b items)))
-		 #t))
-	   #t)))
\ No newline at end of file
+(define-test '%canonicalize-scalar-value-list
+  (make-test:%canonicalize-scalar-value-list 0 1)
+  (map (lambda (i)
+	 (make-test:%canonicalize-scalar-value-list i 100))
+       (iota 4 1))
+  (make-test:%canonicalize-scalar-value-list 100 100))
\ No newline at end of file