- ;; 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*))
+;;; Return a lambda form that we can convert to do a hairy type check
+;;; of the specified TYPES. TYPES is a list of the format returned by
+;;; LVAR-CHECK-TYPES in the :HAIRY case.
+;;;
+;;; Note that we don't attempt to check for required values being
+;;; unsupplied. Such checking is impossible to efficiently do at the
+;;; source level because our fixed-values conventions are optimized
+;;; for the common MV-BIND case.
+(defun make-type-check-form (types)
+ (let ((temps (make-gensym-list (length types))))
+ `(multiple-value-bind ,temps
+ 'dummy
+ ,@(mapcar (lambda (temp type)
+ (let* ((spec
+ (let ((*unparse-fun-type-simplify* t))
+ (type-specifier (second type))))
+ (test (if (first type) `(not ,spec) spec)))
+ `(unless (typep ,temp ',test)
+ (%type-check-error
+ ,temp
+ ',(type-specifier (third type))))))
+ temps
+ types)
+ (values ,@temps))))