- (error "&WHOLE may only appear first in ~S lambda-list." error-kind))
- (do ((rest-of-args lambda-list (cdr rest-of-args)))
- ((null rest-of-args))
- (let ((var (car rest-of-args)))
- (cond ((eq var '&whole)
- (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
- (setq rest-of-args (cdr rest-of-args))
- (push-let-binding (car rest-of-args) arg-list-name nil))
- (t
- (defmacro-error "&WHOLE" error-kind name))))
- ((eq var '&environment)
- (cond (env-illegal
- (error "&ENVIRONMENT is not valid with ~S." error-kind))
- ((not toplevel)
- (error "&ENVIRONMENT is only valid at top level of ~
- lambda-list.")))
- (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
- (setq rest-of-args (cdr rest-of-args))
- (push-let-binding (car rest-of-args) env-arg-name nil)
- (setq env-arg-used t))
- (t
- (defmacro-error "&ENVIRONMENT" error-kind name))))
- ((or (eq var '&rest)
- (eq var '&body))
- (cond (restp
- (defmacro-error (symbol-name var) error-kind name))
- ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
- (setq rest-of-args (cdr rest-of-args))
- (setq restp t)
- (push-let-binding (car rest-of-args) path nil))
- (t
- (defmacro-error (symbol-name var) error-kind name))))
- ((eq var '&optional)
- (setq now-processing :optionals))
- ((eq var '&key)
- (setq now-processing :keywords)
- (setq rest-name (gensym "KEYWORDS-"))
- (push rest-name *ignorable-vars*)
- (setq restp t)
- (push-let-binding rest-name path t))
- ((eq var '&allow-other-keys)
- (setq allow-other-keys-p t))
- ((eq var '&aux)
- (setq now-processing :auxs))
- ((listp var)
- (case now-processing
- ((:required)
- (when restp
- (defmacro-error "required argument after &REST/&BODY" error-kind name))
- (let ((sub-list-name (gensym "SUBLIST-")))
- (push-sub-list-binding sub-list-name `(car ,path) var
- name error-kind error-fun)
- (parse-defmacro-lambda-list var sub-list-name name
- error-kind error-fun))
- (setq path `(cdr ,path)
- minimum (1+ minimum)
- maximum (1+ maximum)))
- ((:optionals)
- (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)))
- ((:keywords)
- (let* ((keyword-given (consp (car var)))
- (variable (if keyword-given
- (cadar var)
- (car var)))
- (keyword (if keyword-given
- (caar var)
- (keywordicate variable)))
- (supplied-p (caddr var)))
- (push-optional-binding variable (cadr var) supplied-p
- `(keyword-supplied-p ',keyword
- ,rest-name)
- `(lookup-keyword ',keyword
- ,rest-name)
- name error-kind error-fun)
- (push keyword keys)))
- ((:auxs)
- (push-let-binding (car var) (cadr var) nil))))
- ((symbolp var)
- (case now-processing
- ((:required)
- (when restp
- (defmacro-error "required argument after &REST/&BODY" error-kind name))
- (push-let-binding var `(car ,path) nil)
- (setq minimum (1+ minimum)
- maximum (1+ maximum)
- path `(cdr ,path)))
- ((:optionals)
- (push-let-binding var `(car ,path) nil `(not (null ,path)))
- (setq path `(cdr ,path)
- maximum (1+ maximum)))
- ((:keywords)
- (let ((key (keywordicate var)))
- (push-let-binding var
- `(lookup-keyword ,key ,rest-name)
- nil)
- (push key keys)))
- ((:auxs)
- (push-let-binding var nil nil))))
- (t
- (error "non-symbol in lambda-list: ~S" var)))))
+ (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)
+ (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?
+ :else `(setf ,whole-var (cdr ,whole-var))))
+ (do ((rest-of-lambda-list lambda-list (cdr rest-of-lambda-list)))
+ ((null rest-of-lambda-list))
+ (macrolet ((process-sublist (var kind path)
+ (once-only ((var var))
+ `(if (listp ,var)
+ (let ((sublist-name (gensym ,kind)))
+ (push-sublist-binding sublist-name ,path ,var
+ name context error-fun)
+ (parse-defmacro-lambda-list ,var sublist-name name
+ context
+ :error-fun error-fun
+ :sublist t))
+ (push-let-binding ,var ,path))))
+ (normalize-singleton (var)
+ `(when (null (cdr ,var))
+ (setf (cdr ,var) (list *default-default*)))))
+ (let ((var (car rest-of-lambda-list)))
+ (typecase var
+ (list
+ (case now-processing
+ ((:required)
+ (when restp
+ (defmacro-error (format nil "required argument after ~A"
+ restp)
+ context name))
+ (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)))
+ ((:optionals)
+ (normalize-singleton var)
+ (destructuring-bind
+ (varname &optional default-form suppliedp-name)
+ var
+ (push-optional-binding varname default-form suppliedp-name
+ :is-supplied-p `(not (null ,path))
+ :path `(car ,path)
+ :name name
+ :context context
+ :error-fun error-fun))
+ (setq path `(cdr ,path)
+ maximum (1+ maximum)))
+ ((:keywords)
+ (normalize-singleton var)
+ (let* ((keyword-given (consp (car var)))
+ (variable (if keyword-given
+ (cadar var)
+ (car var)))
+ (keyword (if keyword-given
+ (caar var)
+ (keywordicate variable)))
+ (default-form (cadr var))
+ (suppliedp-name (caddr var)))
+ (push-optional-binding variable default-form suppliedp-name
+ :is-supplied-p
+ `(keyword-supplied-p ',keyword
+ ,rest-name)
+ :path
+ `(lookup-keyword ',keyword ,rest-name)
+ :name name
+ :context context
+ :error-fun error-fun)
+ (push keyword keys)))
+ ((:auxs)
+ (push-let-binding (car var) (cadr var)))))
+ ((and symbol (not (eql nil)))
+ (case var
+ (&whole
+ (cond ((cdr rest-of-lambda-list)
+ (pop rest-of-lambda-list)
+ (process-sublist (car rest-of-lambda-list)
+ "WHOLE-LIST-"
+ (if (eq 'define-compiler-macro context)
+ compiler-macro-whole
+ whole-var)))
+ (t
+ (defmacro-error "&WHOLE" context name))))
+ (&environment
+ (cond (env-illegal
+ (error "&ENVIRONMENT is not valid with ~S." context))
+ ;; 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
+ (error "Repeated &ENVIRONMENT.")))
+ (cond ((and (cdr rest-of-lambda-list)
+ (symbolp (cadr rest-of-lambda-list)))
+ (setq rest-of-lambda-list (cdr rest-of-lambda-list))
+ (check-defmacro-arg (car rest-of-lambda-list))
+ (setq *env-var* (car rest-of-lambda-list)
+ env-arg-used t))
+ (t
+ (defmacro-error "&ENVIRONMENT" context name))))
+ ((&rest &body)
+ (cond ((or key-seen aux-seen)
+ (error "~A after ~A in ~A"
+ var (or key-seen aux-seen) context))
+ ((and (not restp) (cdr rest-of-lambda-list))
+ (setq rest-of-lambda-list (cdr rest-of-lambda-list)
+ restp var)
+ (process-sublist (car rest-of-lambda-list)
+ "REST-LIST-" path))
+ (t
+ (defmacro-error (symbol-name var) context name))))
+ (&optional
+ (when (or key-seen aux-seen restp)
+ (error "~A after ~A in ~A lambda-list."
+ var (or key-seen aux-seen restp) context))
+ (when optional-seen
+ (error "Multiple ~A in ~A lambda list." var context))
+ (setq now-processing :optionals
+ optional-seen var))
+ (&key
+ (when aux-seen
+ (error "~A after ~A in ~A lambda-list." '&key '&aux context))
+ (when key-seen
+ (error "Multiple ~A in ~A lambda-list." '&key context))
+ (setf now-processing :keywords
+ rest-name (gensym "KEYWORDS-")
+ restp var
+ key-seen var)
+ (push rest-name *ignorable-vars*)
+ (push-let-binding rest-name path :system t))
+ (&allow-other-keys
+ (unless (eq now-processing :keywords)
+ (error "~A outside ~A section of lambda-list in ~A."
+ var '&key context))
+ (when allow-other-keys-p
+ (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
+ aux-seen var))
+ ;; FIXME: Other lambda list keywords.
+ (t
+ (case now-processing
+ ((:required)
+ (when restp
+ (defmacro-error (format nil "required argument after ~A"
+ restp)
+ context name))
+ (push-let-binding var `(car ,path))
+ (setq minimum (1+ minimum)
+ maximum (1+ maximum)
+ path `(cdr ,path)))
+ ((:optionals)
+ (push-let-binding var `(car ,path)
+ :when `(not (null ,path)))
+ (setq path `(cdr ,path)
+ maximum (1+ maximum)))
+ ((:keywords)
+ (let ((key (keywordicate var)))
+ (push-let-binding
+ var
+ `(lookup-keyword ,key ,rest-name)
+ :when `(keyword-supplied-p ,key ,rest-name))
+ (push key keys)))
+ ((:auxs)
+ (push-let-binding var nil))))))
+ (t
+ (error "non-symbol in lambda-list: ~S" var))))))