~ chicken-core (chicken-5) 5303c411c6d148a8dc40e3e0ecf00422b2babced
commit 5303c411c6d148a8dc40e3e0ecf00422b2babced
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Thu Mar 8 21:47:12 2012 +0100
Commit: Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Sun Mar 11 18:49:20 2012 +0100
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)
Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>
diff --git a/tests/numbers-string-conversion-tests.scm b/tests/numbers-string-conversion-tests.scm
index 5f580b09..815798d8 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 3e8e7ab4..88891faa 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 a629ffcf..bb68c14a 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
Trap