X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fparse-defmacro.lisp;h=af0c7baf13a0701ede0b732f5bd9feada2cba3d8;hb=8b64d57b865fec6ba082dda965146b5e8aa877b3;hp=dada4f516132db7effc88cc9975c64ac2ef1471b;hpb=21083e7372a447498dacd3f92427c1e9da7e074a;p=sbcl.git

diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp
index dada4f5..af0c7ba 100644
--- a/src/code/parse-defmacro.lisp
+++ b/src/code/parse-defmacro.lisp
@@ -13,22 +13,22 @@
 
 ;;; variables for accumulating the results of parsing a DEFMACRO. (Declarations
 ;;; in DEFMACRO are the reason this isn't as easy as it sounds.)
-(defvar *arg-tests* nil) ; tests that do argument counting at expansion time
+(defvar *arg-tests*) ; tests that do argument counting at expansion time
 (declaim (type list *arg-tests*))
-(defvar *system-lets* nil) ; LET bindings done to allow lambda-list parsing
+(defvar *system-lets*) ; LET bindings done to allow lambda-list parsing
 (declaim (type list *system-lets*))
-(defvar *user-lets* nil) ; LET bindings that the user has explicitly supplied
+(defvar *user-lets*) ; LET bindings that the user has explicitly supplied
 (declaim (type list *user-lets*))
-(defvar *env-var* nil) ; &ENVIRONMENT variable name
+(defvar *env-var*) ; &ENVIRONMENT variable name
 
 ;; the default default for unsupplied &OPTIONAL and &KEY args
-(defvar *default-default* nil)
+(defvar *default-default*)
 
 ;;; temps that we introduce and might not reference
 (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
@@ -87,6 +91,7 @@
 	 (maximum 0)
 	 (minimum 0)
 	 (keys ())
+	 (key-seen nil)
 	 ;; ANSI specifies that dotted lists are "treated exactly as if the
 	 ;; parameter name that ends the list had appeared preceded by &rest."
 	 ;; We force this behavior by transforming dotted lists into ordinary
@@ -105,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)
@@ -188,6 +193,7 @@
                 (setq rest-name (gensym "KEYWORDS-"))
                 (push rest-name *ignorable-vars*)
                 (setq restp t)
+		(setq key-seen t)
                 (push-let-binding rest-name path t))
                (&allow-other-keys
                 (setq allow-other-keys-p t))
@@ -242,7 +248,7 @@
                                    :minimum ,minimum
                                    :maximum ,explicit-maximum)))
               *arg-tests*))
-      (when keys
+      (when key-seen
 	(let ((problem (gensym "KEY-PROBLEM-"))
 	      (info (gensym "INFO-")))
 	  (push `(multiple-value-bind (,problem ,info)