X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fparse-defmacro.lisp;h=94f8325720b91dac16fc8632e074d835d8dccb62;hb=c3699db2053ff3b5ac6a98d4431c3789496002d8;hp=46182148ad9dee43d7de02eaf5cd137222e34002;hpb=1b7fde9126d21b01f0d5359027242f8b5acdf9f8;p=sbcl.git

diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp
index 4618214..94f8325 100644
--- 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)