From f3e967addfc122dcdf34464d1d57251dedca9c19 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 23 May 2010 22:09:30 -0700
Subject: [PATCH] Get unit tests working.
---
tests/runtime/test-char-set.scm | 120 ++++++++++++++++++--------------
1 file changed, 67 insertions(+), 53 deletions(-)
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
--
2.25.1