X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fparse-defmacro.lisp;h=0058522b7d4cf8e3f3eb4324e40f6b123c074627;hb=7306e23c5a4687bef98fdfb3459aaf15fe79d5ca;hp=225c2f726cbbccb3f5c2696405aed64ef3fd4d64;hpb=8bcffb407835ff680d5ee2ba1f7ce97839bbae3e;p=sbcl.git

diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp
index 225c2f7..0058522 100644
--- a/src/code/parse-defmacro.lisp
+++ b/src/code/parse-defmacro.lisp
@@ -50,13 +50,15 @@
           (parse-defmacro-lambda-list lambda-list whole-var name context
                                       :error-fun error-fun
                                       :anonymousp anonymousp)
-        (values `(let* (,@(when env-arg-used
-                            `((,*env-var* ,env-arg-name)))
-                        ,@(nreverse *system-lets*))
+        (values `(let* (,@(nreverse *system-lets*))
+                   #-sb-xc-host
+                   (declare (muffle-conditions sb!ext:code-deletion-note))
                    ,@(when *ignorable-vars*
                        `((declare (ignorable ,@*ignorable-vars*))))
                    ,@*arg-tests*
-                   (let* ,(nreverse *user-lets*)
+                   (let* (,@(when env-arg-used
+                            `((,*env-var* ,env-arg-name)))
+                          ,@(nreverse *user-lets*))
                      ,@declarations
                      ,@(if wrap-block
                            `((block ,(fun-name-block-name name)
@@ -91,7 +93,7 @@
          (aux-seen nil)
          (optional-seen nil)
          ;; ANSI specifies that dotted lists are "treated exactly as if the
-         ;; parameter name that ends the list had appeared preceded by &rest."
+         ;; parameter name that ends the list had appeared preceded by &REST."
          ;; We force this behavior by transforming dotted lists into ordinary
          ;; lists with explicit &REST elements.
          (lambda-list (do ((in-pdll possibly-dotted-lambda-list (cdr in-pdll))
@@ -106,14 +108,14 @@
       (error "&WHOLE may only appear first in ~S lambda-list." context))
     ;; Special case compiler-macros: if car of the form is FUNCALL,
     ;; skip over it for destructuring, pretending cdr of the form is
-    ;; the actual form. Save original for &whole
-    (when (eq context 'define-compiler-macro)
+    ;; the actual form. Save original for &WHOLE.
+    (when (and (not sublist) (eq context 'define-compiler-macro))
       (push-let-binding compiler-macro-whole whole-var :system t)
       (push compiler-macro-whole *ignorable-vars*)
       (push-let-binding whole-var whole-var
                         :system t
                         :when `(not (eq 'funcall (car ,whole-var)))
-                        ;; do we need to SETF too?
+                        ;; Do we need to SETF too?
                         :else `(setf ,whole-var (cdr ,whole-var))))
     (do ((rest-of-lambda-list lambda-list (cdr rest-of-lambda-list)))
         ((null rest-of-lambda-list))
@@ -140,7 +142,10 @@
                   (defmacro-error (format nil "required argument after ~A"
                                           restp)
                       context name))
-                (process-sublist var "REQUIRED-" `(car ,path))
+                (when (process-sublist var "REQUIRED-" `(car ,path))
+                  ;; Note &ENVIRONMENT from DEFSETF sublist
+                  (aver (eq context 'defsetf))
+                  (setf env-arg-used t))
                 (setq path `(cdr ,path)
                       minimum (1+ minimum)
                       maximum (1+ maximum)))
@@ -195,7 +200,9 @@
                (&environment
                 (cond (env-illegal
                        (error "&ENVIRONMENT is not valid with ~S." context))
-                      (sublist
+                      ;; DEFSETF explicitly allows &ENVIRONMENT, and we get
+                      ;; it here in a sublist.
+                      ((and sublist (neq context 'defsetf))
                        (error "&ENVIRONMENT is only valid at top level of ~
                              lambda-list."))
                       (env-arg-used
@@ -246,6 +253,8 @@
                   (error "Multiple ~A in ~A lambda-list." var context))
                 (setq allow-other-keys-p t))
                (&aux
+                (when (eq context 'defsetf)
+                  (error "~A not allowed in a ~A lambda-list." var context))
                 (when aux-seen
                   (error "Multiple ~A in ~A lambda-list." '&aux context))
                 (setq now-processing :auxs
@@ -312,8 +321,7 @@
                                          :maximum ,explicit-maximum))))))
               *arg-tests*))
       (when key-seen
-        (let ((problem (gensym "KEY-PROBLEM-"))
-              (info (gensym "INFO-")))
+        (with-unique-names (problem info)
           (push `(multiple-value-bind (,problem ,info)
                      (verify-keywords ,rest-name
                                       ',keys