From 3f03a0c686137b9ca3c4216d72fcce25ee241340 Mon Sep 17 00:00:00 2001
From: Marius Gerbershagen <marius.gerbershagen@gmail.com>
Date: Wed, 23 Aug 2023 20:39:03 +0200
Subject: [PATCH] cmp: fix caching of type specifiers

We cannot compare with (equal) here because subtype relations can
differ for member and eql types even if the type specifiers are the
same under equal.
---
 src/cmp/cmptype-arith.lsp | 12 ++++++------
 src/cmp/cmputil.lsp       | 23 +++++++++++++++++++----
 2 files changed, 25 insertions(+), 10 deletions(-)

diff --git a/src/cmp/cmptype-arith.lsp b/src/cmp/cmptype-arith.lsp
index 9e337f308..45d000868 100644
--- a/src/cmp/cmptype-arith.lsp
+++ b/src/cmp/cmptype-arith.lsp
@@ -79,7 +79,7 @@
 (defun trivial-type-p (type)
   (subtypep T type))
 
-(defun-equal-cached type-and (t1 t2)
+(defun-cached type-and (t1 t2) type-specifier=
   ;; FIXME! Should we allow "*" as type name???
   (when (or (eq t1 t2) (eq t2 '*))
     (return-from type-and t1))
@@ -128,7 +128,7 @@
          (let ((l (1- (length type))))
            (values l l)))))
 
-(defun-equal-cached values-type-primary-type (type)
+(defun-cached values-type-primary-type (type) type-specifier=
   ;; Extract the type of the first value returned by this form. We are
   ;; pragmatic and thus (VALUES) => NULL  [CHECKME!]
   (let (aux)
@@ -144,7 +144,7 @@
           (t
            aux))))
 
-(defun-equal-cached values-type-to-n-types (type length)
+(defun-cached values-type-to-n-types (type length) type-specifier=
   (when (plusp length)
     (do-values-type-to-n-types type length)))
 
@@ -195,7 +195,7 @@
           (return (values (nreverse required) (nreverse optional)
                           rest a-o-k)))))
 
-(defun-equal-cached values-type-or (t1 t2)
+(defun-cached values-type-or (t1 t2) type-specifier=
   (when (or (eq t2 'T) (equalp t2 '(VALUES &REST T)))
     (return-from values-type-or t2))
   (when (or (eq t1 'T) (equalp t1 '(VALUES &REST T)))
@@ -241,7 +241,7 @@
                  ,@(and opt (cons '&optional (nreverse opt)))
                  ,@(and rest (cons '&optional rest)))))))
 
-(defun-equal-cached values-type-and (t1 t2)
+(defun-cached values-type-and (t1 t2) type-specifier=
   (when (or (eq t2 'T) (equalp t2 '(VALUES &REST T)))
     (return-from values-type-and t1))
   (when (or (eq t1 'T) (equalp t1 '(VALUES &REST T)))
@@ -277,7 +277,7 @@
                  ,@(and opt (cons '&optional (nreverse opt)))
                  ,@(and rest (cons '&optional rest)))))))
 
-(defun-equal-cached type-or (t1 t2)
+(defun-cached type-or (t1 t2) type-specifier=
   ;; FIXME! Should we allow "*" as type name???
   (when (or (eq t1 t2) (eq t2 '*))
     (return-from type-or t1))
diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp
index c65412987..77c127f42 100644
--- a/src/cmp/cmputil.lsp
+++ b/src/cmp/cmputil.lsp
@@ -436,6 +436,24 @@ comparing circular objects."
                          (equal-recursive (cdr x) (cdr y) x0 y0 t (ash path-spec 1) (the fixnum (1+ n))))))))
     (equal-recursive x y nil nil t 0 -1)))
 
+(defun type-specifier= (x y)
+  "Compares two type specifiers for syntactic equality."
+  ;; This function only checks if the arguments have the same name
+  ;; (and arguments in case of compound type specifiers) but not if
+  ;; they are aliases of each other. For example (OR REAL COMPLEX) and
+  ;; NUMBER are considered different by this function but are of
+  ;; course semantically equivalent.
+  ;;
+  ;; Note that type specifiers cannot be compared with EQUAL since in
+  ;; eql and member types the arguments have to compared using EQL.
+  (if (and (consp x) (consp y))
+      (if (and (member (first x) '(eql member))
+               (member (first y) '(eql member)))
+          (every #'eql x y)
+          (and (type-specifier= (car x) (car y))
+               (type-specifier= (cdr x) (cdr y))))
+      (eql x y)))
+
 ;; ----------------------------------------------------------------------
 ;; CACHED FUNCTIONS
 ;;
@@ -447,7 +465,7 @@ comparing circular objects."
          (hash-function (case test
                           (EQ 'SI::HASH-EQ)
                           (EQL 'SI::HASH-EQL)
-                          ((EQUAL EQUAL-WITH-CIRCULARITY) 'SI::HASH-EQUAL)
+                          ((EQUAL EQUAL-WITH-CIRCULARITY TYPE-SPECIFIER=) 'SI::HASH-EQUAL)
                           (t (setf test 'EQUALP) 'SI::HASH-EQUALP))))
     `(progn
        (defvar ,cache-name
@@ -469,8 +487,5 @@ comparing circular objects."
                    (setf (aref ,cache-name hash) (list ,@lambda-list output))
                    output))))))))
 
-(defmacro defun-equal-cached (name lambda-list &body body)
-  `(defun-cached ,name ,lambda-list equal-with-circularity ,@body))
-
 (defun same-fname-p (name1 name2)
   (equal name1 name2))