X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=e6be6208409d1795749bb8e18690094e66286e6a;hb=34e8e7fd14989e1c86e9408733b4a73c46dd0a92;hp=a790c44a31e1c0a82a83e6329bcac1d0b4685230;hpb=a96369c72588c5457d71d6aaea35f2c450b19ef5;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index a790c44..e6be620 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -237,13 +237,19 @@
                        (multiple-value-bind (val2 win2) ,y
                          (if (and val1 val2)
                              (values t t)
-                             (values nil (or win1 win2))))))))
+                             (values nil (and win2 (not val2)))))))))
      (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))
-                 ((not (or (fun-type-simple-p type1)
-                           (fun-type-simple-p type2)))
+                 ((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))
                  (t (multiple-value-bind (min1 max1) (fun-type-nargs type1)
                       (multiple-value-bind (min2 max2) (fun-type-nargs type2)
@@ -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))
@@ -827,7 +836,7 @@
 (defun accumulate1-compound-type (type types %compound-type-p simplify2)
   (declare (type ctype type))
   (declare (type (vector ctype) types))
-  (declare (type function simplify2))
+  (declare (type function %compound-type-p simplify2))
   ;; Any input object satisfying %COMPOUND-TYPE-P should've been
   ;; broken into components before it reached us.
   (aver (not (funcall %compound-type-p type)))