X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=776d2790d32d78bda8372294ca54c8eaaf88c975;hb=435b7acd186484b1eed5ab615c43bcc1701fcd6c;hp=5343ea75cc5f00e5e4bca2c6766471f8336432cc;hpb=a260738d7a71680079d972b102b4e4db4e8dc3ae;p=sbcl.git

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 5343ea7..776d279 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -330,11 +330,18 @@
     (push node-block (block-pred block))
     (add-continuation-use node cont)
     (unless (eq (continuation-asserted-type cont) *wild-type*)
-      (let ((new (values-type-union (continuation-asserted-type cont)
-				    (or (lexenv-find cont type-restrictions)
-					*wild-type*))))
-	(when (type/= new (continuation-asserted-type cont))
-	  (setf (continuation-asserted-type cont) new)
+      (let* ((restriction (or (lexenv-find cont type-restrictions)
+                              *wild-type*))
+             (wrestriction (or (lexenv-find cont weakend-type-restrictions)
+                               *wild-type*))
+             (newatype (values-type-union (continuation-asserted-type cont)
+                                          restriction))
+             (newctype (values-type-union (continuation-type-to-check cont)
+                                          wrestriction)))
+	(when (or (type/= newatype (continuation-asserted-type cont))
+                  (type/= newctype (continuation-type-to-check cont)))
+	  (setf (continuation-asserted-type cont) newatype)
+          (setf (continuation-type-to-check cont) newctype)
 	  (reoptimize-continuation cont))))))
 
 ;;;; exported functions
@@ -747,7 +754,8 @@
   (let ((node (make-combination fun-cont)))
     (setf (continuation-dest fun-cont) node)
     (assert-continuation-type fun-cont
-			      (specifier-type '(or function symbol)))
+			      (specifier-type '(or function symbol))
+                              (lexenv-policy *lexenv*))
     (setf (continuation-%externally-checkable-type fun-cont) nil)
     (collect ((arg-conts))
       (let ((this-start fun-cont))
@@ -1652,7 +1660,8 @@
                                       (setq ,n-value ,n-value-temp))))))
 		(when (and (not allowp) (eq keyword :allow-other-keys))
                   (setq found-allow-p t)
-                  (setq clause (append clause `((setq ,n-allowp ,n-value-temp)))))
+                  (setq clause
+			(append clause `((setq ,n-allowp ,n-value-temp)))))
 
                 (temps `(,n-value ,default))
 		(tests clause)))