Improve numeric-contagion for float number pairs. Fixes https://bugs.…

…launchpad.net/sbcl/+bug/1914094
ajberkley · Feb 13, 2021 · 5464c17 · 5464c17
1 parent 3a4d43d
commit 5464c17
Show file tree

Hide file tree

Showing 2 changed files with 37 additions and 25 deletions.
diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
@@ -381,7 +381,7 @@
         (if (bounds-unbounded-p low high)
             (if (eq complexp :complex)
                 (specifier-type '(complex float))
-                (specifier-type 'real))
+                (specifier-type 'float))
             (unionize (single-float double-float #+long-float (error "long-float"))
                       (float float)
                       (single-float double-float))))))

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
@@ -2563,6 +2563,26 @@ used for a COMPLEX component.~:@>"
       (when (or (eq f f1) (eq f f2))
         (return f)))))
 
+;; Return proper float format for two arg numeric contagion between
+;; a float with format1 and second number with class2 and format2
+(defun float-format-two-arg (format1 class2 format2)
+  (ecase class2
+    (float (float-format-max format1 format2))
+    ((integer rational) format1)
+    ((nil)
+     ;; A double-float with any real number is a
+     ;; double-float.
+     #-long-float
+     (if (eq format1 'double-float)
+         'double-float
+         nil)
+     ;; A long-float with any real number is a
+     ;; long-float.
+     #+long-float
+     (if (eq format1 'long-float)
+         'long-float
+         nil))))
+
 ;;; Return the result of an operation on TYPE1 and TYPE2 according to
 ;;; the rules of numeric contagion. This is always NUMBER, some float
 ;;; format (possibly complex) or RATIONAL. Due to rational
@@ -2580,32 +2600,24 @@ used for a COMPLEX component.~:@>"
             (format2 (numeric-type-format type2))
             (complexp1 (numeric-type-complexp type1))
             (complexp2 (numeric-type-complexp type2)))
-        (cond ((or (null complexp1)
-                   (null complexp2))
-               (specifier-type 'number))
-              ((eq class1 'float)
+        (cond ((and (eq class1 'float) (not (null complexp1)) (not (null complexp2)))
                (make-numeric-type
                 :class 'float
-                :format (ecase class2
-                          (float (float-format-max format1 format2))
-                          ((integer rational) format1)
-                          ((nil)
-                           ;; A double-float with any real number is a
-                           ;; double-float.
-                           #-long-float
-                           (if (eq format1 'double-float)
-                             'double-float
-                             nil)
-                           ;; A long-float with any real number is a
-                           ;; long-float.
-                           #+long-float
-                           (if (eq format1 'long-float)
-                             'long-float
-                             nil)))
-                :complexp (if (or (eq complexp1 :complex)
-                                  (eq complexp2 :complex))
-                              :complex
-                              :real)))
+                :format (float-format-two-arg format1 class2 format2)
+                :complexp (if (and (eq complexp1 :real)
+                                   (eq complexp2 :real))
+                              :real
+                              :complex)))
+              ((and (eq class1 'float) (or (null complexp1) (null complexp2)))
+               (type-union ;; creating a numeric with :complexp nil makes some type derivers angry
+                (make-numeric-type
+                 :class 'float
+                 :format (float-format-two-arg format1 class2 format2)
+                 :complexp :complex)
+                (make-numeric-type
+                 :class 'float
+                 :format (float-format-two-arg format1 class2 format2)
+                 :complexp :real)))
               ((eq class2 'float) (numeric-contagion type2 type1))
               ((and (eq complexp1 :real) (eq complexp2 :real))
                (make-numeric-type