Halfway fix some broken tests.

- Use with-test-properties, not run-sub-test.

- Disable run-sub-test in the test environment; it doesn't make sense
  for tests to call it.

- Add a rudimentary expect-failure.  (Feel free to spruce this up
  with a message detailing the nature of the expectation, a note in
  the final report, &c.)

- Partly fix test-char-set.scm, which was silently nonfunctional
  because of run-sub-test.  Leave an xfail for the part I don't know
  how to fix.  (Chris -- if you could fix this, that would be great!)

diff --git a/tests/check.scm b/tests/check.scm
index b26219b0a1b1da3932ecc372fce40549ef931a43..bdcef40737eaa1a7bce4a34d31285dc564bdd7e6 100644 (file)
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -75,6 +75,7 @@ USA.
     "runtime/test-predicate"
     ("runtime/test-predicate-dispatch" (runtime predicate-dispatch))
     "runtime/test-process"
+    "runtime/test-random"
     "runtime/test-readwrite"
     "runtime/test-regsexp"
     "runtime/test-rgxcmp"

diff --git a/tests/runtime/test-char-set.scm b/tests/runtime/test-char-set.scm
index f9cddacc6959f6a53f8f8cc981b12a920a1e5150..91d26d000bc0c0b16e289b5c85e6bffd94f77af7 100644 (file)
--- a/tests/runtime/test-char-set.scm
+++ b/tests/runtime/test-char-set.scm
@@ -31,7 +31,7 @@ USA.
 (define-test 'interesting-svl-round-trip
   (lambda ()
     (map (lambda (svl)
-          (run-sub-test
+          (with-test-properties
            (lambda ()
              (assert-equal-canonical-svls (trim-empty-segments svl)
                                           (svl-round-trip svl)))
@@ -44,7 +44,7 @@ USA.
 (define-test 'random-svl-round-trip
   (lambda ()
     (map (lambda (svl)
-          (run-sub-test
+          (with-test-properties
            (lambda ()
              (guarantee code-point-list? svl)
              (assert-equal-canonical-svls (canonicalize-svl svl)
@@ -55,8 +55,8 @@ USA.
                  (make-random-svls 100 100)))))
 
 (define (canonicalize-svl svl)
-  (named-call '%CANONICALIZE-SCALAR-VALUE-LIST
-             %canonicalize-scalar-value-list
+  (named-call 'NORMALIZE-RANGES
+             normalize-ranges
              svl))
 
 (define (make-random-svls n-ranges n-iter)
@@ -81,7 +81,7 @@ USA.
   (lambda ()
     (map (lambda (svl)
           (map (lambda (value)
-                 (run-sub-test
+                 (with-test-properties
                   (lambda ()
                     (assert-boolean=
                      (char-in-set? (integer->char value) (char-set* svl))
@@ -111,10 +111,17 @@ USA.
 (define-test 'invert
   (lambda ()
     (map (lambda (svl)
-          (run-sub-test
+          (with-test-properties
            (lambda ()
-             (assert-equal (svl-invert-thru svl)
-                           (svl-invert-direct (trim-empty-segments svl))))
+             ((lambda (body)
+                (if (equal? svl '())
+                    ;; XXX Broken, please fix!
+                    (expect-failure body)
+                    body))
+              (lambda ()
+                (assert-equal
+                 (svl-invert-thru svl)
+                 (svl-invert-direct (trim-empty-segments svl))))))
            'EXPRESSION `(SVL-INVERT ,svl)))
         interesting-svls)))
 
@@ -143,7 +150,7 @@ USA.
   (lambda ()
     (map (lambda (svl1)
           (map (lambda (svl2)
-                 (run-sub-test
+                 (with-test-properties
                   (lambda ()
                     (assert-equal
                      (char-set->code-points

diff --git a/tests/runtime/test-random.scm b/tests/runtime/test-random.scm
index 6a729744db3f12099fc267701803644600d0f08f..af5640f0a2511f442e0171b13c91fdc101be95ac 100644 (file)
--- a/tests/runtime/test-random.scm
+++ b/tests/runtime/test-random.scm
@@ -24,33 +24,170 @@ USA.
 
 |#
 
-;;;; Tests of random-number generator
+;;;; Tests of random number generator
 
 (declare (usual-integrations))
 \f
-(define (fill-file-with-random-integers n-bits-in-file
-                                       n-bits-per-integer
-                                       n-progress-dots
-                                       filename)
-  (if (not (= 0 (remainder n-bits-in-file n-bits-per-integer)))
-      (error:bad-range-argument n-bits-in-file
-                               'FILL-FILE-WITH-RANDOM-INTEGERS))
-  (if (not (= 0 (remainder n-bits-per-integer 8)))
-      (error:bad-range-argument n-bits-per-integer
-                               'FILL-FILE-WITH-RANDOM-INTEGERS))
-  (call-with-output-file filename
-    (lambda (port)
-      (let ((modulus (expt 2 n-bits-per-integer))
-           (j-limit (quotient n-bits-in-file n-bits-per-integer))
-           (i-limit (quotient n-bits-per-integer 8)))
-       (let ((j-dot (quotient j-limit n-progress-dots))
-             (buffer (make-legacy-string i-limit)))
-         (do ((j 0 (+ j 1)))
-             ((= j j-limit))
-           (if (= 0 (remainder j j-dot))
-               (write-char #\.))
-           (do ((i 0 (+ i 1))
-                (n (random modulus) (quotient n #x100)))
-               ((= i i-limit))
-             (vector-8b-set! buffer i (remainder n #x100)))
-           (write-string buffer port)))))))
\ No newline at end of file
+(define-test 'random-state
+  (lambda ()
+    (assert-true (random-state? (make-random-state)))))
+
+(define-test 'random-source
+  (lambda ()
+    (assert-true (random-source? (make-random-source)))))
+
+(define-test 'random-state-fresh
+  (lambda ()
+    (let* ((s0 (make-random-state #t))
+          (s1 (make-random-state #t)))
+      (assert-!= ((random-source-make-integers s0) (expt 2 32))
+                ((random-source-make-integers s1) (expt 2 32))))))
+
+(define-test 'random-source-randomize!
+  (lambda ()
+    (let* ((s0 (make-random-state #t))
+          (s1 (make-random-state s0)))
+      (random-source-randomize! s0)
+      (assert-!= ((random-source-make-integers s0) (expt 2 32))
+                ((random-source-make-integers s1) (expt 2 32))))))
+\f
+(define (define-random-test name procedure)
+  (define-test name
+    (lambda ()
+      ;; XXX Should make the seed more compact than just the original
+      ;; complete state.
+      (let ((state (make-random-state)))
+       (with-test-properties
+           (lambda ()
+             ;; Ensure we don't accidentally use the global state.
+             (fluid-let ((*random-state* 'loser-state)
+                         (default-random-source 'loser-source))
+               (procedure state)))
+         'seed (export-random-state state))))))
+
+(define-random-test 'random-state-derived
+  (lambda (state)
+    (let* ((s0 (make-random-state state))
+          (s1 (make-random-state s0)))
+      (assert-true (random-state? s0))
+      (assert-true (random-state? s1))
+      (assert-= ((random-source-make-integers s0) (expt 2 64))
+               ((random-source-make-integers s1) (expt 2 64))))))
+
+(define-random-test 'random-source-ref/set!
+  (lambda (state)
+    (let* ((s0 state)
+          (s1 (make-random-state #t)))
+      (random-source-state-set! s1 (random-source-state-ref s0))
+      (assert-= ((random-source-make-integers s0) (expt 2 64))
+               ((random-source-make-integers s1) (expt 2 64))))))
+
+(define-random-test 'import/export
+  (lambda (state)
+    (let* ((s0 (make-random-state state))
+          (s1 (import-random-state (export-random-state s0))))
+      (assert-= ((random-source-make-integers s0) (expt 2 64))
+               ((random-source-make-integers s1) (expt 2 64))))))
+
+(define-random-test 'random/integer
+  (lambda (state)
+    (let ((ok (make-vector 3)))
+      (do ((i 0 (+ i 1)))
+         ((>= i 300))
+       (vector-set! ok (random 3 state) #t))
+      (do ((i 0 (+ i 1)))
+         ((>= i 3))
+       (assert-true (vector-ref ok i))))))
+
+(define-random-test 'random/float
+  (lambda (state)
+    (do ((i 0 (+ i 1)))
+       ((>= i 64))
+      (let ((x (random 0.25 state)))
+       ((predicate-assertion flo:flonum? "flonum") x)
+       (assert-true (<= 0 x 0.25))))))
+
+(define-random-test 'random/rational
+  (lambda (state)
+    (assert-error (lambda () (random 1/4 state)))))
+\f
+;;; Stochastic tests
+
+(define NSAMPLES 100000)
+(define NTRIALS 2)
+(define NPASSES-MIN 1)
+
+(define PSI-DF 100)                    ;degrees of freedom
+(define PSI-CRITICAL 135.807)          ;critical value, alpha = .01
+
+(define (psi-test counts logps n)
+  (let loop ((i 0) (psi 0.) (c 0.))
+    (if (< i PSI-DF)
+       (let ((count (vector-ref counts i))
+             (logp (vector-ref logps i)))
+         (if (= count 0)
+             (loop (+ i 1) psi c)
+             (let* ((t (* count (- (log (/ count n)) logp)))
+                    (t* (- t c))
+                    (psi* (+ psi t*))
+                    (c* (- (- psi* psi) t*)))
+               (loop (+ i 1) psi* c*))))
+       (<= (* 2 psi) PSI-CRITICAL))))
+
+(define (count-sample nsamples procedure)
+  (let ((counts (make-vector PSI-DF 0)))
+    (do ((i 0 (+ i 1)))
+       ((>= i nsamples))
+      (let ((bin (procedure)))
+       (vector-set! counts bin (+ 1 (vector-ref counts bin)))))
+    counts))
+
+(define (assert-psi-test nsamples logps procedure)
+  ;; Square the false positive rate for each test case (alpha=.01 --->
+  ;; alpha=.0001) so that the false positive rate for the whole test
+  ;; suite isn't too high.
+  (assert-true
+   (or (psi-test (count-sample nsamples procedure) logps nsamples)
+       (psi-test (count-sample nsamples procedure) logps nsamples))))
+
+(define-random-test 'uniform-float01
+  (lambda (state)
+    (let ((logps (make-vector PSI-DF (log (/ 1 PSI-DF)))))
+      (assert-psi-test NSAMPLES logps
+       (lambda ()
+         (min (- PSI-DF 1)
+              (floor->exact (* PSI-DF (flo:random-unit state)))))))))
+
+(define-random-test 'uniform-integer
+  (lambda (state)
+    (let ((random-integer (random-source-make-integers state))
+         (logps (make-vector PSI-DF (log (/ 1 PSI-DF)))))
+      (assert-psi-test NSAMPLES logps
+       (lambda ()
+         (random-integer PSI-DF))))))
+
+;;; Confirm that this simple-minded psi test has adequate statistical
+;;; power to detect a modulo bias.
+
+(define-random-test 'nonuniform-integer
+  (lambda (state)
+    (let ((random-integer (random-source-make-integers state))
+         (logps (make-vector PSI-DF (log (/ 1 PSI-DF)))))
+      (define (sampler)
+       (modulo (random-integer (+ 1 (* 2 PSI-DF))) PSI-DF))
+      (assert-false
+       (psi-test (count-sample nsamples sampler) logps nsamples)))))
+
+(define-random-test 'geometric-1/2
+  (lambda (state)
+    (let ((random-integer (random-source-make-integers state))
+         (logps
+          (make-initialized-vector PSI-DF
+            (lambda (k)
+              ;; p = 1/2, so p = 1 - p, so (1 - p)^{k - 1} * p = p^k.
+              (* k (log 1/2))))))
+      (assert-psi-test NSAMPLES logps
+       (lambda ()
+         (min (- PSI-DF 1)
+              ;; Probability of zero is 1/2^1000 = never.
+              (first-set-bit (random-integer (shift-left 1 1000)))))))))

diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm
index 79cc5c0baf083cf65c2f9d777d87c397f34e4c7e..9e06ce15e58ff0db56780bb1640aec7fc1043026 100644 (file)
--- a/tests/unit-testing.scm
+++ b/tests/unit-testing.scm
@@ -250,6 +250,11 @@ USA.
          (write-string "assertion " port)
          (write (cdr p) port)
          (write-string ": " port))))
+  (cond ((failure-property 'SEED failure)
+        => (lambda (p)
+             (write-string " (seed " port)
+             (write (cdr p) port)
+             (write-string ") " port))))
   (cond ((failure-property 'CONDITION failure)
         => (lambda (p)
              (let ((expr (failure-property 'EXPRESSION failure)))
@@ -319,7 +324,7 @@ USA.
 \f
 ;;;; Assertions
 
-(define-for-tests (run-sub-test thunk . properties)
+(define (run-sub-test thunk . properties)
   (call-with-current-continuation
    (lambda (k)
      (parameterize ((assertion-index 1))
@@ -441,6 +446,9 @@ USA.
 (define-for-tests assert-range-error
   (error-assertion condition-type:bad-range-argument))
 
+(define-for-tests expect-failure
+  (error-assertion condition-type:failure))
+
 (define-for-tests keep-it-fast!?
   (let ((v (get-environment-variable "FAST")))
     (if (or (eq? v #f) (string-null? v))