Get unit tests working.

diff --git a/tests/runtime/test-char-set.scm b/tests/runtime/test-char-set.scm
index 87a83e488e7bf0f5d4a11f079fbc2fa3fc46a81a..a0323d5c896800dbd5bb09b61df91a0a0f1bbd7d 100644 (file)
--- a/tests/runtime/test-char-set.scm
+++ b/tests/runtime/test-char-set.scm
@@ -27,60 +27,74 @@ USA.
 
 (declare (usual-integrations))
 \f
-(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