0.7.1.19:

[sbcl.git] / src / code / parse-defmacro.lisp

diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp
index eb9efae..a4eb1bc 100644 (file)
--- a/src/code/parse-defmacro.lisp
+++ b/src/code/parse-defmacro.lisp
@@ -11,9 +11,6 @@
 
 (in-package "SB!KERNEL")
 
-(file-comment
- "$Header$")
-
 ;;; 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
@@ -23,16 +20,16 @@
 (defvar *user-lets* nil) ; LET bindings that the user has explicitly supplied
 (declaim (type list *user-lets*))
 
-;; the default default for unsupplied optional and keyword args
+;; the default default for unsupplied &OPTIONAL and &KEY args
 (defvar *default-default* nil)
 
 ;;; 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 where
-;;; this code is inserted, the documentation for the parsed body, and bounds
-;;; on the number of arguments.
+;;; 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
                                   &key
                                   (anonymousp nil)
@@ -64,7 +61,7 @@
                maximum)))))
 
 ;;; partial reverse-engineered documentation:
-;;;   TOP-LEVEL is true for calls through PARSE-DEFMACRO from DEFSETF and
+;;;   TOPLEVEL is true for calls through PARSE-DEFMACRO from DEFSETF and
 ;;;     DESTRUCTURING-BIND, false otherwise.
 ;;; -- WHN 19990620
 (defun parse-defmacro-lambda-list (possibly-dotted-lambda-list
@@ -73,13 +70,13 @@
                                   error-kind
                                   error-fun
                                   &optional
-                                  top-level
+                                  toplevel
                                   env-illegal
                                   env-arg-name)
   (let* (;; PATH is a sort of pointer into the part of the lambda list we're
         ;; considering at this point in the code. PATH-0 is the root of the
         ;; lambda list, which is the initial value of PATH.
-        (path-0 (if top-level
+        (path-0 (if toplevel
                   `(cdr ,arg-list-name)
                   arg-list-name))
         (path path-0) ; (will change below)
@@ -113,7 +110,7 @@
              ((eq var '&environment)
               (cond (env-illegal
                      (error "&ENVIRONMENT is not valid with ~S." error-kind))
-                    ((not top-level)
+                    ((not toplevel)
                      (error "&ENVIRONMENT is only valid at top level of ~
                              lambda-list.")))
               (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
@@ -154,14 +151,11 @@
                        minimum (1+ minimum)
                        maximum (1+ maximum)))
                 ((eq now-processing :optionals)
-                 (when (> (length var) 3)
-                   (cerror "Ignore extra noise."
-                           "more than variable, initform, and suppliedp ~
-                           in &optional binding: ~S"
-                           var))
-                 (push-optional-binding (car var) (cadr var) (caddr var)
-                                        `(not (null ,path)) `(car ,path)
-                                        name error-kind error-fun)
+                 (destructuring-bind (varname &optional initform supplied-p)
+                     var
+                   (push-optional-binding varname initform supplied-p
+                                          `(not (null ,path)) `(car ,path)
+                                          name error-kind error-fun))
                  (setq path `(cdr ,path)
                        maximum (1+ maximum)))
                 ((eq now-processing :keywords)
@@ -212,13 +206,13 @@
                        `(list-of-length-at-least-p ,path-0 ,minimum)
                        `(proper-list-of-length-p ,path-0 ,minimum ,maximum))
             ,(if (eq error-fun 'error)
-                 `(do-arg-count-error ',error-kind ',name ,path-0
-                                      ',lambda-list ,minimum
-                                      ,(unless restp maximum))
-                 `(,error-fun 'defmacro-ll-arg-count-error
+                 `(arg-count-error ',error-kind ',name ,path-0
+                                   ',lambda-list ,minimum
+                                   ,(unless restp maximum))
+                 `(,error-fun 'arg-count-error
                               :kind ',error-kind
                               ,@(when name `(:name ',name))
-                              :argument ,path-0
+                              :args ,path-0
                               :lambda-list ',lambda-list
                               :minimum ,minimum
                               ,@(unless restp
@@ -278,14 +272,15 @@
        ((symbolp value-var)
         (push-let-binding value-var path nil supplied-var init-form))
        (t
-        (error "Illegal optional variable name: ~S" value-var))))
+        (error "illegal optional variable name: ~S" value-var))))
 
 (defun defmacro-error (problem kind name)
-  (error "Illegal or ill-formed ~A argument in ~A~@[ ~S~]."
+  (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]"
         problem kind name))
 
-;;; 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.
+;;; 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)
   (do ((already-processed nil)
        (unknown-keyword nil)
@@ -300,8 +295,6 @@
           (return (values :dotted-list key-list)))
          ((null (cdr remaining))
           (return (values :odd-length key-list)))
-         ((member (car remaining) already-processed)
-          (return (values :duplicate (car remaining))))
          ((or (eq (car remaining) :allow-other-keys)
               (member (car remaining) valid-keys))
           (push (car remaining) already-processed))