0.8.6.28:

[sbcl.git] / src / code / parse-defmacro.lisp

diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp
index 4618214..94f8325 100644 (file)
--- a/src/code/parse-defmacro.lisp
+++ b/src/code/parse-defmacro.lisp
@@ -28,7 +28,7 @@
 (defvar *ignorable-vars*)
 (declaim (type list *ignorable-vars*))
 
-;;; Return, as multiple values, a body, possibly a declare form to put
+;;; Return, as multiple values, a body, possibly a DECLARE form to put
 ;;; where this code is inserted, the documentation for the parsed
 ;;; body, and bounds on the number of arguments.
 (defun parse-defmacro (lambda-list arg-list-name body name error-kind
@@ -37,9 +37,10 @@
                                   (doc-string-allowed t)
                                   ((:environment env-arg-name))
                                   ((:default-default *default-default*))
-                                  (error-fun 'error))
+                                  (error-fun 'error)
+                                   (wrap-block t))
   (multiple-value-bind (forms declarations documentation)
-      (parse-body body doc-string-allowed)
+      (parse-body body :doc-string-allowed doc-string-allowed)
     (let ((*arg-tests* ())
          (*user-lets* ())
          (*system-lets* ())
@@ -57,7 +58,10 @@
                   ,@*arg-tests*
                   (let* ,(nreverse *user-lets*)
                     ,@declarations
-                    ,@forms))
+                     ,@(if wrap-block
+                           `((block ,(fun-name-block-name name)
+                               ,@forms))
+                           forms)))
                `(,@(when (and env-arg-name (not env-arg-used))
                       `((declare (ignore ,env-arg-name)))))
                documentation
@@ -106,7 +110,7 @@
        ((null rest-of-args))
       (macrolet ((process-sublist (var sublist-name path)
                    (once-only ((var var))
-                     `(if (consp ,var)
+                     `(if (listp ,var)
                           (let ((sub-list-name (gensym ,sublist-name)))
                             (push-sub-list-binding sub-list-name ,path ,var
                                                    name error-kind error-fun)