master: source-transform-union-typep: eql complexes are not numeric-types

The branch "master" has been updated in SBCL:
       via  ba08d271de094d8ed823a95d4856e754bb8e6e41 (commit)
      from  14d60e26b1e9fc4b2ba63dd6d5f9a4c0e79b437e (commit)

- Log -----------------------------------------------------------------
commit ba08d271de094d8ed823a95d4856e754bb8e6e41
Author: Stas Boukarev <[email protected]>
Date:   Sat Jul 11 20:31:46 2026 +0300

    source-transform-union-typep: eql complexes are not numeric-types
    
    Fixes lp#2160429
---
 src/compiler/typetran.lisp | 50 ++++++++++++++++++++++++++++------------------
 tests/typetran.pure.lisp   | 17 ++++++++++++++++
 2 files changed, 48 insertions(+), 19 deletions(-)

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index bad27564d..53c9fa61c 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -845,25 +845,37 @@
            ;; by doing (and (not (fixnump x)) (realp x))
            (when (or (numeric-union-type-p type)
                      (find-if #'numeric-union-type-p (union-type-types type)))
-             (let ((numeric-type (if (numeric-union-type-p type)
-                                     type
-                                     (let ((numeric (remove-if-not #'numeric-union-type-p (union-type-types type))))
-                                       (when numeric
-                                         (sb-kernel::%type-union numeric))))))
-               (when numeric-type
-                 (flet ((add-missing (whole test)
-                          (when (csubtypep numeric-type whole)
-                            (let ((diff (type-difference whole numeric-type)))
-                              (when (numeric-type-p diff)
-                                `(and (not (typep ,object ',(type-specifier diff)))
-                                      (or (,test ,object)
-                                          ,@(when (union-type-p type)
-                                              (let ((left (remove-if #'numeric-union-type-p (union-type-types type))))
-                                                (and left
-                                                     `((typep ,object '(or ,@(mapcar #'type-specifier left))))))))))))))
-                   (or (add-missing (specifier-type 'real) 'realp)
-                       (add-missing (specifier-type 'number) 'numberp)
-                       (add-missing (specifier-type 'rational) 'rationalp)))))))
+             (flet ((numeric-p (type)
+                      (or (numeric-union-type-p type)
+                          ;; (eql complex) goes to a member type
+                          (csubtypep type (specifier-type 'number))
+                          (and (negation-type-p type)
+                               (csubtypep (negation-type-type type) (specifier-type 'number))))))
+               (let ((numeric-type (if (numeric-union-type-p type)
+                                       type
+                                       (let ((numeric (remove-if-not #'numeric-p (union-type-types type))))
+                                         (when numeric
+                                           (sb-kernel::%type-union numeric))))))
+                 (when (and numeric-type
+                            (not (csubtypep numeric-type (specifier-type 'integer))))
+                   (flet ((add-missing (whole test &optional lowered)
+                            (when (csubtypep numeric-type whole)
+                              (let ((diff (type-difference whole numeric-type)))
+                                (when (or (member-type-p diff)
+                                          (and (numeric-union-type-p diff)
+                                               (or (not lowered)
+                                                   (numeric-type-p diff)
+                                                   (csubtypep diff lowered))))
+                                  `(and (not (typep ,object ',(type-specifier diff)))
+                                        (or (,test ,object)
+                                            ,@(when (union-type-p type)
+                                                (let ((left (remove-if #'numeric-p (union-type-types type))))
+                                                  (and left
+                                                       `((typep ,object '(or ,@(mapcar #'type-specifier left))))))))))))))
+                     (or (add-missing (specifier-type 'real) 'realp)
+                         (add-missing (specifier-type 'number) 'numberp)
+                         (add-missing (specifier-type 'rational) 'rationalp
+                                      (specifier-type 'integer)))))))))
           ;; Turn disjoint singlegton numeric types into a single
           ;; call to MEMBER
           ((flet ((transform-numeric (type)
diff --git a/tests/typetran.pure.lisp b/tests/typetran.pure.lisp
index ae57c05ce..fa96c8f21 100644
--- a/tests/typetran.pure.lisp
+++ b/tests/typetran.pure.lisp
@@ -62,3 +62,20 @@
     ;; were delayed until the EQ as the vop would do, it would incorrectly get T as the answer.
     (assert (not (way4 x y)))
     (assert (eq (sb-kernel:layout-of x) (sb-kernel:layout-of y)))))
+
+(with-test (:name :or-complex-members)
+  (checked-compile-and-assert
+      ()
+      `(lambda (x)
+         (typep x '(and number (not (eql #C(1 2d0))))))
+    ((1) t)
+    ((#C(1 2d0)) nil)
+    ((#C(1 3d0)) t))
+  (checked-compile-and-assert
+      ()
+      `(lambda (x)
+         (typep x '(or real (complex single-float) (complex rational) (eql #C(1 2d0)))))
+    ((1) t)
+    ((#C(1 2)) t)
+    ((#C(1 3d0)) nil)
+    ((#C(1 2d0)) t)))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL