From 643b24c3b78b26841dc53d37260765e99c2bc614 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 24 Jul 2008 00:23:05 +0000 Subject: [PATCH] change the way multiple-value results are compared in r6rs test suite svn: r10888 --- collects/tests/r6rs/test.sls | 29 +++++++++++++++++++++-------- 1 file changed, 21 insertions(+), 8 deletions(-) diff --git a/collects/tests/r6rs/test.sls b/collects/tests/r6rs/test.sls index 8516e15051..d71b53f26d 100644 --- a/collects/tests/r6rs/test.sls +++ b/collects/tests/r6rs/test.sls @@ -19,6 +19,9 @@ (define-record-type expected-exception (fields)) + (define-record-type multiple-results + (fields values)) + (define-syntax test (syntax-rules () [(_ expr expected) @@ -55,8 +58,8 @@ [(_ expr val ...) (test (call-with-values (lambda () expr) - list) - (list val ...))])) + (lambda results (make-multiple-results results))) + (make-multiple-results (list val ...)))])) (define-syntax test/output (syntax-rules () @@ -106,14 +109,24 @@ (if (file-exists? "tmp-catch-out") (delete-file "tmp-catch-out"))))) + (define (same-result? got expected) + (cond + [(and (real? expected) (nan? expected)) + (and (real? got) (nan? got))] + [(expected-exception? expected) + (expected-exception? got)] + [(multiple-results? expected) + (and (multiple-results? got) + (= (length (multiple-results-values expected)) + (length (multiple-results-values got))) + (for-all same-result? + (multiple-results-values expected) + (multiple-results-values got)))] + [else (equal? got expected)])) + (define (run-test expr got expected) (set! checked (+ 1 checked)) - (unless (if (and (real? expected) - (nan? expected)) - (and (real? got) (nan? got)) - (or (equal? got expected) - (and (expected-exception? expected) - (expected-exception? got)))) + (unless (same-result? got expected) (set! failures (cons (list expr got expected) failures))))