~ chicken-core (chicken-5) 6b7153339ea9c3cb3dc64e5ba337e29824c754a5
commit 6b7153339ea9c3cb3dc64e5ba337e29824c754a5
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sat Jun 29 15:19:17 2019 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Sun Jul 28 17:08:54 2019 +1200
Distinguish between IEEE fp positive and negative zero
To be able to read these numbers, we need a bit of a hacky workaround
because we read integers and then convert them to inexact when needed,
but of course proper integers don't distinguish between positive and
negative zero.
To write these numbers, we need to use signbit(f) instead of checking
whether the number is negative in a "normal" way, because -0.0 is not
smaller than 0.
To compare them, we have the bizarre rule that = will not distinguish,
while equal? and eqv? will.
Fixes #1627, thanks to John Cowan for pointing out this regression from
CHICKEN 4.x (CHICKEN 4 with the numbers egg has the same bug though).
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/NEWS b/NEWS
index 653f5f0d..bfb2536d 100644
--- a/NEWS
+++ b/NEWS
@@ -13,6 +13,9 @@
by SRFI-88 in the corresponding keyword mode. Symbols containing
quoted empty prefixes or suffixes like ||:abc and abc:|| will be
read correctly as symbols now (fixes #1625, thanks to Andy Bennett).
+ - IEEE floating point negative zero is now properly handled: it can
+ be read, written and distinguished by eqv? and equal?, but not =
+ (fixes #1627, thanks to John Cowan).
- Core libraries
- There is now a srfi-88 module which contains just the three
diff --git a/chicken.h b/chicken.h
index 376f5dd2..f97d3195 100644
--- a/chicken.h
+++ b/chicken.h
@@ -2622,15 +2622,22 @@ inline static int C_memcasecmp(const char *x, const char *y, unsigned int len)
return 0;
}
+inline static C_word C_ub_i_flonum_eqvp(double x, double y)
+{
+ /* This can distinguish between -0.0 and +0.0 */
+ return x == y && signbit(x) == signbit(y);
+}
+
inline static C_word basic_eqvp(C_word x, C_word y)
{
return (x == y ||
(!C_immediatep(x) && !C_immediatep(y) &&
C_block_header(x) == C_block_header(y) &&
-
+
((C_block_header(x) == C_FLONUM_TAG &&
- C_flonum_magnitude(x) == C_flonum_magnitude(y)) ||
+ C_ub_i_flonum_eqvp(C_flonum_magnitude(x),
+ C_flonum_magnitude(y))) ||
(C_block_header(x) == C_BIGNUM_TAG &&
C_block_header(y) == C_BIGNUM_TAG &&
diff --git a/library.scm b/library.scm
index f0781366..8c318093 100644
--- a/library.scm
+++ b/library.scm
@@ -2398,9 +2398,13 @@ EOF
;; Shorthand for readability. TODO: Replace other C_subchar calls with this
(define-inline (%subchar s i) (##core#inline "C_subchar" s i))
(define (##sys#string->compnum radix str offset exactness)
- (define (go-inexact!)
- ;; Go inexact unless exact was requested (with #e prefix)
- (unless (eq? exactness 'e) (set! exactness 'i)))
+ ;; Flipped when a sign is encountered (for inexact numbers only)
+ (define negative #f)
+ ;; Go inexact unless exact was requested (with #e prefix)
+ (define (go-inexact! neg?)
+ (unless (eq? exactness 'e)
+ (set! exactness 'i)
+ (set! negative (or negative neg?))))
(define (safe-exponent value e)
(and e (cond
((not value) 0)
@@ -2465,7 +2469,7 @@ EOF
str start (car end) radix neg?)))
(when hashes ; Eeewww. Feeling dirty yet?
(set! seen-hashes? #t)
- (go-inexact!))
+ (go-inexact! neg?))
(cons num (cdr end))))))
(scan-exponent
(lambda (start)
@@ -2474,7 +2478,6 @@ EOF
((#\+) 'pos) ((#\-) 'neg) (else #f))))
(and-let* ((start (if sign (fx+ start 1) start))
(end (scan-digits start)))
- (go-inexact!)
(cons (##core#inline_allocate
("C_s_a_i_digits_to_integer" 5)
str start (car end) radix (eq? sign 'neg))
@@ -2508,18 +2511,19 @@ EOF
(if (and (fx> len (fx+ start 1)) (eq? radix 10)
(eq? (%subchar str start) #\.))
(begin
- (go-inexact!)
+ (go-inexact! neg?)
(scan-decimal-tail (fx+ start 1) neg? #f))
(and-let* ((end (scan-digits+hashes start neg? #f)))
(case (and (cdr end) (%subchar str (cdr end)))
((#\.)
- (go-inexact!)
+ (go-inexact! neg?)
(and (eq? radix 10)
(if (fx> len (fx+ (cdr end) 1))
(scan-decimal-tail (fx+ (cdr end) 1) neg? (car end))
(cons (car end) #f))))
((#\e #\s #\f #\d #\l
#\E #\S #\F #\D #\L)
+ (go-inexact! neg?)
(and-let* (((eq? radix 10))
((fx> len (cdr end)))
(ee (scan-exponent (fx+ (cdr end) 1)))
@@ -2557,7 +2561,7 @@ EOF
(cons (if (eq? sign 'neg) -1 1) next))
((and (fx<= (fx+ next 5) len)
(string-ci=? (substring str next (fx+ next 5)) "inf.0"))
- (go-inexact!)
+ (go-inexact! (eq? sign 'neg))
(cons (if (eq? sign 'neg) -inf.0 +inf.0)
(and (fx< (fx+ next 5) len)
(fx+ next 5))))
@@ -2567,7 +2571,7 @@ EOF
(or (and sign
(fx<= (fx+ next 5) len)
(string-ci=? (substring str next (fx+ next 5)) "nan.0")
- (begin (go-inexact!)
+ (begin (go-inexact! (eq? sign 'neg))
(cons (make-nan)
(and (fx< (fx+ next 5) len)
(fx+ next 5)))))
@@ -2595,7 +2599,10 @@ EOF
(make-polar (car r1) (car r2))))
(else #f)))))
(and number (if (eq? exactness 'i)
- (exact->inexact number)
+ (let ((r (exact->inexact number)))
+ ;; Stupid hack because flonums can represent negative zero,
+ ;; but we're coming from an exact which has no such thing.
+ (if (and negative (zero? r)) (fpneg r) r))
;; Ensure we didn't encounter +inf.0 or +nan.0 with #e
(and (finite? number) number)))))
diff --git a/runtime.c b/runtime.c
index 30620a22..5b4e1277 100644
--- a/runtime.c
+++ b/runtime.c
@@ -4791,7 +4791,8 @@ C_regparm C_word C_fcall C_equalp(C_word x, C_word y)
if((header = C_block_header(x)) != C_block_header(y)) return 0;
else if((bits = header & C_HEADER_BITS_MASK) & C_BYTEBLOCK_BIT) {
if(header == C_FLONUM_TAG && C_block_header(y) == C_FLONUM_TAG)
- return C_flonum_magnitude(x) == C_flonum_magnitude(y);
+ return C_ub_i_flonum_eqvp(C_flonum_magnitude(x),
+ C_flonum_magnitude(y));
else return !C_memcmp(C_data_pointer(x), C_data_pointer(y), header & C_HEADER_SIZE_MASK);
}
else if(header == C_SYMBOL_TAG) return 0;
@@ -11179,7 +11180,7 @@ void C_ccall C_flonum_to_string(C_word c, C_word *av)
}
if(f == 0.0 || (C_modf(f, &m) == 0.0 && log2(fa) < C_WORD_SIZE)) { /* Use fast int code */
- if(f < 0) {
+ if(signbit(f)) {
p = to_n_nary((C_uword)-f, radix, 1, 1);
} else {
p = to_n_nary((C_uword)f, radix, 0, 1);
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index 2379ed0f..dda075f7 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -58,6 +58,20 @@
(assert (not (integer? "foo")))
; XXX number missing
+;; Negative vs positive zero (see #1627)
+(assert (not (eqv? 0.0 -0.0)))
+(assert (not (equal? 0.0 -0.0)))
+(assert (= 0.0 -0.0))
+
+(assert (not (positive? 0.0)))
+(assert (not (negative? 0.0)))
+(assert (zero? 0.0))
+
+(assert (not (positive? -0.0)))
+(assert (not (negative? -0.0)))
+(assert (zero? -0.0))
+
+;; Exactness
(assert (exact? 1))
(assert (not (exact? 1.0)))
(assert (not (exact? 1.1)))
diff --git a/tests/numbers-string-conversion-tests.scm b/tests/numbers-string-conversion-tests.scm
index b71282de..ad673a46 100644
--- a/tests/numbers-string-conversion-tests.scm
+++ b/tests/numbers-string-conversion-tests.scm
@@ -507,3 +507,13 @@
(error "No error on invalid base" b))))
(condition-case (check-base 1) ((exn type) 'ok))
(condition-case (check-base 37) ((exn type) 'ok)))
+
+;; #1627 - Even though R7RS Scheme allows not distinguishing negative
+;; zero (as in the test above), we do.
+(assert (string=? "-0.0" (number->string -0.0)))
+(assert (string=? "0.0" (number->string +0.0)))
+(assert (eqv? -0.0 (string->number "-0.0")))
+(assert (eqv? 0.0 (string->number "+0.0")))
+(assert (eqv? 0.0 (string->number "0.0")))
+(assert (eqv? -0.0 (string->number "-0e1")))
+(assert (eqv? 0.0 (string->number "0e-1")))
Trap