From: Alexey Dejneka Date: Thu, 31 Oct 2002 07:42:03 +0000 (+0000) Subject: 0.7.9.20: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=b811c391c7a0913c5047bfca3e15ec031dcb952c;p=sbcl.git 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 --- 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 --- 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 --- 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 --- 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"