1.0.19.7: refactor stack allocation decisions

[sbcl.git] / src / code / defboot.lisp

diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp
index ddd6355..232802f 100644 (file)
--- a/src/code/defboot.lisp
+++ b/src/code/defboot.lisp
@@ -573,31 +573,27 @@ evaluated as a PROGN."
   (let* ((local-funs nil)
          (mapped-bindings (mapcar (lambda (binding)
                                     (destructuring-bind (type handler) binding
-                                      (let (lambda-form)
+                                      (let ((lambda-form handler))
                                         (if (and (consp handler)
-                                                 (or (prog1 (eq 'lambda (car handler))
-                                                       (setf lambda-form handler))
+                                                 (or (eq 'lambda (car handler))
                                                      (and (eq 'function (car handler))
                                                           (consp (cdr handler))
-                                                          (consp (cadr handler))
-                                                          (prog1 (eq 'lambda (caadr handler))
-                                                            (setf lambda-form (cadr handler)))))
-                                                 ;; KLUDGE: DX-FLET doesn't handle non-required arguments yet.
-                                                 (not (intersection (second lambda-form) sb!xc:lambda-list-keywords)))
+                                                          (let ((x (second handler)))
+                                                            (and (consp x)
+                                                                 (eq 'lambda (car x))
+                                                                 (setf lambda-form x))))))
                                             (let ((name (gensym "LAMBDA")))
                                               (push `(,name ,@(cdr lambda-form)) local-funs)
                                               (list type `(function ,name)))
                                             binding))))
-                                  bindings))
-         (form-fun (gensym "FORM-FUN")))
-    `(dx-flet (,@(reverse local-funs)
-               (,form-fun () (progn ,form)))
+                                  bindings)))
+    `(dx-flet (,@(reverse local-funs))
        (let ((*handler-clusters*
               (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x)))
                                     mapped-bindings))
                     *handler-clusters*)))
-         (declare (dynamic-extent *handler-clusters*))
-         (,form-fun)))))
+         (declare (truly-dynamic-extent *handler-clusters*))
+         (progn ,form)))))
 
 (defmacro-mundanely handler-bind (bindings &body forms)
   #!+sb-doc