X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=17b51eed25a6fc43aef71e220437a375c6d6f16f;hb=22c1de0a40df83bb5628974010a879cb2c17ff53;hp=5e6162479e65af8adba667ecf33aaf953c457159;hpb=6a756846fe0fe89835ec5eb68327b612c93f82c4;p=sbcl.git

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 5e61624..17b51ee 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -279,7 +279,7 @@
 (defun constrain-float-type (x y greater or-equal)
   (declare (type numeric-type x y))
   (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
-  
+
   (aver (eql (numeric-type-class x) 'float))
   (aver (eql (numeric-type-class y) 'float))
   #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
@@ -378,13 +378,14 @@
       (let* ((cont (node-cont ref))
 	     (dest (continuation-dest cont)))
 	(cond ((and (if-p dest)
-		    (csubtypep (specifier-type 'null) not-res)
-		    (eq (continuation-asserted-type cont) *wild-type*))
+		    (csubtypep (specifier-type 'null) not-res))
 	       (setf (node-derived-type ref) *wild-type*)
 	       (change-ref-leaf ref (find-constant t)))
 	      (t
-	       (derive-node-type ref (or (type-difference res not-res)
-					 res)))))))
+	       (derive-node-type ref
+                                 (make-single-value-type
+                                  (or (type-difference res not-res)
+                                      res))))))))
 
   (values))
 
@@ -429,10 +430,11 @@
          (when var
            (when ref-preprocessor
              (funcall ref-preprocessor node gen))
-           (when (continuation-type-check cont)
-             (let* ((atype (continuation-derived-type cont))
-                    (con (find-constraint 'typep var atype nil)))
-               (sset-adjoin con gen))))))
+           (let ((dest (continuation-dest cont)))
+             (when (cast-p dest)
+               (let* ((atype (single-value-type (cast-derived-type dest))) ; FIXME
+                      (con (find-constraint 'typep var atype nil)))
+                 (sset-adjoin con gen)))))))
       (cset
        (let ((var (set-var node)))
          (when (lambda-var-p var)
@@ -441,7 +443,7 @@
            (let ((cons (lambda-var-constraints var)))
              (when cons
                (sset-difference gen cons)
-               (let* ((type (node-derived-type node))
+               (let* ((type (single-value-type (node-derived-type node)))
                       (con (find-constraint 'typep var type nil)))
                  (sset-adjoin con gen)))))))))