X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran-lambda.lisp;h=d55bdebd740730b9468e3da4c4f6db068d710ad3;hb=506253505641855dc8bb87033f7af894904f848b;hp=c57459a93d82d38cfbc8ef55173514e5e22df2db;hpb=16f848f33e91035457132f704448d2d23c34724e;p=sbcl.git

diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index c57459a..d55bdeb 100644
--- 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