;;; 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
+(defvar *arg-tests*) ; tests that do argument counting at expansion time
(declaim (type list *arg-tests*))
-(defvar *system-lets* nil) ; LET bindings done to allow lambda-list parsing
+(defvar *system-lets*) ; LET bindings done to allow lambda-list parsing
(declaim (type list *system-lets*))
-(defvar *user-lets* nil) ; LET bindings that the user has explicitly supplied
+(defvar *user-lets*) ; LET bindings that the user has explicitly supplied
(declaim (type list *user-lets*))
+(defvar *env-var*) ; &ENVIRONMENT variable name
;; the default default for unsupplied &OPTIONAL and &KEY args
-(defvar *default-default* nil)
+(defvar *default-default*)
;;; 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.
-(defun parse-defmacro (lambda-list arg-list-name body name error-kind
- &key
- (anonymousp nil)
- (doc-string-allowed t)
- ((:environment env-arg-name))
- ((:default-default *default-default*))
- (error-fun 'error))
+;;; 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 whole-var body name context
+ &key
+ (anonymousp nil)
+ (doc-string-allowed t)
+ ((:environment env-arg-name))
+ ((: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)
+ (parse-body body :doc-string-allowed doc-string-allowed)
(let ((*arg-tests* ())
- (*user-lets* ())
- (*system-lets* ())
- (*ignorable-vars* ()))
+ (*user-lets* ())
+ (*system-lets* ())
+ (*ignorable-vars* ())
+ (*env-var* nil))
(multiple-value-bind (env-arg-used minimum maximum)
- (parse-defmacro-lambda-list lambda-list arg-list-name name
- error-kind error-fun (not anonymousp)
- nil env-arg-name)
- (values `(let* ,(nreverse *system-lets*)
- ,@(when *ignorable-vars*
- `((declare (ignorable ,@*ignorable-vars*))))
- ,@*arg-tests*
- (let* ,(nreverse *user-lets*)
- ,@declarations
- ,@forms))
- `(,@(when (and env-arg-name (not env-arg-used))
- `((declare (ignore ,env-arg-name)))))
- documentation
- minimum
- maximum)))))
+ (parse-defmacro-lambda-list lambda-list whole-var name context
+ :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*
+ (let* (,@(when env-arg-used
+ `((,*env-var* ,env-arg-name)))
+ ,@(nreverse *user-lets*))
+ ,@declarations
+ ,@(if wrap-block
+ `((block ,(fun-name-block-name name)
+ ,@forms))
+ forms)))
+ `(,@(when (and env-arg-name (not env-arg-used))
+ `((declare (ignore ,env-arg-name)))))
+ documentation
+ minimum
+ maximum)))))
-;;; partial reverse-engineered documentation:
-;;; TOP-LEVEL 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
- arg-list-name
- name
- error-kind
- error-fun
- &optional
- top-level
- env-illegal
- env-arg-name)
+ whole-var
+ name
+ context
+ &key
+ error-fun
+ anonymousp
+ env-illegal
+ sublist)
(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
- `(cdr ,arg-list-name)
- arg-list-name))
- (path path-0) ; (will change below)
- (now-processing :required)
- (maximum 0)
- (minimum 0)
- (keys ())
- ;; ANSI specifies that dotted lists are "treated exactly as if the
- ;; 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))
- (reversed-result nil))
- ((atom in-pdll)
- (nreverse (if in-pdll
- (list* in-pdll '&rest reversed-result)
- reversed-result)))
- (push (car in-pdll) reversed-result)))
- rest-name restp allow-other-keys-p env-arg-used)
+ ;; 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 (or anonymousp sublist) whole-var `(cdr ,whole-var)))
+ (path path-0) ; will change below
+ (compiler-macro-whole (gensym "CMACRO-&WHOLE"))
+ (now-processing :required)
+ (maximum 0)
+ (minimum 0)
+ (keys ())
+ (key-seen nil)
+ (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."
+ ;; 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))
+ (reversed-result nil))
+ ((atom in-pdll)
+ (nreverse (if in-pdll
+ (list* in-pdll '&rest reversed-result)
+ reversed-result)))
+ (push (car in-pdll) reversed-result)))
+ rest-name restp allow-other-keys-p env-arg-used)
(when (member '&whole (rest lambda-list))
- (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 top-level)
- (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 ((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)
- (cond ; (since it's too early to use CASE)
- ((eq now-processing :required)
- (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)))
- ((eq now-processing :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)))
- ((eq now-processing :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)))
- ((eq now-processing :auxs)
- (push-let-binding (car var) (cadr var) nil))))
- ((symbolp var)
- (cond ; (too early in bootstrapping to use CASE)
- ;; FIXME: ^ This "too early in bootstrapping" is no
- ;; longer an issue in current SBCL bootstrapping.
- ((eq now-processing :required)
- (push-let-binding var `(car ,path) nil)
- (setq minimum (1+ minimum)
- maximum (1+ maximum)
- path `(cdr ,path)))
- ((eq now-processing :optionals)
- (push-let-binding var `(car ,path) nil `(not (null ,path)))
- (setq path `(cdr ,path)
- maximum (1+ maximum)))
- ((eq now-processing :keywords)
- (let ((key (keywordicate var)))
- (push-let-binding var
- `(lookup-keyword ,key ,rest-name)
- nil)
- (push key keys)))
- ((eq now-processing :auxs)
- (push-let-binding var nil nil))))
- (t
- (error "non-symbol in lambda-list: ~S" var)))))
- (push `(unless ,(if restp
- ;; (If RESTP, then the argument list might be
- ;; dotted, in which case ordinary LENGTH won't
- ;; work.)
- `(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
- :kind ',error-kind
- ,@(when name `(:name ',name))
- :argument ,path-0
- :lambda-list ',lambda-list
- :minimum ,minimum
- ,@(unless restp
- `(:maximum ,maximum)))))
- *arg-tests*)
- (when keys
- (let ((problem (gensym "KEY-PROBLEM-"))
- (info (gensym "INFO-")))
- (push `(multiple-value-bind (,problem ,info)
- (verify-keywords ,rest-name
- ',keys
- ',allow-other-keys-p)
- (when ,problem
- (,error-fun
- 'defmacro-ll-broken-key-list-error
- :kind ',error-kind
- ,@(when name `(:name ',name))
- :problem ,problem
- :info ,info)))
- *arg-tests*)))
- (values env-arg-used minimum (if (null restp) maximum nil))))
+ (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 (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?
+ :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))))))
+ (let (;; common subexpression, suitable for passing to functions
+ ;; which expect a MAXIMUM argument regardless of whether
+ ;; there actually is a maximum number of arguments
+ ;; (expecting MAXIMUM=NIL when there is no maximum)
+ (explicit-maximum (and (not restp) maximum)))
+ (unless (and restp (zerop minimum))
+ (push (let ((args-form (if (eq 'define-compiler-macro context)
+ `(if (eq 'funcall (car ,whole-var))
+ (cdr ,path-0)
+ ,path-0)
+ path-0)))
+ (with-unique-names (args)
+ `(let ((,args ,args-form))
+ (unless ,(if restp
+ ;; (If RESTP, then the argument list
+ ;; might be dotted, in which case
+ ;; ordinary LENGTH won't work.)
+ `(list-of-length-at-least-p ,args ,minimum)
+ `(proper-list-of-length-p ,args
+ ,minimum
+ ,maximum))
+ ,(if (eq error-fun 'error)
+ `(arg-count-error ',context ',name ,args
+ ',lambda-list ,minimum
+ ,explicit-maximum)
+ `(,error-fun 'arg-count-error
+ :kind ',context
+ ,@(when name `(:name ',name))
+ :args ,args
+ :lambda-list ',lambda-list
+ :minimum ,minimum
+ :maximum ,explicit-maximum))))))
+ *arg-tests*))
+ (when key-seen
+ (with-unique-names (problem info)
+ (push `(multiple-value-bind (,problem ,info)
+ (verify-keywords ,rest-name
+ ',keys
+ ',allow-other-keys-p
+ ,(eq 'define-compiler-macro context))
+ (when ,problem
+ (,error-fun
+ 'defmacro-lambda-list-broken-key-list-error
+ :kind ',context
+ ,@(when name `(:name ',name))
+ :problem ,problem
+ :info ,info)))
+ *arg-tests*)))
+ (values env-arg-used minimum explicit-maximum))))
-(defun push-sub-list-binding (variable path object name error-kind error-fun)
+;;; 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* (or sb!debug:*stack-top-hint* 'arg-count-error)))
+ (error 'arg-count-error
+ :kind context
+ :name name
+ :args args
+ :lambda-list lambda-list
+ :minimum minimum
+ :maximum maximum)))
+
+(defun push-sublist-binding (variable path object name context error-fun)
+ (check-defmacro-arg variable)
(let ((var (gensym "TEMP-")))
(push `(,variable
- (let ((,var ,path))
- (if (listp ,var)
- ,var
- (,error-fun 'defmacro-bogus-sublist-error
- :kind ',error-kind
- ,@(when name `(:name ',name))
- :object ,var
- :lambda-list ',object))))
- *system-lets*)))
+ (let ((,var ,path))
+ (if (listp ,var)
+ ,var
+ (,error-fun 'defmacro-bogus-sublist-error
+ :kind ',context
+ ,@(when name `(:name ',name))
+ :object ,var
+ :lambda-list ',object))))
+ *system-lets*)))
-(defun push-let-binding (variable path systemp &optional condition
- (init-form *default-default*))
- (let ((let-form (if condition
- `(,variable (if ,condition ,path ,init-form))
- `(,variable ,path))))
- (if systemp
- (push let-form *system-lets*)
- (push let-form *user-lets*))))
+(defun push-let-binding (variable form
+ &key system when (else *default-default*))
+ (check-defmacro-arg variable)
+ (let ((let-form (if when
+ `(,variable (if ,when ,form ,else))
+ `(,variable ,form))))
+ (if system
+ (push let-form *system-lets*)
+ (push let-form *user-lets*))))
-(defun push-optional-binding (value-var init-form supplied-var condition path
- name error-kind error-fun)
- (unless supplied-var
- (setq supplied-var (gensym "SUPPLIEDP-")))
- (push-let-binding supplied-var condition t)
+(defun push-optional-binding (value-var init-form suppliedp-name
+ &key is-supplied-p path name context error-fun)
+ (unless suppliedp-name
+ (setq suppliedp-name (gensym "SUPPLIEDP-")))
+ (push-let-binding suppliedp-name is-supplied-p :system t)
(cond ((consp value-var)
- (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
- (push-sub-list-binding whole-thing
- `(if ,supplied-var ,path ,init-form)
- value-var name error-kind error-fun)
- (parse-defmacro-lambda-list value-var whole-thing name
- error-kind error-fun)))
- ((symbolp value-var)
- (push-let-binding value-var path nil supplied-var init-form))
- (t
- (error "illegal optional variable name: ~S" value-var))))
+ (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
+ (push-sublist-binding whole-thing
+ `(if ,suppliedp-name ,path ,init-form)
+ value-var name context error-fun)
+ (parse-defmacro-lambda-list value-var whole-thing name
+ context
+ :error-fun error-fun
+ :sublist t)))
+ ((symbolp value-var)
+ (push-let-binding value-var path :when suppliedp-name :else init-form))
+ (t
+ (error "illegal optional variable name: ~S" value-var))))
-(defun defmacro-error (problem kind name)
+(defun defmacro-error (problem context name)
(error "illegal or ill-formed ~A argument in ~A~@[ ~S~]"
- problem kind name))
+ problem context name))
+
+(defun check-defmacro-arg (arg)
+ (when (or (and *env-var* (eq arg *env-var*))
+ (member arg *system-lets* :key #'car)
+ (member arg *user-lets* :key #'car))
+ (error "variable ~S occurs more than once" arg)))
;;; 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)))
((null remaining)
(if (and unknown-keyword
- (not allow-other-keys)
- (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))))))
+ (not allow-other-keys)
+ (not (lookup-keyword :allow-other-keys key-list)))
+ (values :unknown-keyword (list unknown-keyword valid-keys))
+ (values nil nil)))
+ (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)))
projects / sbcl.git / blobdiff