From ab6263cd50869be699c7afea271d626f83a5a27d Mon Sep 17 00:00:00 2001
From: Alexey Dejneka <adejneka@comail.ru>
Date: Thu, 28 Nov 2002 04:10:20 +0000
Subject: [PATCH] 0.7.10.3:         Fix bug: (FUNCTION (&REST T)) = (FUNCTION
 *).

---
 BUGS                        |  3 +++
 package-data-list.lisp-expr |  3 ++-
 src/code/early-type.lisp    |  6 ++++++
 src/code/late-type.lisp     | 21 +++++++++++++++------
 tests/type.pure.lisp        | 11 +++++++++++
 version.lisp-expr           |  2 +-
 6 files changed, 38 insertions(+), 8 deletions(-)

diff --git a/BUGS b/BUGS
index b7b3e60b3..9da82f24a 100644
--- a/BUGS
+++ b/BUGS
@@ -1354,6 +1354,9 @@ WORKAROUND:
   but this first return value is not suitable for input to FUNCTION or
   COMPILE, as required by ANSI.
 
+229:
+  (subtypep 'function '(function)) => nil, t.
+
 DEFUNCT CATEGORIES OF BUGS
   IR1-#:
     These labels were used for bugs related to the old IR1 interpreter.
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 8da64b810..9dd7a1f3c 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1205,7 +1205,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
              "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT"
              "SINGLE-FLOAT-INT-EXPONENT"
              "SINGLE-FLOAT-SIGNIFICAND"
-             "SINGLE-VALUE-TYPE" "SPECIALIZABLE" "SPECIALIZABLE-VECTOR"
+             "SINGLE-VALUE-TYPE" "SINGLE-VALUE-SPECIFIER-TYPE"
+             "SPECIALIZABLE" "SPECIALIZABLE-VECTOR"
              "SPECIFIER-TYPE" "STACK-REF"
              "STREAMLIKE" "STRINGABLE"
              "STRUCTURE-RAW-SLOT-TYPE-AND-SIZE"
diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index e4df2ee0d..0af428157 100644
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -364,6 +364,12 @@
       (error "VALUES type illegal in this context:~%  ~S" x))
     res))
 
+(defun single-value-specifier-type (x)
+  (let ((res (specifier-type x)))
+    (if (eq res *wild-type*)
+        *universal-type*
+        res)))
+
 ;;; Similar to MACROEXPAND, but expands DEFTYPEs. We don't bother
 ;;; returning a second value.
 (defun type-expand (form)
diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index f0b2fc63b..ff52c6767 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -241,7 +241,13 @@
      (3and (values-subtypep (fun-type-returns type1)
                             (fun-type-returns type2))
            (cond ((fun-type-wild-args type2) (values t t))
-                 ((fun-type-wild-args type1) (values nil t))
+                 ((fun-type-wild-args type1)
+                  (cond ((fun-type-keyp type2) (values nil nil))
+                        ((not (fun-type-rest type2)) (values nil t))
+                        ((not (null (fun-type-required type2))) (values nil t))
+                        (t (3and (type= *universal-type* (fun-type-rest type2))
+                                 (every/type #'type= *universal-type*
+                                             (fun-type-optional type2))))))
                  ((not (and (fun-type-simple-p type1)
                             (fun-type-simple-p type2)))
                   (values nil nil))
@@ -298,9 +304,12 @@
     (declare (ignore aux)) ; since we require AUXP=NIL
     (when auxp
       (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list))
-    (setf (args-type-required result) (mapcar #'specifier-type required))
-    (setf (args-type-optional result) (mapcar #'specifier-type optional))
-    (setf (args-type-rest result) (if restp (specifier-type rest) nil))
+    (setf (args-type-required result)
+          (mapcar #'single-value-specifier-type required))
+    (setf (args-type-optional result)
+          (mapcar #'single-value-specifier-type optional))
+    (setf (args-type-rest result)
+          (if restp (single-value-specifier-type rest) nil))
     (setf (args-type-keyp result) keyp)
     (collect ((key-info))
       (dolist (key keys)
@@ -311,7 +320,7 @@
 	    (error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
 		   kwd lambda-list))
 	  (key-info (make-key-info :name kwd
-				   :type (specifier-type (second key))))))
+				   :type (single-value-specifier-type (second key))))))
       (setf (args-type-keywords result) (key-info)))
     (setf (args-type-allowp result) allowp)
     (values)))
@@ -445,7 +454,7 @@
 				       :initial-element rest2)))
 	    exact)))
 
-;;; If Type isn't a values type, then make it into one:
+;;; If TYPE isn't a values type, then make it into one:
 ;;;    <type>  ==>  (values type &rest t)
 (defun coerce-to-values (type)
   (declare (type ctype type))
diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index e5bd13bc6..a7708352c 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -167,6 +167,17 @@
 (assert (not (equal (multiple-value-list
                      (subtypep '(function ()) '(function (&rest t))))
                     '(nil t))))
+
 (assert (not (equal (multiple-value-list
                      (subtypep '(function (&rest t)) '(function ())))
                     '(t t))))
+
+(assert (subtypep '(function)
+                  '(function (&optional * &rest t))))
+(assert (equal (multiple-value-list
+                (subtypep '(function)
+                          '(function (t &rest t))))
+               '(nil t)))
+#+nil
+(assert (and (subtypep 'function '(function))
+             (subtypep '(function) 'function)))
diff --git a/version.lisp-expr b/version.lisp-expr
index 07b217866..ef3d3fd9d 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.10.2"
+"0.7.10.3"
-- 
2.11.4.GIT