0.7.9.67:

[sbcl.git] / src / compiler / ir1tran.lisp

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 265034e..776d279 100644 (file)
--- 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))))))
 \f
 ;;;; exported functions
@@ -657,27 +664,12 @@
                ;; or the cross-compiler which encountered the problem?"
                #+sb-xc-host "(in cross-compiler macroexpansion of ~S)"
                form))))
-      (handler-bind (;; When cross-compiling, we can get style warnings
-                     ;; about e.g. undefined functions. An unhandled
-                     ;; CL:STYLE-WARNING (as opposed to a
-                     ;; SB!C::COMPILER-NOTE) would cause FAILURE-P to be
-                     ;; set on the return from #'SB!XC:COMPILE-FILE, which
-                     ;; would falsely indicate an error sufficiently
-                     ;; serious that we should stop the build process. To
-                     ;; avoid this, we translate CL:STYLE-WARNING
-                     ;; conditions from the host Common Lisp into
-                     ;; cross-compiler SB!C::COMPILER-NOTE calls. (It
-                     ;; might be cleaner to just make Python use
-                     ;; CL:STYLE-WARNING internally, so that the
-                     ;; significance of any host Common Lisp
-                     ;; CL:STYLE-WARNINGs is understood automatically. But
-                     ;; for now I'm not motivated to do this. -- WHN
-                     ;; 19990412)
-                     (style-warning (lambda (c)
-                                      (compiler-note "~@<~A~:@_~A~:@_~A~:>"
-                                                    (wherestring) hint c)
-                                      (muffle-warning-or-die)))
-                     ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for
+      (handler-bind ((style-warning (lambda (c)
+                                     (compiler-style-warn
+                                      "~@<~A~:@_~A~@:_~A~:>"
+                                      (wherestring) hint c)
+                                     (muffle-warning-or-die)))
+                    ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for
                      ;; Debian Linux, anyway) raises a CL:WARNING
                      ;; condition (not a CL:STYLE-WARNING) for undefined
                      ;; symbols when converting interpreted functions,
@@ -692,7 +684,7 @@
                      ;; and this code does so, by crudely suppressing all
                      ;; warnings in cross-compilation macroexpansion. --
                      ;; WHN 19990412
-                     #+cmu
+                     #+(and cmu sb-xc-host)
                      (warning (lambda (c)
                                 (compiler-note
                                  "~@<~A~:@_~
@@ -709,6 +701,11 @@
                                  (wherestring)
                                  c)
                                 (muffle-warning-or-die)))
+                    #-(and cmu sb-xc-host)
+                    (warning (lambda (c)
+                               (compiler-warn "~@<~A~:@_~A~@:_~A~:>"
+                                              (wherestring) hint c)
+                               (muffle-warning-or-die)))
                      (error (lambda (c)
                               (compiler-error "~@<~A~:@_~A~@:_~A~:>"
                                               (wherestring) hint c))))
@@ -757,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))
@@ -1662,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)))