+ (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))))))
+
+(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-notify
+ :where "proclamation"))))
+\f
+;;;; FIXME: Move to some other file.
+(defun check-catch-tag-type (tag)
+ (declare (type continuation tag))
+ (let ((ctype (continuation-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)~@:>"
+ (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
+ "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
+ atype dtype))))
+ (ir2-convert-full-call node block)))