-;;; Do stuff to recognize a THE or VALUES declaration. CONT is the
-;;; continuation that the assertion applies to, TYPE is the type
-;;; specifier and LEXENV is the current lexical environment. NAME is
-;;; the name of the declaration we are doing, for use in error
-;;; messages.
-;;;
-;;; This is somewhat involved, since a type assertion may only be made
-;;; on a continuation, not on a node. We can't just set the
-;;; continuation asserted type and let it go at that, since there may
-;;; be parallel THE's for the same continuation, i.e.
-;;; (if ...
-;;; (the foo ...)
-;;; (the bar ...))
-;;;
-;;; In this case, our representation can do no better than the union
-;;; of these assertions. And if there is a branch with no assertion,
-;;; we have nothing at all. We really need to recognize scoping, since
-;;; we need to be able to discern between parallel assertions (which
-;;; we union) and nested ones (which we intersect).
-;;;
-;;; We represent the scoping by throwing our innermost (intersected)
-;;; assertion on CONT into the TYPE-RESTRICTIONS. As we go down, we
-;;; intersect our assertions together. If CONT has no uses yet, we
-;;; have not yet bottomed out on the first COND branch; in this case
-;;; we optimistically assume that this type will be the one we end up
-;;; with, and set the ASSERTED-TYPE to it. We can never get better
-;;; than the type that we have the first time we bottom out. Later
-;;; THE's (or the absence thereof) can only weaken this result.
-;;;
-;;; We make this work by getting USE-CONTINUATION to do the unioning
-;;; across COND branches. We can't do it here, since we don't know how
-;;; many branches there are going to be.
-(defun ir1ize-the-or-values (type cont lexenv place)
- (declare (type continuation cont) (type lexenv lexenv))
- (let* ((atype (if (typep type 'ctype) type (compiler-values-specifier-type type)))
- (old-atype (or (lexenv-find cont type-restrictions)
- *wild-type*))
- (old-ctype (or (lexenv-find cont weakend-type-restrictions)
- *wild-type*))
- (intersects (values-types-equal-or-intersect old-atype atype))
- (new-atype (values-type-intersection old-atype atype))
- (new-ctype (values-type-intersection
- old-ctype (maybe-weaken-check atype (lexenv-policy lexenv)))))
- (when (null (find-uses cont))
- (setf (continuation-asserted-type cont) new-atype)
- (setf (continuation-type-to-check cont) new-ctype))
- (when (and (not intersects)
- ;; FIXME: Is it really right to look at *LEXENV* here,
- ;; instead of looking at the LEXENV argument? Why?
- (not (policy *lexenv*
- (= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
- (compiler-warn
- "The type ~S ~A conflicts with an enclosing assertion:~% ~S"
- (type-specifier atype)
- place
- (type-specifier old-atype)))
- (make-lexenv :type-restrictions `((,cont . ,new-atype))
- :weakend-type-restrictions `((,cont . ,new-ctype))
- :default lexenv)))
+;;; A logic shared among THE and TRULY-THE.
+(defun the-in-policy (type value policy start next result)
+ (let ((type (if (ctype-p type) type
+ (compiler-values-specifier-type type))))
+ (cond ((or (eq type *wild-type*)
+ (eq type *universal-type*)
+ (and (leaf-p value)
+ (values-subtypep (make-single-value-type (leaf-type value))
+ type))
+ (and (sb!xc:constantp value)
+ (ctypep (constant-form-value value)
+ (single-value-type type))))
+ (ir1-convert start next result value))
+ (t (let ((value-ctran (make-ctran))
+ (value-lvar (make-lvar)))
+ (ir1-convert start value-ctran value-lvar value)
+ (let ((cast (make-cast value-lvar type policy)))
+ (link-node-to-previous-ctran cast value-ctran)
+ (setf (lvar-dest value-lvar) cast)
+ (use-continuation cast next result)))))))