+ (return (lambda-return (main-entry functional)))
+ (dtype (when return
+ (lvar-derived-type (return-result return)))))
+ (cond
+ ((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)
+ (let ((s-type (make-single-value-type type)))
+ (dolist (ref (leaf-refs var))
+ (derive-node-type ref s-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)
+ (let ((type (massage-global-definition-type type fun)))
+ (setf (leaf-type fun) type)
+ (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))))))))
+
+;;; If the function has both &REST and &KEY, FIND-OPTIONAL-DISPATCH-TYPES
+;;; doesn't complain about the type missing &REST -- which is good, because in
+;;; that case &REST is really an implementation detail and not part of the
+;;; interface. However since we set the leaf type missing &REST from there
+;;; would be a bad thing -- to make up a new type if necessary.
+(defun massage-global-definition-type (type fun)
+ (if (and (fun-type-p type)
+ (optional-dispatch-p fun)
+ (optional-dispatch-keyp fun)
+ (optional-dispatch-more-entry fun)
+ (not (or (fun-type-rest type)
+ (fun-type-wild-args type))))
+ (make-fun-type :required (fun-type-required type)
+ :optional (fun-type-optional type)
+ :rest *universal-type*
+ :keyp (fun-type-keyp type)
+ :keywords (fun-type-keywords type)
+ :allowp (fun-type-allowp type)
+ :returns (fun-type-returns type))
+ type))
+\f
+;;; 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 &optional (trusted t))
+ (declare (type combination call) (type fun-type type))
+ (let ((policy (lexenv-policy (node-lexenv call)))
+ (returns (fun-type-returns type)))
+ (if trusted
+ (derive-node-type call returns)
+ (let ((lvar (node-lvar call)))
+ ;; If the value is used in a non-tail position, and the lvar
+ ;; is a single-use, assert the type. Multiple use sites need
+ ;; to be elided because the assertion has to apply to all
+ ;; uses. Tail positions are elided because the assertion
+ ;; would cause us not the be in a tail-position anymore. MV
+ ;; calls are elided because not only are the assertions of
+ ;; less use there, but they can cause the MV call conversion
+ ;; to cause astray.
+ (when (and lvar
+ (not (return-p (lvar-dest lvar)))
+ (not (mv-combination-p (lvar-dest lvar)))
+ (lvar-has-single-use-p lvar))
+ (when (assert-lvar-type lvar returns policy)
+ (reoptimize-lvar lvar)))))
+ (map-combination-args-and-types
+ (lambda (arg type)
+ (when (assert-lvar-type arg type policy)
+ (unless trusted (reoptimize-lvar arg))))
+ call))
+ (values))
+\f
+;;;; FIXME: Move to some other file.
+(defun check-catch-tag-type (tag)
+ (declare (type lvar tag))
+ (let ((ctype (lvar-type tag)))
+ (when (csubtypep ctype (specifier-type '(or number character)))
+ (compiler-style-warn "~@<using ~S of type ~S as a catch tag (which ~
+ tends to be unportable because THROW and CATCH ~
+ use EQ comparison)~@:>"
+ (lvar-source tag)
+ (type-specifier (lvar-type tag))))))
+
+(defun %compile-time-type-error (values atype dtype context)
+ (declare (ignore dtype))
+ (destructuring-bind (form . detail) context
+ (if (and (consp atype) (eq (car atype) 'values))
+ (error 'simple-type-error
+ :datum (car values)
+ :expected-type atype
+ :format-control
+ "~@<Value set ~2I~_[~{~S~^ ~}] ~I~_from ~S in ~2I~_~S ~I~_is ~
+ not of type ~2I~_~S.~:>"
+ :format-arguments (list values
+ detail form
+ atype))
+ (error 'simple-type-error
+ :datum (car values)
+ :expected-type atype
+ :format-control "~@<Value of ~S in ~2I~_~S ~I~_is ~2I~_~S, ~
+ ~I~_not a ~2I~_~S.~:@>"
+ :format-arguments (list detail form
+ (car values)
+ atype)))))
+
+(defoptimizer (%compile-time-type-error ir2-convert)
+ ((objects atype dtype context) node block)
+ (let ((*compiler-error-context* node))
+ (setf (node-source-path node)
+ (cdr (node-source-path node)))
+ (destructuring-bind (values atype dtype context)
+ (basic-combination-args node)
+ (declare (ignore values))
+ (let ((atype (lvar-value atype))
+ (dtype (lvar-value dtype))
+ (detail (cdr (lvar-value context))))
+ (unless (eq atype nil)
+ (if (constantp detail)
+ (warn 'type-warning
+ :format-control
+ "~@<Constant ~2I~_~S ~Iconflicts with its asserted type ~
+ ~2I~_~S.~@:>"
+ :format-arguments (list (eval detail) atype))
+ (warn 'type-warning
+ :format-control
+ "~@<Derived type of ~S is ~2I~_~S, ~I~_conflicting with ~
+ its asserted type ~2I~_~S.~@:>"
+ :format-arguments (list detail dtype atype))))))
+ (ir2-convert-full-call node block)))