[Guile-commits] 01/01: Fix bug in comparison between real and complex

[Daniel Llorens]

lloda pushed a commit to branch master
in repository guile.

commit 7de77bf7d8016446b4fcddb36e588406266ec40a
Author: Daniel Llorens <address@hidden>
Date:   Thu Mar 9 15:13:19 2017 +0100

    Fix bug in comparison between real and complex
    
    This bug was introduced by 35a90592501ebde7e7ddbf2486ca9d315e317d09.
    
    * module/language/cps/specialize-numbers.scm (specialize-operations):
      Check that both operands are real as a condition for
      specialize-f64-comparison.
    * test-suite/tests/numbers.test: Add test.
---
 module/language/cps/specialize-numbers.scm | 14 ++++++++------
 test-suite/tests/numbers.test              |  9 +++++++++
 2 files changed, 17 insertions(+), 6 deletions(-)

diff --git a/module/language/cps/specialize-numbers.scm 
b/module/language/cps/specialize-numbers.scm
index 808ea67..d558703 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -51,6 +51,7 @@
 (define-module (language cps specialize-numbers)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (language cps)
   #:use-module (language cps intmap)
   #:use-module (language cps intset)
@@ -301,11 +302,12 @@ BITS indicating the significant bits needed for a 
variable.  BITS may be
             (lambda (type min max)
               (and (eqv? type &exact-integer)
                    (<= 0 min max #xffffffffffffffff))))))
-    (define (f64-operand? var)
-      (call-with-values (lambda ()
-                          (lookup-pre-type types label var))
-        (lambda (type min max)
-          (and (eqv? type &flonum)))))
+    (define (f64-operands? vara varb)
+      (let-values (((typea mina maxa) (lookup-pre-type types label vara))
+                   ((typeb minb maxb) (lookup-pre-type types label varb)))
+        (and (zero? (logand (logior typea typeb) (lognot &real)))
+             (or (eqv? typea &flonum)
+                 (eqv? typeb &flonum)))))
     (match cont
       (($ $kfun)
        (let ((types (infer-types cps label)))
@@ -411,7 +413,7 @@ BITS indicating the significant bits needed for a variable. 
 BITS may be
              ($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a 
b)))))
        (values
         (cond
-         ((or (f64-operand? a) (f64-operand? b))
+         ((f64-operands? a b)
           (with-cps cps
             (let$ body (specialize-f64-comparison k kt src op a b))
             (setk label ($kargs names vars ,body))))
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 0adf216..a0403a1 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -5425,3 +5425,12 @@
 
   (test-ash-variant       'ash       ash floor)
   (test-ash-variant 'round-ash round-ash round))
+
+;;;
+;;; regressions
+;;;
+
+(with-test-prefix/c&e "bug in unboxing f64 in 2.1.6"
+
+  (pass-if "= real and complex"
+    (= 1.0 (make-rectangular 1.0 0.0))))