~ chicken-core (chicken-5) 296874e523a6bcbd157b8112d59919f0eba76b2c
commit 296874e523a6bcbd157b8112d59919f0eba76b2c
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Sep 28 12:25:53 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Sep 28 12:25:53 2011 +0200
push exactness check into ##sys#string->number to catch superfluous base/exactness prefixes in numbers parsing; added tests (developed in collaboration with sjamaan)
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/library.scm b/library.scm
index d84c8053..4cf975cd 100644
--- a/library.scm
+++ b/library.scm
@@ -1070,8 +1070,12 @@ EOF
(##sys#lcm head n2)
(##sys#slot next 1)) #f) ) ) ) ) ) )
-(define (##sys#string->number str #!optional (radix 10))
- (##core#inline_allocate ("C_a_i_string_to_number" 4) str radix))
+(define (##sys#string->number str #!optional (radix 10) exactness)
+ (let ((num (##core#inline_allocate ("C_a_i_string_to_number" 4) str radix)))
+ (case exactness
+ ((i) (##core#inline_allocate ("C_a_i_exact_to_inexact" 4) num))
+ ((e) (##core#inline "C_i_inexact_to_exact" num))
+ (else num))))
(define string->number ##sys#string->number)
(define ##sys#number->string (##core#primitive "C_number_to_string"))
@@ -2526,20 +2530,25 @@ EOF
(##sys#list->vector lst)
(##sys#read-error port "invalid vector syntax" lst) ) ) )
- (define (r-number radix)
+ (define (r-number radix exactness)
(set! rat-flag #f)
(let ([tok (r-token)])
- (if (string=? tok ".")
- (##sys#read-error port "invalid use of `.'")
- (let ([val (##sys#string->number tok (or radix 10))] )
+ (cond
+ [(string=? tok ".")
+ (##sys#read-error port "invalid use of `.'")]
+ [(and (fx> (##sys#size tok) 0) (char=? (string-ref tok 0) #\#))
+ (##sys#read-error port "unexpected prefix in number syntax" tok)]
+ [else
+ (let ([val (##sys#string->number tok (or radix 10) exactness)] )
(cond [val
+ ;;XXX move this into ##sys#string->number ?
(when (and (##sys#inexact? val) rat-flag)
(##sys#read-warning
port
"cannot represent exact fraction - coerced to flonum" tok) )
val]
[radix (##sys#read-error port "illegal number syntax" tok)]
- [else (build-symbol tok)] ) ) ) ) )
+ [else (build-symbol tok)] ) ) ] ) ) )
(define (r-number-with-exactness radix)
(cond [(char=? #\# (##sys#peek-char-0 port))
@@ -2547,25 +2556,25 @@ EOF
(let ([c2 (##sys#read-char-0 port)])
(cond [(eof-object? c2)
(##sys#read-error port "unexpected end of numeric literal")]
- [(char=? c2 #\i) (##sys#exact->inexact (r-number radix))]
- [(char=? c2 #\e) (##sys#inexact->exact (r-number radix))]
+ [(char=? c2 #\i) (r-number radix 'i)]
+ [(char=? c2 #\e) (r-number radix 'e)]
[else
(##sys#read-error
port
"illegal number syntax - invalid exactness prefix" c2)] ) ) ]
- [else (r-number radix)] ) )
+ [else (r-number radix #f)] ) )
- (define (r-number-with-radix)
+ (define (r-number-with-radix exactness)
(cond [(char=? #\# (##sys#peek-char-0 port))
(##sys#read-char-0 port)
(let ([c2 (##sys#read-char-0 port)])
(cond [(eof-object? c2) (##sys#read-error port "unexpected end of numeric literal")]
- [(char=? c2 #\x) (r-number 16)]
- [(char=? c2 #\d) (r-number 10)]
- [(char=? c2 #\o) (r-number 8)]
- [(char=? c2 #\b) (r-number 2)]
+ [(char=? c2 #\x) (r-number 16 exactness)]
+ [(char=? c2 #\d) (r-number 10 exactness)]
+ [(char=? c2 #\o) (r-number 8 exactness)]
+ [(char=? c2 #\b) (r-number 2 exactness)]
[else (##sys#read-error port "illegal number syntax - invalid radix" c2)] ) ) ]
- [else (r-number 10)] ) )
+ [else (r-number 10 exactness)] ) )
(define (r-token)
(let loop ((c (##sys#peek-char-0 port)) (lst '()))
@@ -2783,8 +2792,8 @@ EOF
((#\d) (##sys#read-char-0 port) (r-number-with-exactness 10))
((#\o) (##sys#read-char-0 port) (r-number-with-exactness 8))
((#\b) (##sys#read-char-0 port) (r-number-with-exactness 2))
- ((#\i) (##sys#read-char-0 port) (##sys#exact->inexact (r-number-with-radix)))
- ((#\e) (##sys#read-char-0 port) (##sys#inexact->exact (r-number-with-radix)))
+ ((#\i) (##sys#read-char-0 port) (r-number-with-radix 'i))
+ ((#\e) (##sys#read-char-0 port) (r-number-with-radix 'e))
((#\c)
(##sys#read-char-0 port)
(let ([c (##sys#read-char-0 port)])
@@ -2852,11 +2861,11 @@ EOF
((#\() (r-list #\( #\)))
((#\)) (##sys#read-char-0 port) (container c))
((#\") (##sys#read-char-0 port) (r-string #\"))
- ((#\.) (r-number #f))
- ((#\- #\+) (r-number #f))
+ ((#\.) (r-number #f #f))
+ ((#\- #\+) (r-number #f #f))
(else
(cond [(eof-object? c) c]
- [(char-numeric? c) (r-number #f)]
+ [(char-numeric? c) (r-number #f #f)]
((memq c reserved-characters)
(reserved-character c))
(else
diff --git a/tests/numbers-string-conversion-tests.scm b/tests/numbers-string-conversion-tests.scm
index ca5c2e7a..c1b9d675 100644
--- a/tests/numbers-string-conversion-tests.scm
+++ b/tests/numbers-string-conversion-tests.scm
@@ -41,8 +41,39 @@
(write `(str value ...))
(display " => ") (write re-str) (newline)
(set! total-errors (+ total-errors 1)))
- (begin (display "OK ")
- (write '(str value ...)) (newline))))))
+ (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)))))))))
(test-numbers rest ...)))
((_ "no-totals") #f)
((_ x rest ...)
Trap