X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fparse-defmacro.lisp;h=f745a8425eff8505842f2f3b6b1ce3443b7650aa;hb=6242b9f8336fee3c0b0e473efb414e39ed3b92c7;hp=fe30d12fd5069cd81e6b64619faff118608da98d;hpb=cd08dc8fd4d4b77fdbe87addb06e97cde247bbf9;p=sbcl.git

diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp
index fe30d12..f745a84 100644
--- a/src/code/parse-defmacro.lisp
+++ b/src/code/parse-defmacro.lisp
@@ -39,6 +39,9 @@
                        ((:default-default *default-default*))
                        (error-fun 'error)
                        (wrap-block t))
+  (unless (listp lambda-list)
+    (bad-type lambda-list 'list "~S lambda-list is not a list: ~S"
+              context lambda-list))
   (multiple-value-bind (forms declarations documentation)
       (parse-body body :doc-string-allowed doc-string-allowed)
     (let ((*arg-tests* ())
@@ -51,6 +54,8 @@
                                       :error-fun error-fun
                                       :anonymousp anonymousp)
         (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*
@@ -91,7 +96,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 +111,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))
@@ -319,12 +324,12 @@
                                          :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
-                                      ',allow-other-keys-p)
+                                      ',allow-other-keys-p
+                                      ,(eq 'define-compiler-macro context))
                    (when ,problem
                      (,error-fun
                       'defmacro-lambda-list-broken-key-list-error
@@ -338,7 +343,7 @@
 ;;; We save space in macro definitions by calling this function.
 (defun arg-count-error (context name args lambda-list minimum maximum)
   (let (#-sb-xc-host
-        (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
+        (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'arg-count-error)))
     (error 'arg-count-error
            :kind context
            :name name
@@ -403,7 +408,7 @@
 ;;; Determine whether KEY-LIST is a valid list of keyword/value pairs.
 ;;; Do not signal the error directly, 'cause we don't know how it
 ;;; should be signaled.
-(defun verify-keywords (key-list valid-keys allow-other-keys)
+(defun verify-keywords (key-list valid-keys allow-other-keys &optional compiler-macro)
   (do ((already-processed nil)
        (unknown-keyword nil)
        (remaining key-list (cddr remaining)))
@@ -413,15 +418,30 @@
                 (not (lookup-keyword :allow-other-keys key-list)))
            (values :unknown-keyword (list unknown-keyword valid-keys))
            (values nil nil)))
-    (cond ((not (and (consp remaining) (listp (cdr remaining))))
-           (return (values :dotted-list key-list)))
-          ((null (cdr remaining))
-           (return (values :odd-length key-list)))
-          ((or (eq (car remaining) :allow-other-keys)
-               (member (car remaining) valid-keys))
-           (push (car remaining) already-processed))
-          (t
-           (setq unknown-keyword (car remaining))))))
+    (let ((key (when (consp remaining)
+                 (car remaining))))
+      (cond ((not (and (consp remaining) (listp (cdr remaining))))
+             (return (values :dotted-list key-list)))
+            ((null (cdr remaining))
+             (return (values :odd-length key-list))))
+      ;; Compiler-macro lambda lists are macro lambda lists -- meaning that
+      ;; &key ((a a) t) should match a literal A, not a form evaluating to A
+      ;; as in an ordinary lambda list.
+      ;;
+      ;; That, however, breaks the evaluation model unless A is also a
+      ;; constant evaluating to itself. So, signal a condition telling the
+      ;; compiler to punt on the expansion.
+      (when (and compiler-macro
+                 (not (or (keywordp key)
+                          (and (symbolp key)
+                               (constantp key)
+                               (eq key (symbol-value key))))))
+        (signal 'compiler-macro-keyword-problem :argument key))
+      (cond ((or (eq key :allow-other-keys)
+                 (member key valid-keys))
+             (push key already-processed))
+            (t
+             (setq unknown-keyword key))))))
 
 (defun lookup-keyword (keyword key-list)
   (do ((remaining key-list (cddr remaining)))