;;;
;;; 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
#'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))
;;; 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))
(dtype (when return
(continuation-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~@
+ ((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
- (assert-continuation-type (return-result return) type-returns
- (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~% ~
+ 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)))))))
+\f
+;;; 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))
\f
;;;; FIXME: Move to some other file.
(defun check-catch-tag-type (tag)
projects / sbcl.git / blobdiff