;;; matches the specified result.
;;;
;;; Unlike the argument test, the result test may be called on values
-;;; or function types. If STRICT-RESULT is true and SAFETY is
-;;; non-zero, then the NODE-DERIVED-TYPE is always used. Otherwise, if
-;;; CONT's TYPE-CHECK is true, then the NODE-DERIVED-TYPE is
-;;; intersected with the CONT's ASSERTED-TYPE.
+;;; or function types. NODE-DERIVED-TYPE is intersected with the
+;;; trusted asserted type.
;;;
;;; The error and warning functions are functions that are called to
;;; explain the result. We bind *COMPILER-ERROR-CONTEXT* to the
;;; 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*)))
- (declare (type function result-test) (type combination call)
- (type fun-type type))
+ ((:argument-test *ctype-test-fun*) #'csubtypep)
+ (result-test #'values-subtypep)
+ ((:lossage-fun *lossage-fun*))
+ ((:unwinnage-fun *unwinnage-fun*)))
+ (declare (type (or function null) result-test) (type combination call)
+ ;; FIXME: Could TYPE here actually be something like
+ ;; (AND GENERIC-FUNCTION (FUNCTION (T) T))? How
+ ;; horrible... -- CSR, 2003-05-03
+ (type ctype type))
(let* ((*lossage-detected* nil)
(*unwinnage-detected* nil)
(*compiler-error-context* call)
- (args (combination-args call))
- (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)
- (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))))
+
+ (when result-test
+ (let* ((dtype (node-derived-type call))
+ (out-type (or
+ (binding* ((lvar (node-lvar call) :exit-if-null)
+ (dest (lvar-dest lvar)))
+ (when (and (cast-p dest)
+ (eq (cast-type-to-check dest) *wild-type*)
+ (immediately-used-p lvar call))
+ (values-type-intersection
+ dtype (cast-asserted-type dest))))
+ dtype))
+ (return-type (fun-type-returns type)))
+ (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)))))
-
-;;; Check that the derived type of the continuation CONT is compatible
-;;; with TYPE. N is the arg number, for error message purposes. We
-;;; return true if arg is definitely o.k. If the type is a magic
-;;; CONSTANT-TYPE, then we check for the argument being a constant
-;;; value of the specified type. If there is a manifest type error
-;;; (DERIVED-TYPE = NIL), then we flame about the asserted type even
-;;; when our type is satisfied under the test.
-(defun check-arg-type (cont type n)
- (declare (type continuation cont) (type ctype type) (type index n))
+ (*unwinnage-detected* (values nil nil))
+ (t (values t t)))))
+
+;;; Check that the derived type of the LVAR is compatible with TYPE. N
+;;; is the arg number, for error message purposes. We return true if
+;;; arg is definitely o.k. If the type is a magic CONSTANT-TYPE, then
+;;; we check for the argument being a constant value of the specified
+;;; type. If there is a manifest type error (DERIVED-TYPE = NIL), then
+;;; we flame about the asserted type even when our type is satisfied
+;;; under the test.
+(defun check-arg-type (lvar type n)
+ (declare (type lvar lvar) (type ctype type) (type index n))
(cond
((not (constant-type-p type))
- (let ((ctype (continuation-type cont)))
+ (let ((ctype (lvar-type lvar)))
(multiple-value-bind (int win) (funcall *ctype-test-fun* ctype type)
(cond ((not win)
(note-unwinnage "can't tell whether the ~:R argument is a ~S"
(note-unwinnage "The ~:R argument never returns a value." n)
nil)
(t t)))))
- ((not (constant-continuation-p cont))
+ ((not (constant-lvar-p lvar))
(note-unwinnage "The ~:R argument is not a constant." n)
nil)
(t
- (let ((val (continuation-value cont))
+ (let ((val (lvar-value lvar))
(type (constant-type-type type)))
(multiple-value-bind (res win) (ctypep val type)
(cond ((not win)
(note-unwinnage "can't tell whether the ~:R argument is a ~
- constant ~S:~% ~S"
+ constant ~S:~% ~S"
n (type-specifier type) val)
nil)
((not res)
(let ((k (car key)))
(cond
((not (check-arg-type k (specifier-type 'symbol) n)))
- ((not (constant-continuation-p k))
+ ((not (constant-lvar-p k))
(note-unwinnage "The ~:R argument (in keyword position) is not a ~
- constant."
+ constant."
n))
(t
- (let* ((name (continuation-value k))
+ (let* ((name (lvar-value k))
(info (find name (fun-type-keywords type)
:key #'key-info-name)))
(cond ((not info)
;;;
;;; 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
(args (combination-args call))
(nargs (length args))
(allowp (some (lambda (x)
- (and (constant-continuation-p x)
- (eq (continuation-value x) :allow-other-keys)))
+ (and (constant-lvar-p x)
+ (eq (lvar-value x) :allow-other-keys)))
args)))
(setf (approximate-fun-type-min-args type)
(setf (approximate-fun-type-types type)
(nconc types
(mapcar (lambda (x)
- (list (continuation-type x)))
+ (list (lvar-type x)))
arg))))
(when (null arg) (return))
- (pushnew (continuation-type (car arg))
+ (pushnew (lvar-type (car arg))
(car old)
:test #'type=))
(setf (approximate-fun-type-keys type) (keys)))
(let ((key (first arg))
(val (second arg)))
- (when (constant-continuation-p key)
- (let ((name (continuation-value key)))
+ (when (constant-lvar-p key)
+ (let ((name (lvar-value key)))
(when (keywordp name)
(let ((old (find-if
(lambda (x)
(= (approximate-key-info-position x)
pos)))
(keys)))
- (val-type (continuation-type val)))
+ (val-type (lvar-type val)))
(cond (old
(pushnew val-type
(approximate-key-info-types old)
: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)
#'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))
((eq int *empty-type*)
(note-lossage
"Definition's declared type for variable ~A:~% ~S~@
- conflicts with this type from ~A:~% ~S"
+ conflicts with this type from ~A:~% ~S"
(leaf-debug-name var) (type-specifier vtype)
where (type-specifier type))
(return-from try-type-intersections (values nil nil)))
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.
;;;
(unless (eq x y)
(note-lossage
"The definition ~:[doesn't have~;has~] ~A, but ~
- ~A ~:[doesn't~;does~]."
+ ~A ~:[doesn't~;does~]."
x what where y))))
(frob (optional-dispatch-keyp od) (fun-type-keyp type)
"&KEY arguments")
;;; 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))
(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
+ (lvar-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))
- (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))))))
-
+ ((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)
+ (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-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)
+ (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-lvar-type arg type policy))
+ call))
+ (values))
+\f
+;;;; FIXME: Move to some other file.
(defun check-catch-tag-type (tag)
- (declare (type continuation tag))
- (let ((ctype (continuation-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)~@:>"
- (continuation-source tag)
- (type-specifier (continuation-type tag))))))
+ (lvar-source tag)
+ (type-specifier (lvar-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 (lvar-value atype))
+ (dtype (lvar-value dtype)))
+ (unless (eq atype nil)
+ (warn 'type-warning
+ :format-control
+ "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
+ :format-arguments (list atype dtype)))))
+ (ir2-convert-full-call node block)))
projects / sbcl.git / blobdiff