(let ((kind (basic-combination-kind dest)))
(cond ((eq cont (basic-combination-fun dest)) t)
((eq kind :local) t)
- ((member kind '(:full :error)) nil)
+ ((not (eq (continuation-asserted-type cont)
+ (continuation-externally-checkable-type cont)))
+ ;; There is an explicit assertion.
+ t)
+ ((eq kind :full)
+ ;; The theory is that the type assertion is from a
+ ;; declaration in (or on) the callee, so the
+ ;; callee should be able to do the check. We want
+ ;; to let the callee do the check, because it is
+ ;; possible that by the time of call that
+ ;; declaration will be changed and we do not want
+ ;; to make people recompile all calls to a
+ ;; function when they were originally compiled
+ ;; with a bad declaration. (See also bug 35.)
+ nil)
+
+ ((eq kind :error) nil)
;; :ERROR means that we have an invalid syntax of
;; the call and the callee will detect it before
- ;; thinking about types. When KIND is :FULL, the
- ;; theory is that the type assertion is probably
- ;; from a declaration in (or on) the callee, so the
- ;; callee should be able to do the check. We want
- ;; to let the callee do the check, because it is
- ;; possible that by the time of call that
- ;; declaration will be changed and we do not want
- ;; to make people recompile all calls to a function
- ;; when they were originally compiled with a bad
- ;; declaration. (See also bug 35.)
+ ;; thinking about types.
((fun-info-ir2-convert kind) t)
(t
(declaim (ftype (function (continuation) ctype) continuation-type))
(defun continuation-type (cont)
(single-value-type (continuation-derived-type cont)))
+
+;;; If CONT is an argument of a function, return a type which the
+;;; function checks CONT for.
+#!-sb-fluid (declaim (inline continuation-externally-checkable-type))
+(defun continuation-externally-checkable-type (cont)
+ (or (continuation-%externally-checkable-type cont)
+ (%continuation-%externally-checkable-type cont)))
+(defun %continuation-%externally-checkable-type (cont)
+ (declare (type continuation cont))
+ (let ((dest (continuation-dest cont)))
+ (if (not (and dest (combination-p dest)))
+ ;; TODO: MV-COMBINATION
+ (setf (continuation-%externally-checkable-type cont) *wild-type*)
+ (let* ((fun (combination-fun dest))
+ (args (combination-args dest))
+ (fun-type (continuation-type fun)))
+ (if (or (not (fun-type-p fun-type))
+ ;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)).
+ (fun-type-wild-args fun-type))
+ (progn (dolist (arg args)
+ (setf (continuation-%externally-checkable-type arg)
+ *wild-type*))
+ *wild-type*)
+ (let* ((arg-types (append (fun-type-required fun-type)
+ (fun-type-optional fun-type)
+ (let ((rest (list (or (fun-type-rest fun-type)
+ *wild-type*))))
+ (setf (cdr rest) rest)))))
+ ;; TODO: &KEY
+ (loop
+ for arg of-type continuation in args
+ and type of-type ctype in arg-types
+ do (setf (continuation-%externally-checkable-type arg)
+ type))
+ (continuation-%externally-checkable-type cont)))))))
\f
;;;; interface routines used by optimizers
(new-block (continuation-starts-block new-cont)))
(link-node-to-previous-continuation new-node new-cont)
(setf (continuation-dest new-cont) new-node)
+ (setf (continuation-%externally-checkable-type new-cont) nil)
(add-continuation-use new-node dummy-cont)
(setf (block-last new-block) new-node)
(flush-dest (combination-fun use))
(let ((fun-cont (basic-combination-fun call)))
(setf (continuation-dest fun-cont) use)
- (setf (combination-fun use) fun-cont))
+ (setf (combination-fun use) fun-cont)
+ (setf (continuation-%externally-checkable-type fun-cont) nil))
(setf (combination-kind use) :local)
(setf (functional-kind fun) :let)
(flush-dest (first (basic-combination-args call)))
(setf (combination-kind node) :full)
(let ((args (combination-args use)))
(dolist (arg args)
- (setf (continuation-dest arg) node))
+ (setf (continuation-dest arg) node)
+ (setf (continuation-%externally-checkable-type arg) nil))
(setf (combination-args use) nil)
(flush-dest list)
(setf (combination-args node) args))
(setf (continuation-dest fun-cont) node)
(assert-continuation-type fun-cont
(specifier-type '(or function symbol)))
+ (setf (continuation-%externally-checkable-type fun-cont) nil)
(collect ((arg-conts))
(let ((this-start fun-cont))
(dolist (arg args)
(setf (lambda-tail-set lambda) tail-set)
(setf (lambda-return lambda) return)
(setf (continuation-dest result) return)
+ (setf (continuation-%externally-checkable-type result) nil)
(setf (block-last block) return)
(link-node-to-previous-continuation return result)
(use-continuation return dummy))
(nsubst new old (basic-combination-args dest))))))
(flush-dest old)
- (setf (continuation-dest new) dest))
+ (setf (continuation-dest new) dest)
+ (setf (continuation-%externally-checkable-type new) nil))
(values))
;;; Replace all uses of OLD with uses of NEW, where NEW has an
(unless (eq (continuation-kind cont) :deleted)
(aver (continuation-dest cont))
(setf (continuation-dest cont) nil)
+ (setf (continuation-%externally-checkable-type cont) nil)
(do-uses (use cont)
(let ((prev (node-prev use)))
(unless (eq (continuation-kind prev) :deleted)
(setf (continuation-kind cont) :deleted)
(setf (continuation-dest cont) nil)
+ (setf (continuation-%externally-checkable-type cont) nil)
(setf (continuation-next cont) nil)
(setf (continuation-asserted-type cont) *empty-type*)
(setf (continuation-%derived-type cont) *empty-type*)
(before-args (subseq outside-args 0 arg-position))
(after-args (subseq outside-args (1+ arg-position))))
(dolist (arg inside-args)
- (setf (continuation-dest arg) outside))
+ (setf (continuation-dest arg) outside)
+ (setf (continuation-%externally-checkable-type arg) nil))
(setf (combination-args inside) nil)
(setf (combination-args outside)
(append before-args inside-args after-args))
;; This is computed lazily by CONTINUATION-DERIVED-TYPE, so use
;; CONTINUATION-TYPE-CHECK instead of the %'ed slot accessor.
(%type-check t :type (member t nil :deleted :no-check))
+ ;; Cached type which is checked by DEST. If NIL, then this must be
+ ;; recomputed: see CONTINUATION-EXTERNALLY-CHECKABLE-TYPE.
+ (%externally-checkable-type nil :type (or null ctype))
;; something or other that the back end annotates this continuation with
(info nil)
;; uses of this continuation in the lexical environment. They are
(raises-error? (foo 3) type-error)
(raises-error? (foo 3f0) type-error)
+
+;;; until 0.8.2 SBCL did not check THEs in arguments
+(defun the-in-arguments-aux (x)
+ x)
+(defun the-in-arguments-1 (x)
+ (list x (the-in-arguments-aux (the (single-float 0s0) x))))
+(defun the-in-arguments-2 (x)
+ (list x (the-in-arguments-aux (the single-float x))))
+
+(multiple-value-bind (result condition)
+ (ignore-errors (the-in-arguments-1 1))
+ (assert (null result))
+ (assert (typep condition 'type-error)))
+#+nil
+(multiple-value-bind (result condition)
+ (ignore-errors (the-in-arguments-2 1))
+ (assert (null result))
+ (assert (typep condition 'type-error)))
\f
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself
;;; internal versions off the main CVS branch, it gets hairier, e.g.
;;; "0.pre7.14.flaky4.13".)
-"0.7.8.1"
+"0.7.8.2"
projects / sbcl.git / commitdiff