0.8.2.8:

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

diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index c57459a..d55bdeb 100644 (file)
--- a/src/compiler/ir1tran-lambda.lisp
+++ b/src/compiler/ir1tran-lambda.lisp
@@ -47,7 +47,7 @@
 
 ;;; Make the default keyword for a &KEY arg, checking that the keyword
 ;;; isn't already used by one of the VARS.
-(declaim (ftype (sfunction (symbol list t) keyword) make-keyword-for-arg))
+(declaim (ftype (sfunction (symbol list t) symbol) make-keyword-for-arg))
 (defun make-keyword-for-arg (symbol vars keywordify)
   (let ((key (if (and keywordify (not (keywordp symbol)))
                 (keywordicate symbol)
@@ -285,13 +285,11 @@
 
   (let* ((bind (make-bind))
         (lambda (make-lambda :vars vars
-                             :bind bind
-                             :%source-name source-name
-                             :%debug-name debug-name))
+                  :bind bind
+                  :%source-name source-name
+                  :%debug-name debug-name))
         (result (or result (make-continuation))))
 
-    (continuation-starts-block result)
-
     ;; just to check: This function should fail internal assertions if
     ;; we didn't set up a valid debug name above.
     ;;
@@ -302,7 +300,7 @@
 
     (setf (lambda-home lambda) lambda)
     (collect ((svars)
-             (new-venv nil cons))
+             (new-venv nil cons))
 
       (dolist (var vars)
        ;; As far as I can see, LAMBDA-VAR-HOME should never have
@@ -324,27 +322,28 @@
        (setf (bind-lambda bind) lambda)
        (setf (node-lexenv bind) *lexenv*)
 
-       (let ((cont1 (make-continuation))
-             (cont2 (make-continuation)))
-         (continuation-starts-block cont1)
-         (link-node-to-previous-continuation bind cont1)
-         (use-continuation bind cont2)
-         (ir1-convert-special-bindings cont2 result body
-                                       aux-vars aux-vals (svars)))
-
-       (let ((block (continuation-block result)))
-         (when block
-           (let ((return (make-return :result result :lambda lambda))
-                 (tail-set (make-tail-set :funs (list lambda)))
-                 (dummy (make-continuation)))
-             (setf (lambda-tail-set lambda) tail-set)
-             (setf (lambda-return lambda) return)
-             (setf (continuation-dest result) return)
-              (flush-continuation-externally-checkable-type result)
-             (setf (block-last block) return)
-             (link-node-to-previous-continuation return result)
-             (use-continuation return dummy))
-           (link-blocks block (component-tail *current-component*))))))
+       (let ((block (continuation-starts-block result)))
+         (let ((return (make-return :result result :lambda lambda))
+                (tail-set (make-tail-set :funs (list lambda)))
+                (dummy (make-continuation)))
+            (setf (lambda-tail-set lambda) tail-set)
+            (setf (lambda-return lambda) return)
+            (setf (continuation-dest result) return)
+            (flush-continuation-externally-checkable-type result)
+            (setf (block-last block) return)
+            (link-node-to-previous-continuation return result)
+            (use-continuation return dummy))
+          (link-blocks block (component-tail *current-component*)))
+
+        (with-component-last-block (*current-component*
+                                    (continuation-block result))
+          (let ((cont1 (make-continuation))
+                (cont2 (make-continuation)))
+            (continuation-starts-block cont1)
+            (link-node-to-previous-continuation bind cont1)
+            (use-continuation bind cont2)
+            (ir1-convert-special-bindings cont2 result body
+                                          aux-vars aux-vals (svars))))))
 
     (link-blocks (component-head *current-component*) (node-block bind))
     (push lambda (component-new-functionals *current-component*))
@@ -869,7 +868,7 @@
                                        (append aux-vars vars)
                                        nil result-cont))
               (forms (if (and *allow-debug-catch-tag*
-                              (policy *lexenv* (> debug (max speed space))))
+                              (policy *lexenv* (= insert-debug-catch 3)))
                          `((catch (make-symbol "SB-DEBUG-CATCH-TAG")
                              ,@forms))
                          forms))
@@ -995,7 +994,7 @@
      ;; compilation unit, so we can't do that. -- WHN 2001-02-11
      :lossage-fun #'compiler-style-warn
      :unwinnage-fun (cond (info #'compiler-style-warn)
-                         (for-real #'compiler-note)
+                         (for-real #'compiler-notify)
                          (t nil))
      :really-assert
      (and for-real