X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fctype.lisp;h=3748cf8ebf66771e4c0111e2a9a6c8863ab5f170;hb=ebf2239bc0f2e306ed98acaef232fce9c8f1d5d2;hp=6b6256533b6e58c79fd109a6451f4024b1bd688d;hpb=138d390ee26dee726f8cdfde2375ade74a4655ab;p=sbcl.git diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index 6b62565..3748cf8 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -103,82 +103,73 @@ ;;; 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))))) + (*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 @@ -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 @@ -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,48 +725,94 @@ (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 + (continuation-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-continuation-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-continuation arg-type) +(defun map-combination-args-and-types (fun call) + (declare (type function fun) (type combination call)) + (binding* ((type (continuation-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 (continuation-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-continuation-type arg type policy)) + call)) + (values)) ;;;; FIXME: Move to some other file. (defun check-catch-tag-type (tag) @@ -787,3 +824,26 @@ use EQ comparison)~@:>" (continuation-source tag) (type-specifier (continuation-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 (continuation-value atype)) + (dtype (continuation-value dtype))) + (unless (eq atype nil) + (compiler-warn + "~@" + atype dtype)))) + (ir2-convert-full-call node block)))