;;; 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
(result-test #'values-subtypep)
((:lossage-fun *lossage-fun*))
((:unwinnage-fun *unwinnage-fun*)))
- (declare (type function 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))
+ (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)
+ (*unwinnage-detected* nil)
+ (*compiler-error-context* call)
(args (combination-args call)))
(if (fun-type-p type)
(let* ((nargs (length args))
(when keyp
(check-key-args args max-args type))))
- (let* ((dtype (node-derived-type call))
- (return-type (fun-type-returns type))
- (out-type 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)))))))
+ (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)))
(*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))
+;;; 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"
- n (type-specifier type))
- nil)
- ((not int)
- (note-lossage "The ~:R argument is a ~S, not a ~S."
- n (type-specifier ctype) (type-specifier type))
- nil)
- ((eq ctype *empty-type*)
- (note-unwinnage "The ~:R argument never returns a value." n)
- nil)
- (t t)))))
- ((not (constant-continuation-p cont))
+ (cond ((not win)
+ (note-unwinnage "can't tell whether the ~:R argument is a ~S"
+ n (type-specifier type))
+ nil)
+ ((not int)
+ (note-lossage "The ~:R argument is a ~S, not a ~S."
+ n (type-specifier ctype) (type-specifier type))
+ nil)
+ ((eq ctype *empty-type*)
+ (note-unwinnage "The ~:R argument never returns a value." n)
+ nil)
+ (t t)))))
+ ((not (constant-lvar-p lvar))
(note-unwinnage "The ~:R argument is not a constant." n)
nil)
(t
- (let ((val (continuation-value cont))
- (type (constant-type-type type)))
+ (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"
- n (type-specifier type) val)
- nil)
- ((not res)
- (note-lossage "The ~:R argument is not a constant ~S:~% ~S"
- n (type-specifier type) val)
- nil)
- (t t)))))))
+ (cond ((not win)
+ (note-unwinnage "can't tell whether the ~:R argument is a ~
+ constant ~S:~% ~S"
+ n (type-specifier type) val)
+ nil)
+ ((not res)
+ (note-lossage "The ~:R argument is not a constant ~S:~% ~S"
+ n (type-specifier type) val)
+ nil)
+ (t t)))))))
;;; Check that each of the type of each supplied argument intersects
;;; with the type specified for that argument. If we can't tell, then
(n 1 (1+ n)))
((or (null type) (null arg))
(when rest
- (dolist (arg arg)
- (check-arg-type arg rest n)
- (incf n))))
+ (dolist (arg arg)
+ (check-arg-type arg rest n)
+ (incf n))))
(declare (fixnum n))
(check-arg-type (car arg) (car type) n))
(values))
;;; complain about absence of manifest winnage.
(declaim (ftype (function (list fixnum fun-type) (values)) check-key-args))
(defun check-key-args (args pre-key type)
- (do ((key (nthcdr pre-key args) (cddr key))
- (n (1+ pre-key) (+ n 2)))
- ((null key))
- (declare (fixnum n))
- (let ((k (car key)))
- (cond
- ((not (check-arg-type k (specifier-type 'symbol) n)))
- ((not (constant-continuation-p k))
- (note-unwinnage "The ~:R argument (in keyword position) is not a ~
- constant."
- n))
- (t
- (let* ((name (continuation-value k))
- (info (find name (fun-type-keywords type)
- :key #'key-info-name)))
- (cond ((not info)
- (unless (fun-type-allowp type)
- (note-lossage "~S is not a known argument keyword."
- name)))
- (t
- (check-arg-type (second key) (key-info-type info)
- (1+ n)))))))))
+ (let (lossages allow-other-keys)
+ (do ((key (nthcdr pre-key args) (cddr key))
+ (n (1+ pre-key) (+ n 2)))
+ ((null key))
+ (declare (fixnum n))
+ (let ((k (first key))
+ (v (second key)))
+ (cond
+ ((not (check-arg-type k (specifier-type 'symbol) n)))
+ ((not (constant-lvar-p k))
+ (note-unwinnage "~@<The ~:R argument (in keyword position) is not ~
+ a constant, weakening keyword argument ~
+ checking.~:@>" n)
+ ;; An unknown key may turn out to be :ALLOW-OTHER-KEYS at runtime,
+ ;; so we cannot signal full warnings for keys that look bad.
+ (unless allow-other-keys
+ (setf allow-other-keys :maybe)))
+ (t
+ (let* ((name (lvar-value k))
+ (info (find name (fun-type-keywords type)
+ :key #'key-info-name)))
+ (cond ((eq name :allow-other-keys)
+ (unless allow-other-keys
+ (if (constant-lvar-p v)
+ (setf allow-other-keys (if (lvar-value v)
+ :yes
+ :no))
+ (setf allow-other-keys :maybe))))
+ ((not info)
+ (unless (fun-type-allowp type)
+ (pushnew name lossages :test #'eq)))
+ (t
+ (check-arg-type (second key) (key-info-type info)
+ (1+ n)))))))))
+ (when (and lossages (member allow-other-keys '(nil :no)))
+ (setf lossages (nreverse lossages))
+ (if (cdr lossages)
+ (note-lossage "~@<~{~S~^, ~} and ~S are not a known argument keywords.~:@>"
+ (butlast lossages)
+ (car (last lossages)))
+ (note-lossage "~S is not a known argument keyword."
+ (car lossages)))))
(values))
;;; Construct a function type from a definition.
;;;
;;; 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
:required (mapcar #'leaf-type (lambda-vars functional))
:returns (tail-set-type (lambda-tail-set functional)))
(let ((rest nil))
- (collect ((req)
- (opt)
- (keys))
- (dolist (arg (optional-dispatch-arglist functional))
- (let ((info (lambda-var-arg-info arg))
- (type (leaf-type arg)))
- (if info
- (ecase (arg-info-kind info)
- (:required (req type))
- (:optional (opt type))
- (:keyword
- (keys (make-key-info :name (arg-info-key info)
- :type type)))
- ((:rest :more-context)
- (setq rest *universal-type*))
- (:more-count))
- (req type))))
-
- (make-fun-type
- :required (req)
- :optional (opt)
- :rest rest
- :keywords (keys)
- :keyp (optional-dispatch-keyp functional)
- :allowp (optional-dispatch-allowp functional)
- :returns (tail-set-type
- (lambda-tail-set
- (optional-dispatch-main-entry functional))))))))
+ (collect ((req)
+ (opt)
+ (keys))
+ (dolist (arg (optional-dispatch-arglist functional))
+ (let ((info (lambda-var-arg-info arg))
+ (type (leaf-type arg)))
+ (if info
+ (ecase (arg-info-kind info)
+ (:required (req type))
+ (:optional (opt type))
+ (:keyword
+ (keys (make-key-info :name (arg-info-key info)
+ :type type)))
+ ((:rest :more-context)
+ (setq rest *universal-type*))
+ (:more-count))
+ (req type))))
+
+ (make-fun-type
+ :required (req)
+ :optional (opt)
+ :rest rest
+ :keywords (keys)
+ :keyp (optional-dispatch-keyp functional)
+ :allowp (optional-dispatch-allowp functional)
+ :returns (tail-set-type
+ (lambda-tail-set
+ (optional-dispatch-main-entry functional))))))))
\f
;;;; approximate function types
;;;;
(defstruct (approximate-fun-type (:copier nil))
;; the smallest and largest numbers of arguments that this function
;; has been called with.
- (min-args sb!xc:call-arguments-limit :type fixnum)
- (max-args 0 :type fixnum)
+ (min-args sb!xc:call-arguments-limit
+ :type (integer 0 #.sb!xc:call-arguments-limit))
+ (max-args 0
+ :type (integer 0 #.sb!xc:call-arguments-limit))
;; a list of lists of the all the types that have been used in each
;; argument position
(types () :type list)
(name (missing-arg) :type keyword)
;; The position at which this keyword appeared. 0 if it appeared as the
;; first argument, etc.
- (position (missing-arg) :type fixnum)
+ (position (missing-arg)
+ :type (integer 0 #.sb!xc:call-arguments-limit))
;; a list of all the argument types that have been used with this keyword
(types nil :type list)
;; true if this keyword has appeared only in calls with an obvious
;;; CALL. If TYPE is supplied and not null, then we merge the
;;; information into the information already accumulated in TYPE.
(declaim (ftype (function (combination
- &optional (or approximate-fun-type null))
- approximate-fun-type)
- note-fun-use))
+ &optional (or approximate-fun-type null))
+ approximate-fun-type)
+ note-fun-use))
(defun note-fun-use (call &optional type)
(let* ((type (or type (make-approximate-fun-type)))
- (types (approximate-fun-type-types type))
- (args (combination-args call))
- (nargs (length args))
- (allowp (some (lambda (x)
- (and (constant-continuation-p x)
- (eq (continuation-value x) :allow-other-keys)))
- args)))
+ (types (approximate-fun-type-types type))
+ (args (combination-args call))
+ (nargs (length args))
+ (allowp (some (lambda (x)
+ (and (constant-lvar-p x)
+ (eq (lvar-value x) :allow-other-keys)))
+ args)))
(setf (approximate-fun-type-min-args type)
- (min (approximate-fun-type-min-args type) nargs))
+ (min (approximate-fun-type-min-args type) nargs))
(setf (approximate-fun-type-max-args type)
- (max (approximate-fun-type-max-args type) nargs))
+ (max (approximate-fun-type-max-args type) nargs))
(do ((old types (cdr old))
- (arg args (cdr arg)))
- ((null old)
- (setf (approximate-fun-type-types type)
- (nconc types
- (mapcar (lambda (x)
- (list (continuation-type x)))
- arg))))
+ (arg args (cdr arg)))
+ ((null old)
+ (setf (approximate-fun-type-types type)
+ (nconc types
+ (mapcar (lambda (x)
+ (list (lvar-type x)))
+ arg))))
(when (null arg) (return))
- (pushnew (continuation-type (car arg))
- (car old)
- :test #'type=))
+ (pushnew (lvar-type (car arg))
+ (car old)
+ :test #'type=))
(collect ((keys (approximate-fun-type-keys type) cons))
(do ((arg args (cdr arg))
- (pos 0 (1+ pos)))
- ((or (null arg) (null (cdr arg)))
- (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 (keywordp name)
- (let ((old (find-if
- (lambda (x)
- (and (eq (approximate-key-info-name x) name)
- (= (approximate-key-info-position x)
- pos)))
- (keys)))
- (val-type (continuation-type val)))
- (cond (old
- (pushnew val-type
- (approximate-key-info-types old)
- :test #'type=)
- (unless allowp
- (setf (approximate-key-info-allowp old) nil)))
- (t
- (keys (make-approximate-key-info
- :name name
- :position pos
- :allowp allowp
- :types (list val-type))))))))))))
+ (pos 0 (1+ pos)))
+ ((or (null arg) (null (cdr arg)))
+ (setf (approximate-fun-type-keys type) (keys)))
+ (let ((key (first arg))
+ (val (second arg)))
+ (when (constant-lvar-p key)
+ (let ((name (lvar-value key)))
+ (when (keywordp name)
+ (let ((old (find-if
+ (lambda (x)
+ (and (eq (approximate-key-info-name x) name)
+ (= (approximate-key-info-position x)
+ pos)))
+ (keys)))
+ (val-type (lvar-type val)))
+ (cond (old
+ (pushnew val-type
+ (approximate-key-info-types old)
+ :test #'type=)
+ (unless allowp
+ (setf (approximate-key-info-allowp old) nil)))
+ (t
+ (keys (make-approximate-key-info
+ :name name
+ :position pos
+ :allowp allowp
+ :types (list val-type))))))))))))
type))
;;; 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)
- (values boolean boolean))
- valid-approximate-type))
+ &optional function function function)
+ (values boolean boolean))
+ valid-approximate-type))
(defun valid-approximate-type (call-type type &optional
- (*ctype-test-fun*
- #'types-equal-or-intersect)
- (*lossage-fun*
- #'compiler-style-warn)
- (*unwinnage-fun* #'compiler-note))
+ (*ctype-test-fun*
+ #'types-equal-or-intersect)
+ (*lossage-fun*
+ #'compiler-style-warn)
+ (*unwinnage-fun* #'compiler-notify))
(let* ((*lossage-detected* nil)
- (*unwinnage-detected* nil)
- (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)))
+ (*unwinnage-detected* nil)
+ (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)))
(when (fun-type-wild-args type)
(return-from valid-approximate-type (values t t)))
(let ((call-min (approximate-fun-type-min-args call-type)))
(when (< call-min min-args)
- (note-lossage
- "~:@<The function was previously called with ~R argument~:P, ~
+ (note-lossage
+ "~:@<The function was previously called with ~R argument~:P, ~
but wants at least ~R.~:>"
- call-min min-args)))
+ call-min min-args)))
(let ((call-max (approximate-fun-type-max-args call-type)))
(cond ((<= call-max max-args))
- ((not (or keyp rest))
- (note-lossage
- "~:@<The function was previously called with ~R argument~:P, ~
+ ((not (or keyp rest))
+ (note-lossage
+ "~:@<The function was previously called with ~R argument~:P, ~
but wants at most ~R.~:>"
- call-max max-args))
- ((and keyp (oddp (- call-max max-args)))
- (note-lossage
- "~:@<The function was previously called with an odd number of ~
+ call-max max-args))
+ ((and keyp (oddp (- call-max max-args)))
+ (note-lossage
+ "~:@<The function was previously called with an odd number of ~
arguments in the keyword portion.~:>")))
(when (and keyp (> call-max max-args))
- (check-approximate-keywords call-type max-args type)))
+ (check-approximate-keywords call-type max-args type)))
(check-approximate-fixed-and-rest call-type (append required optional)
- rest)
+ rest)
(cond (*lossage-detected* (values nil t))
- (*unwinnage-detected* (values nil nil))
- (t (values t t)))))
+ (*unwinnage-detected* (values nil nil))
+ (t (values t t)))))
;;; Check that each of the types used at each arg position is
;;; compatible with the actual type.
(declaim (ftype (function (approximate-fun-type list (or ctype null))
- (values))
- check-approximate-fixed-and-rest))
+ (values))
+ check-approximate-fixed-and-rest))
(defun check-approximate-fixed-and-rest (call-type fixed rest)
(do ((types (approximate-fun-type-types call-type) (cdr types))
(n 1 (1+ n))
;;; Check that each of the call-types is compatible with DECL-TYPE,
;;; complaining if not or if we can't tell.
(declaim (ftype (function (list ctype string &rest t) (values))
- check-approximate-arg-type))
+ check-approximate-arg-type))
(defun check-approximate-arg-type (call-types decl-type context &rest args)
(let ((losers *empty-type*))
(dolist (ctype call-types)
(multiple-value-bind (int win) (funcall *ctype-test-fun* ctype decl-type)
- (cond
- ((not win)
- (note-unwinnage "can't tell whether previous ~? ~
+ (cond
+ ((not win)
+ (note-unwinnage "can't tell whether previous ~? ~
argument type ~S is a ~S"
- context
- args
- (type-specifier ctype)
- (type-specifier decl-type)))
- ((not int)
- (setq losers (type-union ctype losers))))))
+ context
+ args
+ (type-specifier ctype)
+ (type-specifier decl-type)))
+ ((not int)
+ (setq losers (type-union ctype losers))))))
(unless (eq losers *empty-type*)
(note-lossage "~:(~?~) argument should be a ~S but was a ~S in a previous call."
- context args (type-specifier decl-type) (type-specifier losers))))
+ context args (type-specifier decl-type) (type-specifier losers))))
(values))
;;; Check the types of each manifest keyword that appears in a keyword
;;; keywords.
(defun check-approximate-keywords (call-type max-args type)
(let ((call-keys (approximate-fun-type-keys call-type))
- (keys (fun-type-keywords type)))
+ (keys (fun-type-keywords type)))
(dolist (key keys)
(let ((name (key-info-name key)))
- (collect ((types nil append))
- (dolist (call-key call-keys)
- (let ((pos (approximate-key-info-position call-key)))
- (when (and (eq (approximate-key-info-name call-key) name)
- (> pos max-args) (evenp (- pos max-args)))
- (types (approximate-key-info-types call-key)))))
- (check-approximate-arg-type (types) (key-info-type key) "~S" name))))
+ (collect ((types nil append))
+ (dolist (call-key call-keys)
+ (let ((pos (approximate-key-info-position call-key)))
+ (when (and (eq (approximate-key-info-name call-key) name)
+ (> pos max-args) (evenp (- pos max-args)))
+ (types (approximate-key-info-types call-key)))))
+ (check-approximate-arg-type (types) (key-info-type key) "~S" name))))
(unless (fun-type-allowp type)
(collect ((names () adjoin))
- (dolist (call-key call-keys)
- (let ((pos (approximate-key-info-position call-key)))
- (when (and (> pos max-args) (evenp (- pos max-args))
- (not (approximate-key-info-allowp call-key)))
- (names (approximate-key-info-name call-key)))))
-
- (dolist (name (names))
- (unless (find name keys :key #'key-info-name)
- (note-lossage "Function previously called with unknown argument keyword ~S."
- name)))))))
+ (dolist (call-key call-keys)
+ (let ((pos (approximate-key-info-position call-key)))
+ (when (and (> pos max-args) (evenp (- pos max-args))
+ (not (approximate-key-info-allowp call-key)))
+ (names (approximate-key-info-name call-key)))))
+
+ (dolist (name (names))
+ (unless (find name keys :key #'key-info-name)
+ (note-lossage "Function previously called with unknown argument keyword ~S."
+ name)))))))
\f
;;;; ASSERT-DEFINITION-TYPE
(declare (list vars types) (string where))
(collect ((res))
(mapc (lambda (var type)
- (let* ((vtype (leaf-type var))
- (int (type-approx-intersection2 vtype type)))
- (cond
- ((eq int *empty-type*)
- (note-lossage
- "Definition's declared type for variable ~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)))
- (t
- (res int)))))
- vars types)
+ (let* ((vtype (leaf-type var))
+ (int (type-approx-intersection2 vtype type)))
+ (cond
+ ((eq int *empty-type*)
+ (note-lossage
+ "Definition's declared type for variable ~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)))
+ (t
+ (res int)))))
+ vars types)
(values vars (res))))
;;; Check that the optional-dispatch OD conforms to TYPE. We return
;;; assertion.
(defun find-optional-dispatch-types (od type where)
(declare (type optional-dispatch od)
- (type fun-type type)
- (string where))
+ (type fun-type type)
+ (string where))
(let* ((min (optional-dispatch-min-args od))
- (req (fun-type-required type))
- (opt (fun-type-optional type)))
+ (req (fun-type-required type))
+ (opt (fun-type-optional type)))
(flet ((frob (x y what)
- (unless (= x y)
- (note-lossage
- "The definition has ~R ~A arg~P, but ~A has ~R."
- x what x where y))))
+ (unless (= x y)
+ (note-lossage
+ "The definition has ~R ~A arg~P, but ~A has ~R."
+ x what x where y))))
(frob min (length req) "fixed")
(frob (- (optional-dispatch-max-args od) min) (length opt) "optional"))
(flet ((frob (x y what)
- (unless (eq x y)
- (note-lossage
- "The definition ~:[doesn't have~;has~] ~A, but ~
- ~A ~:[doesn't~;does~]."
- x what where y))))
+ (unless (eq x y)
+ (note-lossage
+ "The definition ~:[doesn't have~;has~] ~A, but ~
+ ~A ~:[doesn't~;does~]."
+ x what where y))))
(frob (optional-dispatch-keyp od) (fun-type-keyp type)
- "&KEY arguments")
+ "&KEY arguments")
(unless (optional-dispatch-keyp od)
- (frob (not (null (optional-dispatch-more-entry od)))
- (not (null (fun-type-rest type)))
- "&REST arguments"))
+ (frob (not (null (optional-dispatch-more-entry od)))
+ (not (null (fun-type-rest type)))
+ "&REST argument"))
(frob (optional-dispatch-allowp od) (fun-type-allowp type)
- "&ALLOW-OTHER-KEYS"))
+ "&ALLOW-OTHER-KEYS"))
(when *lossage-detected*
(return-from find-optional-dispatch-types (values nil nil)))
(collect ((res)
- (vars))
+ (vars))
(let ((keys (fun-type-keywords type))
- (arglist (optional-dispatch-arglist od)))
- (dolist (arg arglist)
- (cond
- ((lambda-var-arg-info arg)
- (let* ((info (lambda-var-arg-info arg))
- (default (arg-info-default info))
- (def-type (when (constantp default)
- (ctype-of (eval default)))))
- (ecase (arg-info-kind info)
- (:keyword
- (let* ((key (arg-info-key info))
- (kinfo (find key keys :key #'key-info-name)))
- (cond
- (kinfo
- (res (type-union (key-info-type kinfo)
- (or def-type (specifier-type 'null)))))
- (t
- (note-lossage
- "Defining a ~S keyword not present in ~A."
- key where)
- (res *universal-type*)))))
- (:required (res (pop req)))
- (:optional
- (res (type-union (pop opt) (or def-type *universal-type*))))
- (:rest
- (when (fun-type-rest type)
- (res (specifier-type 'list))))
- (:more-context
- (when (fun-type-rest type)
- (res *universal-type*)))
- (:more-count
- (when (fun-type-rest type)
- (res (specifier-type 'fixnum)))))
- (vars arg)
- (when (arg-info-supplied-p info)
- (res *universal-type*)
- (vars (arg-info-supplied-p info)))))
- (t
- (res (pop req))
- (vars arg))))
-
- (dolist (key keys)
- (unless (find (key-info-name key) arglist
- :key (lambda (x)
- (let ((info (lambda-var-arg-info x)))
- (when info
- (arg-info-key info)))))
- (note-lossage
- "The definition lacks the ~S key present in ~A."
- (key-info-name key) where))))
+ (arglist (optional-dispatch-arglist od)))
+ (dolist (arg arglist)
+ (cond
+ ((lambda-var-arg-info arg)
+ (let* ((info (lambda-var-arg-info arg))
+ (default (arg-info-default info))
+ (def-type (when (sb!xc:constantp default)
+ (ctype-of (constant-form-value default)))))
+ (ecase (arg-info-kind info)
+ (:keyword
+ (let* ((key (arg-info-key info))
+ (kinfo (find key keys :key #'key-info-name)))
+ (cond
+ (kinfo
+ (res (type-union (key-info-type kinfo)
+ (or def-type (specifier-type 'null)))))
+ (t
+ (note-lossage
+ "Defining a ~S keyword not present in ~A."
+ key where)
+ (res *universal-type*)))))
+ (:required (res (pop req)))
+ (:optional
+ (res (type-union (pop opt) (or def-type *universal-type*))))
+ (:rest
+ (when (fun-type-rest type)
+ (res (specifier-type 'list))))
+ (:more-context
+ (when (fun-type-rest type)
+ (res *universal-type*)))
+ (:more-count
+ (when (fun-type-rest type)
+ (res (specifier-type 'fixnum)))))
+ (vars arg)
+ (when (arg-info-supplied-p info)
+ (res *universal-type*)
+ (vars (arg-info-supplied-p info)))))
+ (t
+ (res (pop req))
+ (vars arg))))
+
+ (dolist (key keys)
+ (unless (find (key-info-name key) arglist
+ :key (lambda (x)
+ (let ((info (lambda-var-arg-info x)))
+ (when info
+ (arg-info-key info)))))
+ (note-lossage
+ "The definition lacks the ~S key present in ~A."
+ (key-info-name key) where))))
(try-type-intersections (vars) (res) where))))
(defun find-lambda-types (lambda type where)
(declare (type clambda lambda) (type fun-type type) (string where))
(flet ((frob (x what)
- (when x
- (note-lossage
- "The definition has no ~A, but the ~A did."
- what where))))
+ (when x
+ (note-lossage
+ "The definition has no ~A, but the ~A did."
+ what where))))
(frob (fun-type-optional type) "&OPTIONAL arguments")
(frob (fun-type-keyp type) "&KEY arguments")
(frob (fun-type-rest type) "&REST argument"))
(let* ((vars (lambda-vars lambda))
- (nvars (length vars))
- (req (fun-type-required type))
- (nreq (length req)))
+ (nvars (length vars))
+ (req (fun-type-required type))
+ (nreq (length req)))
(unless (= nvars nreq)
(note-lossage "The definition has ~R arg~:P, but the ~A has ~R."
- nvars where nreq))
+ nvars where nreq))
(if *lossage-detected*
- (values nil nil)
- (try-type-intersections vars req where))))
+ (values nil nil)
+ (try-type-intersections vars req where))))
;;; Check for syntactic and type conformance between the definition
;;; FUNCTIONAL and the specified FUN-TYPE. If they are compatible
;;; 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))
+ (type function *lossage-fun*)
+ (string where))
(unless (fun-type-p type)
(return-from assert-definition-type t))
(let ((*lossage-detected* nil))
(multiple-value-bind (vars types)
- (if (fun-type-wild-args type)
- (values nil nil)
- (etypecase functional
- (optional-dispatch
- (find-optional-dispatch-types functional type where))
- (clambda
- (find-lambda-types functional type where))))
+ (if (fun-type-wild-args type)
+ (values nil nil)
+ (etypecase functional
+ (optional-dispatch
+ (find-optional-dispatch-types functional type where))
+ (clambda
+ (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))))) ; !!
- (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~% ~
- 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))))))
-
+ (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)
- (setf (leaf-type fun) type)
- (assert-definition-type fun type
- :unwinnage-fun #'compiler-note
- :where "proclamation"))))
+ (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))
+ (let ((keyname (first arg)))
+ (when (and (constant-lvar-p keyname)
+ (eq (lvar-value keyname) 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 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))))))
-
-(defun %compile-time-type-error (values atype dtype)
+ (let ((sources (lvar-all-sources tag)))
+ (if (singleton-p sources)
+ (compiler-style-warn
+ "~@<using ~S of type ~S as a catch tag (which ~
+ tends to be unportable because THROW and CATCH ~
+ use EQ comparison)~@:>"
+ (first sources)
+ (type-specifier (lvar-type tag)))
+ (compiler-style-warn
+ "~@<using ~{~S~^~#[~; or ~:;, ~]~} in ~S of type ~S ~
+ as a catch tag (which tends to be unportable ~
+ because THROW and CATCH use EQ comparison)~@:>"
+ (rest sources) (first sources)
+ (type-specifier (lvar-type tag))))))))
+
+(defun %compile-time-type-error (values atype dtype context)
(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)))
+ (destructuring-bind (form . detail) context
+ (if (and (consp atype) (eq (car atype) 'values))
+ (if (singleton-p detail)
+ (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
+ (first detail) form
+ atype))
+ (error 'simple-type-error
+ :datum (car values)
+ :expected-type atype
+ :format-control
+ "~@<Value set ~2I~_[~{~S~^ ~}] ~
+ ~I~_from ~2I~_~{~S~^~#[~; or ~:;, ~]~} ~
+ ~I~_of ~2I~_~S ~I~_in ~2I~_~S ~I~_is not of type ~2I~_~S.~:>"
+ :format-arguments (list values
+ (rest detail) (first detail)
+ form
+ atype)))
+ (if (singleton-p detail)
+ (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 (car detail) form
+ (car values)
+ atype))
+ (error 'simple-type-error
+ :datum (car values)
+ :expected-type atype
+ :format-control "~@<Value from ~2I~_~{~S~^~#[~; or ~:;, ~]~} ~
+ ~I~_of ~2I~_~S ~I~_in ~2I~_~S ~I~_is ~2I~_~S, ~
+ ~I~_not a ~2I~_~S.~:@>"
+ :format-arguments (list (rest detail) (first detail) form
+ (car values)
+ atype))))))
(defoptimizer (%compile-time-type-error ir2-convert)
- ((objects atype dtype) node block)
+ ((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)
+ (destructuring-bind (values atype dtype context)
(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))))
+ (let ((atype (lvar-value atype))
+ (dtype (lvar-value dtype))
+ (detail (cdr (lvar-value context))))
+ (unless (eq atype nil)
+ (if (singleton-p detail)
+ (let ((detail (first detail)))
+ (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))))
+ (warn 'type-warning
+ :format-control
+ "~@<Derived type of ~2I~_~{~S~^~#[~; and ~:;, ~]~} ~
+ ~I~_in ~2I~_~S ~I~_is ~2I~_~S, ~I~_conflicting with ~
+ their asserted type ~2I~_~S.~@:>"
+ :format-arguments (list (rest detail) (first detail) dtype atype))))))
(ir2-convert-full-call node block)))
projects / sbcl.git / blobdiff