From 37faef9232d3c599731c9645b198217ff4d96f05 Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Fri, 16 Nov 2018 07:05:17 +0000 Subject: [PATCH] Don't transform (- x) into (- 0 x). The transformation is wrong for floating-point signed zero. --- src/sf/usiexp.scm | 28 +++++++++++++++------------- tests/runtime/test-arith.scm | 4 +--- 2 files changed, 16 insertions(+), 16 deletions(-) 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 -- 2.25.1