From 7bd86749f7545ca6a20a9298a54b6ef03454845d Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Wed, 7 Nov 2018 05:08:02 +0000 Subject: [PATCH] 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!) --- tests/check.scm | 1 + tests/runtime/test-char-set.scm | 25 +++-- tests/runtime/test-random.scm | 191 +++++++++++++++++++++++++++----- tests/unit-testing.scm | 10 +- 4 files changed, 190 insertions(+), 37 deletions(-) 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)) -- 2.25.1