From d7c351c76a047c757a29462bbd35e5aab60227d8 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Fri, 19 Apr 2019 22:03:07 +0200
Subject: [PATCH] predlib: type= doesn't yield T for complex types

TYPE= is only used from cmpopt's typep compiler macro which optimizes
atomic complex types by other means. Compound complex types are
handled differently for subtypep and typep (the first relies on
upgraded type and the second relies on the actual types), so we can't
rely in this case on SAFE-CANONICAL-TYPE.
---
 src/cmp/cmpopt.lsp  | 12 +++++++++---
 src/lsp/predlib.lsp | 19 ++++++++++++++-----
 2 files changed, 23 insertions(+), 8 deletions(-)

diff --git a/src/cmp/cmpopt.lsp b/src/cmp/cmpopt.lsp
index fa904ae90..62fc55902 100644
--- a/src/cmp/cmpopt.lsp
+++ b/src/cmp/cmpopt.lsp
@@ -79,7 +79,7 @@
               when (si::type= type a-type)
               do (return `(,function-name ,object))))
           ;;
-          ;; Complex types defined with DEFTYPE.
+          ;; Derived types defined with DEFTYPE.
           ((and (atom type)
                 (setq function (si:get-sysprop type 'SI::DEFTYPE-DEFINITION)))
            (expand-typep form object `',(funcall function nil) env))
@@ -90,7 +90,7 @@
           ;;
           ;; CONS types. They must be checked _before_ sequence types. We
           ;; do not produce optimized forms because they can be recursive.
-          ((and (consp type) (eq first 'CONS))
+          ((and (consp type) (eq (first type) 'CONS))
            form)
           ;;
           ;; The type denotes a known class and we can check it
@@ -141,13 +141,19 @@
                        (setf ,var2 (truly-the ,first ,var1))
                        (AND ,@(expand-in-interval-p var2 rest)))))))
           ;;
+          ;; Compound COMPLEX types.
+          ((and (eq first 'COMPLEX)
+                (= (list-length type) 2))
+           `(and (typep (realpart ,object) ',(second type))
+                 (typep (imagpart ,object) ',(second type))))
+          ;;
           ;; (SATISFIES predicate)
           ((and (eq first 'SATISFIES)
                 (= (list-length type) 2)
                 (symbolp (setf function (second type))))
            `(,function ,object))
           ;;
-          ;; Complex types with arguments.
+          ;; Derived compound types.
           ((setf function (si:get-sysprop first 'SI::DEFTYPE-DEFINITION))
            (expand-typep form object `',(funcall function rest) env))
           (t
diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp
index 13be58759..91d3423e3 100644
--- a/src/lsp/predlib.lsp
+++ b/src/lsp/predlib.lsp
@@ -568,9 +568,10 @@ Returns T if X belongs to TYPE; NIL otherwise."
     (COMPLEX
      (and (complexp object)
           (or (null i)
+              ;; type specifier may be i.e (complex integer) so we
+              ;; should check both real and imag part (disregarding
+              ;; the fact that both have the same upgraded type).
               (and (typep (realpart object) (car i))
-                   ;;wfs--should only have to check one.
-                   ;;Illegal to mix real and imaginary types!
                    (typep (imagpart object) (car i))))
            ))
     (SEQUENCE (or (listp object) (vectorp object)))
@@ -1514,9 +1515,17 @@ if not possible."
   (declare (si::c-local))
   (when (eq t1 t2)
     (return-from fast-type= (values t t)))
-  (let* ((tag1 (safe-canonical-type t1))
-         (tag2 (safe-canonical-type t2)))
-    (cond ((and (numberp tag1) (numberp tag2))
+  (let ((tag1 (safe-canonical-type t1))
+        (tag2 (safe-canonical-type t2))
+        (tag3 (safe-canonical-type 'complex)))
+    ;; FAST-TYPE= can't rely on the CANONICAL-TYPE in case of complex
+    ;; numbers which have an exceptional behavior define for TYPEP not
+    ;; being consistent with SUBTYPEP. -- jd 2019-04-19
+    (cond ((and (numberp tag1)
+                (numberp tag2)
+                (/= tag2 tag3))
+           ;; We must call safe-canonical-type again because one of
+           ;; the calls above could have called UPDATE-TYPES.
            (values (= (safe-canonical-type t1) (safe-canonical-type t2))
                    t))
           #+nil