X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fctype.lisp;h=3748cf8ebf66771e4c0111e2a9a6c8863ab5f170;hb=eb6f8dd033501c7372b27967a2cb7750560897bd;hp=c6bee542d12d1718e5d774f3710a61e17d3e82d6;hpb=05525d3a5906d7a89fcb689c26177732493c40ce;p=sbcl.git diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index c6bee54..3748cf8 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -265,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 @@ -418,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)) @@ -704,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)) @@ -725,49 +725,94 @@ (find-lambda-types functional type where)))) (let* ((type-returns (fun-type-returns type)) (return (lambda-return (main-entry functional))) - (atype (when return - nil - #+nil(continuation-derived-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 (make-single-value-type 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) @@ -782,7 +827,10 @@ (defun %compile-time-type-error (values atype dtype) (declare (ignore dtype)) - (error 'values-type-error :datum values :expected-type atype)) + (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) @@ -796,6 +844,6 @@ (dtype (continuation-value dtype))) (unless (eq atype nil) (compiler-warn - "Asserted type ~S conflicts with derived type ~S." + "~@" atype dtype)))) (ir2-convert-full-call node block)))