X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir1-translators.lisp;h=8c11111fc10fb935a8ca1161facfc8529330a770;hb=96b310113978665980a8d65ad5dd83deab05c28b;hp=809d384dbdc28f28c9d108b5381234d8dd29abcd;hpb=24bc431a3403af05c5df601d09c0d0c27cb500b2;p=sbcl.git

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index 809d384..8c11111 100644
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -718,14 +718,13 @@
 ;;; 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 name)
+(defun ir1ize-the-or-values (type cont lexenv place)
   (declare (type continuation cont) (type lexenv lexenv))
-  (let* ((ctype (values-specifier-type type))
+  (let* ((ctype (if (typep type 'ctype) type (compiler-values-specifier-type type)))
 	 (old-type (or (lexenv-find cont type-restrictions)
 		       *wild-type*))
 	 (intersects (values-types-equal-or-intersect old-type ctype))
-	 (int (values-type-intersection old-type ctype))
-	 (new (if intersects int old-type)))
+	 (new (values-type-intersection old-type ctype)))
     (when (null (find-uses cont))
       (setf (continuation-asserted-type cont) new))
     (when (and (not intersects)
@@ -734,10 +733,9 @@
 	       (not (policy *lexenv*
 			    (= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
       (compiler-warn
-       "The type ~S in ~S declaration conflicts with an ~
-        enclosing assertion:~%   ~S"
+       "The type ~S ~A conflicts with an enclosing assertion:~%   ~S"
        (type-specifier ctype)
-       name
+       place
        (type-specifier old-type)))
     (make-lexenv :type-restrictions `((,cont . ,new))
 		 :default lexenv)))
@@ -749,7 +747,8 @@
 ;;; this didn't seem to expand into an assertion, at least for ALIEN
 ;;; values. Check that SBCL doesn't have this problem.
 (def-ir1-translator the ((type value) start cont)
-  (let ((*lexenv* (ir1ize-the-or-values type cont *lexenv* 'the)))
+  (with-continuation-type-assertion (cont (compiler-values-specifier-type type)
+                                          "in THE declaration")
     (ir1-convert start cont value)))
 
 ;;; This is like the THE special form, except that it believes
@@ -763,7 +762,7 @@
 (def-ir1-translator truly-the ((type value) start cont)
   #!+sb-doc
   (declare (inline member))
-  (let ((type (values-specifier-type type))
+  (let ((type (compiler-values-specifier-type type))
 	(old (find-uses cont)))
     (ir1-convert start cont value)
     (do-uses (use cont)
@@ -1011,7 +1010,10 @@
     (continuation-starts-block dummy-start)
     (ir1-convert start dummy-start result)
 
-    (substitute-continuation-uses cont dummy-start)
+    (with-continuation-type-assertion
+        (cont (continuation-asserted-type dummy-start)
+              "of the first form")
+      (substitute-continuation-uses cont dummy-start))
 
     (continuation-starts-block dummy-result)
     (ir1-convert-progn-body dummy-start dummy-result forms)