X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fctype.lisp;h=64dce3b13203acb710af90bcb9b46948cadd0257;hb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;hp=6b6256533b6e58c79fd109a6451f4024b1bd688d;hpb=138d390ee26dee726f8cdfde2375ade74a4655ab;p=sbcl.git diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index 6b62565..64dce3b 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -103,95 +103,86 @@ ;;; combination node so that COMPILER-WARNING and related functions ;;; will do the right thing if they are supplied. (defun valid-fun-use (call type &key - ((:argument-test *ctype-test-fun*) #'csubtypep) - (result-test #'values-subtypep) - (strict-result nil) - ((:lossage-fun *lossage-fun*)) - ((:unwinnage-fun *unwinnage-fun*))) + ((:argument-test *ctype-test-fun*) #'csubtypep) + (result-test #'values-subtypep) + ((:lossage-fun *lossage-fun*)) + ((:unwinnage-fun *unwinnage-fun*))) (declare (type function result-test) (type combination call) - ;; FIXME: Could FUN-TYPE here actually be something like + ;; FIXME: Could TYPE here actually be something like ;; (AND GENERIC-FUNCTION (FUNCTION (T) T))? How ;; horrible... -- CSR, 2003-05-03 - (type (or fun-type classoid) type)) + (type ctype type)) (let* ((*lossage-detected* nil) (*unwinnage-detected* nil) (*compiler-error-context* call) - (args (combination-args call)) - (nargs (length args))) - (if (typep type 'classoid) - (do ((i 1 (1+ i)) - (arg args (cdr arg))) - ((null arg)) - (check-arg-type (car arg) *wild-type* i)) - (let* ((required (fun-type-required type)) - (min-args (length required)) - (optional (fun-type-optional type)) - (max-args (+ min-args (length optional))) - (rest (fun-type-rest type)) - (keyp (fun-type-keyp type))) - (cond - ((fun-type-wild-args type) - (do ((i 1 (1+ i)) - (arg args (cdr arg))) - ((null arg)) - (check-arg-type (car arg) *wild-type* i))) - ((not (or optional keyp rest)) - (if (/= nargs min-args) - (note-lossage - "The function was called with ~R argument~:P, but wants exactly ~R." - nargs min-args) - (check-fixed-and-rest args required nil))) - ((< nargs min-args) - (note-lossage - "The function was called with ~R argument~:P, but wants at least ~R." - nargs min-args)) - ((<= nargs max-args) - (check-fixed-and-rest args (append required optional) rest)) - ((not (or keyp rest)) - (note-lossage - "The function was called with ~R argument~:P, but wants at most ~R." - nargs max-args)) - ((and keyp (oddp (- nargs max-args))) - (note-lossage - "The function has an odd number of arguments in the keyword portion.")) - (t - (check-fixed-and-rest args (append required optional) rest) - (when keyp - (check-key-args args max-args type)))) - - (let* ((dtype (node-derived-type call)) - (return-type (fun-type-returns type)) - (cont (node-cont call)) - (out-type - (if (or (not (continuation-type-check cont)) - (and strict-result (policy call (/= safety 0)))) - dtype - (values-type-intersection (continuation-asserted-type cont) - dtype)))) - (multiple-value-bind (int win) (funcall result-test out-type return-type) - (cond ((not win) - (note-unwinnage "can't tell whether the result is a ~S" - (type-specifier return-type))) - ((not int) - (note-lossage "The result is a ~S, not a ~S." - (type-specifier out-type) - (type-specifier return-type)))))))) + (args (combination-args call))) + (if (fun-type-p type) + (let* ((nargs (length args)) + (required (fun-type-required type)) + (min-args (length required)) + (optional (fun-type-optional type)) + (max-args (+ min-args (length optional))) + (rest (fun-type-rest type)) + (keyp (fun-type-keyp type))) + (cond + ((fun-type-wild-args type) + (loop for arg in args + and i from 1 + do (check-arg-type arg *universal-type* i))) + ((not (or optional keyp rest)) + (if (/= nargs min-args) + (note-lossage + "The function was called with ~R argument~:P, but wants exactly ~R." + nargs min-args) + (check-fixed-and-rest args required nil))) + ((< nargs min-args) + (note-lossage + "The function was called with ~R argument~:P, but wants at least ~R." + nargs min-args)) + ((<= nargs max-args) + (check-fixed-and-rest args (append required optional) rest)) + ((not (or keyp rest)) + (note-lossage + "The function was called with ~R argument~:P, but wants at most ~R." + nargs max-args)) + ((and keyp (oddp (- nargs max-args))) + (note-lossage + "The function has an odd number of arguments in the keyword portion.")) + (t + (check-fixed-and-rest args (append required optional) rest) + (when keyp + (check-key-args args max-args type)))) + + (let* ((dtype (node-derived-type call)) + (return-type (fun-type-returns type)) + (out-type dtype)) + (multiple-value-bind (int win) (funcall result-test out-type return-type) + (cond ((not win) + (note-unwinnage "can't tell whether the result is a ~S" + (type-specifier return-type))) + ((not int) + (note-lossage "The result is a ~S, not a ~S." + (type-specifier out-type) + (type-specifier return-type))))))) + (loop for arg in args + and i from 1 + do (check-arg-type arg *wild-type* i))) (cond (*lossage-detected* (values nil t)) - (*unwinnage-detected* (values nil nil)) - (t (values t t))))) - -;;; Check that the derived type of the continuation CONT is compatible -;;; with TYPE. N is the arg number, for error message purposes. We -;;; return true if arg is definitely o.k. If the type is a magic -;;; CONSTANT-TYPE, then we check for the argument being a constant -;;; value of the specified type. If there is a manifest type error -;;; (DERIVED-TYPE = NIL), then we flame about the asserted type even -;;; when our type is satisfied under the test. -(defun check-arg-type (cont type n) - (declare (type continuation cont) (type ctype type) (type index n)) + (*unwinnage-detected* (values nil nil)) + (t (values t t))))) + +;;; Check that the derived type of the LVAR is compatible with TYPE. N +;;; is the arg number, for error message purposes. We return true if +;;; arg is definitely o.k. If the type is a magic CONSTANT-TYPE, then +;;; we check for the argument being a constant value of the specified +;;; type. If there is a manifest type error (DERIVED-TYPE = NIL), then +;;; we flame about the asserted type even when our type is satisfied +;;; under the test. +(defun check-arg-type (lvar type n) + (declare (type lvar lvar) (type ctype type) (type index n)) (cond ((not (constant-type-p type)) - (let ((ctype (continuation-type cont))) + (let ((ctype (lvar-type lvar))) (multiple-value-bind (int win) (funcall *ctype-test-fun* ctype type) (cond ((not win) (note-unwinnage "can't tell whether the ~:R argument is a ~S" @@ -205,11 +196,11 @@ (note-unwinnage "The ~:R argument never returns a value." n) nil) (t t))))) - ((not (constant-continuation-p cont)) + ((not (constant-lvar-p lvar)) (note-unwinnage "The ~:R argument is not a constant." n) nil) (t - (let ((val (continuation-value cont)) + (let ((val (lvar-value lvar)) (type (constant-type-type type))) (multiple-value-bind (res win) (ctypep val type) (cond ((not win) @@ -253,12 +244,12 @@ (let ((k (car key))) (cond ((not (check-arg-type k (specifier-type 'symbol) n))) - ((not (constant-continuation-p k)) + ((not (constant-lvar-p k)) (note-unwinnage "The ~:R argument (in keyword position) is not a ~ constant." n)) (t - (let* ((name (continuation-value k)) + (let* ((name (lvar-value k)) (info (find name (fun-type-keywords type) :key #'key-info-name))) (cond ((not info) @@ -274,7 +265,7 @@ ;;; ;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct ;;; the &REST type. -(declaim (ftype (function (functional) fun-type) definition-type)) +(declaim (ftype (sfunction (functional) fun-type) definition-type)) (defun definition-type (functional) (if (lambda-p functional) (make-fun-type @@ -363,8 +354,8 @@ (args (combination-args call)) (nargs (length args)) (allowp (some (lambda (x) - (and (constant-continuation-p x) - (eq (continuation-value x) :allow-other-keys))) + (and (constant-lvar-p x) + (eq (lvar-value x) :allow-other-keys))) args))) (setf (approximate-fun-type-min-args type) @@ -378,10 +369,10 @@ (setf (approximate-fun-type-types type) (nconc types (mapcar (lambda (x) - (list (continuation-type x))) + (list (lvar-type x))) arg)))) (when (null arg) (return)) - (pushnew (continuation-type (car arg)) + (pushnew (lvar-type (car arg)) (car old) :test #'type=)) @@ -392,8 +383,8 @@ (setf (approximate-fun-type-keys type) (keys))) (let ((key (first arg)) (val (second arg))) - (when (constant-continuation-p key) - (let ((name (continuation-value key))) + (when (constant-lvar-p key) + (let ((name (lvar-value key))) (when (keywordp name) (let ((old (find-if (lambda (x) @@ -401,7 +392,7 @@ (= (approximate-key-info-position x) pos))) (keys))) - (val-type (continuation-type val))) + (val-type (lvar-type val))) (cond (old (pushnew val-type (approximate-key-info-types old) @@ -416,7 +407,7 @@ :types (list val-type)))))))))))) type)) -;;; This is similar to VALID-FUNCTION-USE, but checks an +;;; This is similar to VALID-FUN-USE, but checks an ;;; APPROXIMATE-FUN-TYPE against a real function type. (declaim (ftype (function (approximate-fun-type fun-type &optional function function function) @@ -427,7 +418,7 @@ #'types-equal-or-intersect) (*lossage-fun* #'compiler-style-warn) - (*unwinnage-fun* #'compiler-note)) + (*unwinnage-fun* #'compiler-notify)) (let* ((*lossage-detected* nil) (*unwinnage-detected* nil) (required (fun-type-required type)) @@ -565,7 +556,7 @@ vars types) (values vars (res)))) -;;; Check that the optional-dispatch OD conforms to Type. We return +;;; Check that the optional-dispatch OD conforms to TYPE. We return ;;; the values of TRY-TYPE-INTERSECTIONS if there are no syntax ;;; problems, otherwise NIL, NIL. ;;; @@ -713,11 +704,11 @@ ;;; If there is no problem, we return T (even if REALLY-ASSERT was ;;; false). If there was a problem, we return NIL. (defun assert-definition-type - (functional type &key (really-assert t) - ((:lossage-fun *lossage-fun*) - #'compiler-style-warn) - unwinnage-fun - (where "previous declaration")) + (functional type &key (really-assert t) + ((:lossage-fun *lossage-fun*) + #'compiler-style-warn) + unwinnage-fun + (where "previous declaration")) (declare (type functional functional) (type function *lossage-fun*) (string where)) @@ -734,56 +725,125 @@ (find-lambda-types functional type where)))) (let* ((type-returns (fun-type-returns type)) (return (lambda-return (main-entry functional))) - (atype (when return - (continuation-asserted-type (return-result return))))) + (dtype (when return + (lvar-derived-type (return-result return))))) (cond - ((and atype (not (values-types-equal-or-intersect atype - type-returns))) - (note-lossage - "The result type from ~A:~% ~S~@ - conflicts with the definition's result type assertion:~% ~S" - where (type-specifier type-returns) (type-specifier atype)) - nil) - (*lossage-detected* nil) - ((not really-assert) t) - (t - (when atype - (assert-continuation-type (return-result return) atype - (lexenv-policy (functional-lexenv functional)))) - (loop for var in vars and type in types do - (cond ((basic-var-sets var) - (when (and unwinnage-fun - (not (csubtypep (leaf-type var) type))) - (funcall unwinnage-fun - "Assignment to argument: ~S~% ~ + ((and dtype (not (values-types-equal-or-intersect dtype + type-returns))) + (note-lossage + "The result type from ~A:~% ~S~@ + conflicts with the definition's result type:~% ~S" + where (type-specifier type-returns) (type-specifier dtype)) + nil) + (*lossage-detected* nil) + ((not really-assert) t) + (t + (let ((policy (lexenv-policy (functional-lexenv functional)))) + (when (policy policy (> type-check 0)) + (assert-lvar-type (return-result return) type-returns + policy))) + (loop for var in vars and type in types do + (cond ((basic-var-sets var) + (when (and unwinnage-fun + (not (csubtypep (leaf-type var) type))) + (funcall unwinnage-fun + "Assignment to argument: ~S~% ~ prevents use of assertion from function ~ type ~A:~% ~S~%" - (leaf-debug-name var) - where - (type-specifier type)))) - (t - (setf (leaf-type var) type) - (dolist (ref (leaf-refs var)) - (derive-node-type ref type))))) - t)))))) - + (leaf-debug-name var) + where + (type-specifier type)))) + (t + (setf (leaf-type var) type) + (dolist (ref (leaf-refs var)) + (derive-node-type ref (make-single-value-type type)))))) + t)))))) + +;;; FIXME: This is quite similar to ASSERT-NEW-DEFINITION. (defun assert-global-function-definition-type (name fun) (declare (type functional fun)) (let ((type (info :function :type name)) (where (info :function :where-from name))) (when (eq where :declared) (setf (leaf-type fun) type) - (assert-definition-type fun type - :unwinnage-fun #'compiler-note - :where "proclamation")))) + (assert-definition-type + fun type + :unwinnage-fun #'compiler-notify + :where "proclamation" + :really-assert (not (awhen (info :function :info name) + (ir1-attributep (fun-info-attributes it) + explicit-check))))))) + +;;; Call FUN with (arg-lvar arg-type) +(defun map-combination-args-and-types (fun call) + (declare (type function fun) (type combination call)) + (binding* ((type (lvar-type (combination-fun call))) + (nil (fun-type-p type) :exit-if-null) + (args (combination-args call))) + (dolist (req (fun-type-required type)) + (when (null args) (return-from map-combination-args-and-types)) + (let ((arg (pop args))) + (funcall fun arg req))) + (dolist (opt (fun-type-optional type)) + (when (null args) (return-from map-combination-args-and-types)) + (let ((arg (pop args))) + (funcall fun arg opt))) + + (let ((rest (fun-type-rest type))) + (when rest + (dolist (arg args) + (funcall fun arg rest)))) + + (dolist (key (fun-type-keywords type)) + (let ((name (key-info-name key))) + (do ((arg args (cddr arg))) + ((null arg)) + (when (eq (lvar-value (first arg)) name) + (funcall fun (second arg) (key-info-type key)))))))) + +;;; Assert that CALL is to a function of the specified TYPE. It is +;;; assumed that the call is legal and has only constants in the +;;; keyword positions. +(defun assert-call-type (call type) + (declare (type combination call) (type fun-type type)) + (derive-node-type call (fun-type-returns type)) + (let ((policy (lexenv-policy (node-lexenv call)))) + (map-combination-args-and-types + (lambda (arg type) + (assert-lvar-type arg type policy)) + call)) + (values)) ;;;; FIXME: Move to some other file. (defun check-catch-tag-type (tag) - (declare (type continuation tag)) - (let ((ctype (continuation-type tag))) + (declare (type lvar tag)) + (let ((ctype (lvar-type tag))) (when (csubtypep ctype (specifier-type '(or number character))) (compiler-style-warn "~@" - (continuation-source tag) - (type-specifier (continuation-type tag)))))) + (lvar-source tag) + (type-specifier (lvar-type tag)))))) + +(defun %compile-time-type-error (values atype dtype) + (declare (ignore dtype)) + (if (and (consp atype) + (eq (car atype) 'values)) + (error 'values-type-error :datum values :expected-type atype) + (error 'type-error :datum (car values) :expected-type atype))) + +(defoptimizer (%compile-time-type-error ir2-convert) + ((objects atype dtype) node block) + (let ((*compiler-error-context* node)) + (setf (node-source-path node) + (cdr (node-source-path node))) + (destructuring-bind (values atype dtype) + (basic-combination-args node) + (declare (ignore values)) + (let ((atype (lvar-value atype)) + (dtype (lvar-value dtype))) + (unless (eq atype nil) + (compiler-warn + "~@" + atype dtype)))) + (ir2-convert-full-call node block)))