X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fparse-defmacro.lisp;h=f745a8425eff8505842f2f3b6b1ce3443b7650aa;hb=5f0cfcf9095f2d8dbca4ddf703c580a36d5c3709;hp=48576799bb5dae3ce8dfab57388e79fd9c0d5876;hpb=deac413eadea2935f356eebfc8f6b01b6367d260;p=sbcl.git

diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp
index 4857679..f745a84 100644
--- a/src/code/parse-defmacro.lisp
+++ b/src/code/parse-defmacro.lisp
@@ -328,7 +328,8 @@
           (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
@@ -342,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
@@ -407,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)))
@@ -417,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)))