0.7.9.20:

        * fixed SUBTYPEP on FUNCTION types: (int int -> *) < (int [int] -> *).
        * removed check for 'list of length >= 0' from parsing of
          macro lambda lists

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index f3f7f0d..46b983f 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -213,46 +213,52 @@
            (type-specifier
             (fun-type-returns type)))))
 
-(!define-type-method (function :simple-subtypep) (type1 type2)
-   (flet ((fun-type-simple-p (type)
-            (not (or (fun-type-rest type)
-                     (fun-type-keyp type))))
-          (every-csubtypep (types1 types2)
-            (loop
-               for a1 in types1
-               for a2 in types2
-               do (multiple-value-bind (res sure-p)
-                      (csubtypep a1 a2)
-                    (unless res (return (values res sure-p))))
-               finally (return (values t t)))))
-     (macrolet ((3and (x y)
-                  `(multiple-value-bind (val1 win1)
-                       ,x
-                     (if (and (not val1) win1)
-                         (values nil t)
-                         (multiple-value-bind (val2 win2)
-                             ,y
-                           (if (and val1 val2)
-                               (values t t)
-                               (values nil (or win1 win2))))))))
-       (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)))
-                    (values nil nil))
-                   ((not (and (= (length (fun-type-required type1))
-                                 (length (fun-type-required type2)))
-                              (= (length (fun-type-optional type1))
-                                 (length (fun-type-optional type2)))))
-                    (values nil t))
-                   (t (3and (every-csubtypep (fun-type-required type1)
-                                             (fun-type-required type2))
-                            (every-csubtypep (fun-type-optional type1)
-                                             (fun-type-optional type2)))))))))
+;;; Since all function types are equivalent to FUNCTION, they are all
+;;; subtypes of each other.
+(!define-type-method
+ (function :simple-subtypep) (type1 type2)
+ (flet ((fun-type-simple-p (type)
+          (not (or (fun-type-rest type)
+                   (fun-type-keyp type))))
+        (every-csubtypep (types1 types2)
+          (loop
+             for a1 in types1
+             for a2 in types2
+             do (multiple-value-bind (res sure-p)
+                    (csubtypep a1 a2)
+                  (unless res (return (values res sure-p))))
+             finally (return (values t t)))))
+   (macrolet ((3and (x y)
+                `(multiple-value-bind (val1 win1) ,x
+                   (if (and (not val1) win1)
+                       (values nil t)
+                       (multiple-value-bind (val2 win2) ,y
+                         (if (and val1 val2)
+                             (values t t)
+                             (values nil (or win1 win2))))))))
+     (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)))
+                  (values nil nil))
+                 (t (multiple-value-bind (min1 max1) (fun-type-nargs type1)
+                      (multiple-value-bind (min2 max2) (fun-type-nargs type2)
+                        (cond ((or (> max1 max2) (< min1 min2))
+                               (values nil t))
+                              ((and (= min1 min2) (= max1 max2))
+                               (3and (every-csubtypep (fun-type-required type1)
+                                                      (fun-type-required type2))
+                                     (every-csubtypep (fun-type-optional type1)
+                                                      (fun-type-optional type2))))
+                              (t (every-csubtypep
+                                  (concatenate 'list
+                                               (fun-type-required type1)
+                                               (fun-type-optional type1))
+                                  (concatenate 'list
+                                               (fun-type-required type2)
+                                               (fun-type-optional type2)))))))))))))
 
 (!define-superclasses function ((function)) !cold-init-forms)
 

diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp
index 378d0ec..4ef5bd4 100644 (file)
--- a/src/code/parse-defmacro.lisp
+++ b/src/code/parse-defmacro.lisp
@@ -204,24 +204,25 @@
          ;; there actually is a maximum number of arguments
          ;; (expecting MAXIMUM=NIL when there is no maximum)
          (explicit-maximum (and (not restp) maximum)))
-      (push `(unless ,(if restp
-                         ;; (If RESTP, then the argument list might be
-                         ;; dotted, in which case ordinary LENGTH won't
-                         ;; work.)
-                         `(list-of-length-at-least-p ,path-0 ,minimum)
-                         `(proper-list-of-length-p ,path-0 ,minimum ,maximum))
-              ,(if (eq error-fun 'error)
-                   `(arg-count-error ',error-kind ',name ,path-0
-                                     ',lambda-list ,minimum
-                                     ,explicit-maximum)
-                   `(,error-fun 'arg-count-error
-                                :kind ',error-kind
-                                ,@(when name `(:name ',name))
-                                :args ,path-0
-                                :lambda-list ',lambda-list
-                                :minimum ,minimum
-                                :maximum ,explicit-maximum)))
-           *arg-tests*)
+      (unless (and restp (zerop minimum))
+        (push `(unless ,(if restp
+                            ;; (If RESTP, then the argument list might be
+                            ;; dotted, in which case ordinary LENGTH won't
+                            ;; work.)
+                            `(list-of-length-at-least-p ,path-0 ,minimum)
+                            `(proper-list-of-length-p ,path-0 ,minimum ,maximum))
+                 ,(if (eq error-fun 'error)
+                      `(arg-count-error ',error-kind ',name ,path-0
+                                        ',lambda-list ,minimum
+                                        ,explicit-maximum)
+                      `(,error-fun 'arg-count-error
+                                   :kind ',error-kind
+                                   ,@(when name `(:name ',name))
+                                   :args ,path-0
+                                   :lambda-list ',lambda-list
+                                   :minimum ,minimum
+                                   :maximum ,explicit-maximum)))
+              *arg-tests*))
       (when keys
        (let ((problem (gensym "KEY-PROBLEM-"))
              (info (gensym "INFO-")))

diff --git a/tests/compiler-1.impure-cload.lisp b/tests/compiler-1.impure-cload.lisp
index a873e69..5034636 100644 (file)
--- a/tests/compiler-1.impure-cload.lisp
+++ b/tests/compiler-1.impure-cload.lisp
@@ -115,5 +115,11 @@
                  nil)
                '(13 nil)))
 
+;;; bug 221: sbcl 0.7.9.13 failed to compile the following function
+(declaim (ftype (function (fixnum) (values package boolean)) bug221-f1))
+(declaim (ftype (function (t) (values package boolean)) bug221-f2))
+(defun bug221 (b x)
+  (funcall (if b #'bug221-f1 #'bug221-f2) x))
+
 (sb-ext:quit :unix-status 104) ; success
 

diff --git a/version.lisp-expr b/version.lisp-expr
index 5d32582..02450cc 100644 (file)
--- 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.9.19"
+"0.7.9.20"