>From cfb7dda59ca5f8c6448f21b4b8250740cdf6a7c9 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Thu, 8 Mar 2012 21:47:12 +0100 Subject: [PATCH] Change numbers string conversion test to use a helper procedure to speed it up, and restore compilation (since this might catch possible literal representation errors) --- tests/numbers-string-conversion-tests.scm | 112 ++++++++++++++++------------- tests/runtests.bat | 4 +- tests/runtests.sh | 3 +- 3 files changed, 66 insertions(+), 53 deletions(-) diff --git a/tests/numbers-string-conversion-tests.scm b/tests/numbers-string-conversion-tests.scm index 5f580b0..815798d 100644 --- a/tests/numbers-string-conversion-tests.scm +++ b/tests/numbers-string-conversion-tests.scm @@ -12,7 +12,7 @@ ;;; It also doesn't try to support Schemes which support *only* integers or ;;; *only* flonums (which is also allowed by R5RS). ;;; -(use ports) +(use srfi-1 ports) (define the-nan (fp/ 0.0 0.0)) (define pos-inf (fp/ 1.0 0.0)) @@ -22,59 +22,69 @@ (define total-errors 0) -;; Here comes a horrible nasty hack. It seems to work though ;) +(define (check-string-against-values! str . possible-values) + (define (none? pred) (not (any pred possible-values))) + (let ((res (string->number str))) + (cond + ((none? (lambda (value) + (or (and (not (string? value)) (equal? res value)) + (and res (nan? res) (or (and value (nan? value))))))) + (display "PARSE ERROR ") + (write (cons str possible-values)) + (display " => ") (write res) (newline) + (set! total-errors (+ total-errors 1))) + ((let ((re-str (and res (number->string res)))) + (and (none? (lambda (value) + (or (and res (string=? re-str str)) + (and (not res) (not value)) + (and res (string? value) (string=? re-str value))))) + re-str)) + => (lambda (re-str) + (display "SERIALIZATION ERROR ") + (write (cons str possible-values)) + (display " => ") (write re-str) (newline) + (set! total-errors (+ total-errors 1)))) + ((handle-exceptions exn + (and res exn) + (let ((re-read (with-input-from-string str read))) + (and (not (symbol? re-read)) + (not (eof-object? re-read)) + (or (not res) + (and (not (and (nan? res) (nan? re-read))) + (not (equal? res re-read)))) + re-read))) + => (lambda (obj) + (display (if (condition? obj) + "READBACK EXN ERROR " + "READBACK ERROR ")) + (write (cons str possible-values)) + (display " => ") + (if (condition? obj) + (write ((condition-property-accessor 'exn 'message #f) obj)) + (write obj)) + (newline) + (set! total-errors (+ total-errors 1)))) + ((let ((written&read (with-input-from-string (with-output-to-string + (lambda () (write res))) + read))) + (and (not (or (and (nan? res) (nan? written&read)) + (equal? res written&read))) + written&read)) + => (lambda (read-back) + (display "R/W VARIANCE ERROR ") + (write (cons str possible-values)) + (display " => ") + (write read-back) (newline) + (set! total-errors (+ total-errors 1)))) + (else (display "OK ") + (write (cons str possible-values)) + (newline))))) + (define-syntax test-numbers - (syntax-rules (compnums fractions) + (syntax-rules () ((_ (str value ...) rest ...) (begin - (let ((res (string->number str))) - (if (not (or (and (not (string? value)) (equal? res value)) ... - (and res (nan? res) (or (and value (nan? value)) ...)))) - (begin (display "PARSE ERROR ") - (write '(str value ...)) - (display " => ") (write res) (newline) - (set! total-errors (+ total-errors 1))) - (let ((re-str (and res (number->string res)))) - (if (not (or (and res (string=? re-str str)) - (and (not res) (not value)) ... - (and res (string? value) (string=? re-str value)) ...)) - (begin (display "SERIALIZATION ERROR ") - (write `(str value ...)) - (display " => ") (write re-str) (newline) - (set! total-errors (+ total-errors 1))) - (and (handle-exceptions exn - (if res - (begin (display "READBACK EXN ERROR ") - (write `(str value ...)) - (display " => ") (write exn) (newline) - (set! total-errors (+ total-errors 1)) - #f) - #t) - (let ((re-read (with-input-from-string str read))) - (if (and (not (symbol? re-read)) - (not (eof-object? re-read)) - (or (not res) - (and (not (and (nan? res) (nan? re-read))) - (not (equal? res re-read))))) - (begin (display "READBACK ERROR ") - (write `(str value ...)) - (display " => ") (write re-read) (newline) - (set! total-errors (+ total-errors 1)) - #f) - #t))) - (let ((written&read (with-input-from-string - (with-output-to-string - (lambda () (write res))) - read))) - (if (not (or (and (nan? res) (nan? written&read)) - (equal? res written&read))) - (begin (display "R/W VARIANCE ERROR ") - (write `(str value ...)) - (display " => ") - (write written&read) (newline) - (set! total-errors (+ total-errors 1))) - (begin (display "OK ") - (write '(str value ...)) (newline))))))))) + (check-string-against-values! str value ...) (test-numbers rest ...))) ((_ "no-totals") #f) ((_ x rest ...) diff --git a/tests/runtests.bat b/tests/runtests.bat index 3e8e7ab..88891fa 100644 --- a/tests/runtests.bat +++ b/tests/runtests.bat @@ -322,7 +322,9 @@ a.out if errorlevel 1 exit /b 1 echo ======================================== string->number tests ... -%interpret% -s numbers-string-conversion-tests.scm +%compile% numbers-string-conversion-tests.scm +if errorlevel 1 exit /b 1 +a.out if errorlevel 1 exit /b 1 echo ======================================== srfi-4 tests ... diff --git a/tests/runtests.sh b/tests/runtests.sh index a629ffc..bb68c14 100644 --- a/tests/runtests.sh +++ b/tests/runtests.sh @@ -282,7 +282,8 @@ $compile fixnum-tests.scm ./a.out echo "======================================== string->number tests ..." -$interpret -s numbers-string-conversion-tests.scm +$compile numbers-string-conversion-tests.scm +./a.out echo "======================================== srfi-4 tests ..." $interpret -s srfi-4-tests.scm -- 1.7.9.1