-;;; Splice in explicit type check code immediately before the node which is
-;;; Cont's Dest. This code receives the value(s) that were being passed to
-;;; Cont, checks the type(s) of the value(s), then passes them on to Cont.
-(defun convert-type-check (cont types)
- (declare (type continuation cont) (type list types))
- (with-ir1-environment (continuation-dest cont)
-
- ;; Ensuring that CONT starts a block lets us freely manipulate its uses.
- (ensure-block-start cont)
-
- ;; Make a new continuation and move CONT's uses to it.
- (let* ((new-start (make-continuation))
- (dest (continuation-dest cont))
- (prev (node-prev dest)))
- (continuation-starts-block new-start)
- (substitute-continuation-uses new-start cont)
-
- ;; Setting TYPE-CHECK in CONT to :DELETED indicates that the check has
- ;; been done.
- (setf (continuation-%type-check cont) :deleted)
-
- ;; Make the DEST node start its block so that we can splice in the
- ;; type check code.
- (when (continuation-use prev)
- (node-ends-block (continuation-use prev)))
-
- (let* ((prev-block (continuation-block prev))
- (new-block (continuation-block new-start))
- (dummy (make-continuation)))
-
- ;; Splice in the new block before DEST, giving the new block all of
- ;; DEST's predecessors.
- (dolist (block (block-pred prev-block))
- (change-block-successor block prev-block new-block))
-
- ;; Convert the check form, using the new block start as START and a
- ;; dummy continuation as CONT.
- (ir1-convert new-start dummy (make-type-check-form types))
-
- ;; TO DO: Why should this be true? -- WHN 19990601
- (assert (eq (continuation-block dummy) new-block))
-
- ;; KLUDGE: Comments at the head of this function in CMU CL said that
- ;; somewhere in here we
- ;; Set the new block's start and end cleanups to the *start*
- ;; cleanup of PREV's block. This overrides the incorrect
- ;; default from WITH-IR1-ENVIRONMENT.
- ;; Unfortunately I can't find any code which corresponds to this.
- ;; Perhaps it was a stale comment? Or perhaps I just don't
- ;; understand.. -- WHN 19990521
-
- (let ((node (continuation-use dummy)))
- (setf (block-last new-block) node)
- ;; Change the use to a use of CONT. (We need to use the dummy
- ;; continuation to get the control transfer right, because we want to
- ;; go to PREV's block, not CONT's.)
- (delete-continuation-use node)
- (add-continuation-use node cont))
- ;; Link the new block to PREV's block.
- (link-blocks new-block prev-block))
-
- ;; MAKE-TYPE-CHECK-FORM generated a form which checked the type of
- ;; 'DUMMY, not a real form. At this point we convert to the real form by
- ;; finding 'DUMMY and overwriting it with the new continuation. (We can
- ;; find 'DUMMY because no LET conversion has been done yet.) The
- ;; [mv-]combination code from the mv-bind in the check form will be the
- ;; use of the new check continuation. We substitute for the first
- ;; argument of this node.
- (let* ((node (continuation-use cont))
- (args (basic-combination-args node))
- (victim (first args)))
- (assert (and (= (length args) 1)
- (eq (constant-value
- (ref-leaf
- (continuation-use victim)))
- 'dummy)))
- (substitute-continuation new-start victim)))
-
- ;; Invoking local call analysis converts this call to a LET.
- (local-call-analyze *current-component*))
-
- (values))
+;;; Splice in explicit type check code immediately before CAST. This
+;;; code receives the value(s) that were being passed to CAST-VALUE,
+;;; checks the type(s) of the value(s), then passes them further.
+(defun convert-type-check (cast types)
+ (declare (type cast cast) (type list types))
+ (let ((value (cast-value cast))
+ (length (length types)))
+ (filter-lvar value (make-type-check-form types))
+ (reoptimize-lvar (cast-value cast))
+ (setf (cast-type-to-check cast) *wild-type*)
+ (setf (cast-%type-check cast) nil)
+ (let* ((atype (cast-asserted-type cast))
+ (atype (cond ((not (values-type-p atype))
+ atype)
+ ((= length 1)
+ (single-value-type atype))
+ (t
+ (make-values-type
+ :required (values-type-out atype length)))))
+ (dtype (node-derived-type cast))
+ (dtype (make-values-type
+ :required (values-type-out dtype length))))
+ (setf (cast-asserted-type cast) atype)
+ (setf (node-derived-type cast) dtype)))