From: Taylor R Campbell <campbell@mumble.net>
Date: Fri, 16 Nov 2018 07:05:17 +0000 (+0000)
Subject: Don't transform (- x) into (- 0 x).
X-Git-Tag: mit-scheme-pucked-10.1.2~16^2~84
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=37faef9232d3c599731c9645b198217ff4d96f05;p=mit-scheme.git

Don't transform (- x) into (- 0 x).

The transformation is wrong for floating-point signed zero.
---

diff --git a/src/sf/usiexp.scm b/src/sf/usiexp.scm
index 3eb298868..b9f3fe10d 100644
--- a/src/sf/usiexp.scm
+++ b/src/sf/usiexp.scm
@@ -274,19 +274,21 @@ USA.
 
 (define (right-accumulation-inverse identity inverse-expansion make-binary)
   (lambda (expr operands block)
-    (let ((expand
-	   (lambda (expr x y)
-	      (if (constant-eq? y identity)
-		  x
-		  (make-binary expr block x y)))))
-      (cond ((null? operands) #f)
-	    ((null? (cdr operands))
-	     (expand expr (constant/make #f identity) (car operands)))
-	    (else
-	     (let ((inverse (inverse-expansion #f (cdr operands) block)))
-	       (if inverse
-		   (expand expr (car operands) inverse)
-		   #f)))))))
+    (cond ((null? operands) #f)
+	  ((null? (cdr operands))
+	   (let ((y (car operands)))
+	     (if (constant-eq? y identity)
+		 (constant/make #f identity)
+		 ;; Converting (- x) to (- 0 x) breaks signed zero.
+		 #f)))
+	  ((inverse-expansion #f (cdr operands) block)
+	   => (lambda (inverse)
+		(let ((x (car operands))
+		      (y inverse))
+		  (if (constant-eq? inverse identity)
+		      x
+		      (make-binary expr block x y)))))
+	  (else #f))))
 
 (define --expansion
   (right-accumulation-inverse 0 +-expansion
diff --git a/tests/runtime/test-arith.scm b/tests/runtime/test-arith.scm
index 312b43b66..8f60ea75f 100644
--- a/tests/runtime/test-arith.scm
+++ b/tests/runtime/test-arith.scm
@@ -374,7 +374,5 @@ USA.
   (lambda (v)
     (let ((x (vector-ref v 0))
           (y (vector-ref v 1)))
-      (if (flo:= -1. (flo:copysign 1. x))
-          (assert-eqv (- x) y)
-          (expect-failure (lambda () (assert-eqv (- x) y))))
+      (assert-eqv (- x) y)
       (assert-eqv (- 0 (flo:copysign 1. x)) (flo:copysign 1. y)))))
\ No newline at end of file