From: Taylor R Campbell <campbell@mumble.net>
Date: Wed, 7 Nov 2018 05:08:02 +0000 (+0000)
Subject: Halfway fix some broken tests.
X-Git-Tag: mit-scheme-pucked-10.1.2~16^2~116^2~37
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7bd86749f7545ca6a20a9298a54b6ef03454845d;p=mit-scheme.git

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 b26219b0a..bdcef4073 100644
--- 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 f9cddacc6..91d26d000 100644
--- 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 6a729744d..af5640f0a 100644
--- 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))
 
-(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))))))
+
+(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)))))
+
+;;; 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 79cc5c0ba..9e06ce15e 100644
--- 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.
 
 ;;;; 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))