- ;; each time.
- (let* ((chain (nth-chain form (+ reqvar-count optvar-count) t))
- (pattern (or (d-lambda-list-restvar d-ll) (gensym)))
- (rest (compute-pbindings pattern chain)))
- (dolist (keyvar (d-lambda-list-keyvars d-ll))
- (let ((variable (keyvar-variable keyvar))
- (keyword (keyvar-keyword-name keyvar))
- (supplied (or (keyvar-supplied-p-parameter keyvar)
- (gensym))))
- (when supplied
- (compute-pbindings supplied `(keyword-supplied-p ,keyword ,rest)))
- (compute-pbindings variable `(if ,supplied
- (keyword-lookup ,keyword ,rest)
- ,(keyvar-initform keyvar)))))))
-
- ;; Aux variables
- (dolist (auxvar (d-lambda-list-auxvars d-ll))
- (compute-pbindings (auxvar-variable auxvar) (auxvar-initform auxvar))))))
+ ;; each time. We also include validation of
+ ;; keywords if there is any.
+ (let* ((chain (nth-chain whole (+ reqvar-count optvar-count) t))
+ (restvar (lambda-list-restvar ll))
+ (pattern (or restvar (gensym)))
+ (keywords (mapcar #'keyvar-keyword-name (lambda-list-keyvars ll)))
+ (rest
+ ;; Create a binding for the rest of the
+ ;; arguments. If there is keywords, then
+ ;; validate this list. If there is no
+ ;; keywords and no &rest variable, then
+ ;; validate that the rest is empty, it is
+ ;; to say, there is no more arguments
+ ;; that we expect.
+ (cond
+ (keywords (compute-pbindings pattern `(validate-keyvars ,chain ',keywords ,(lambda-list-allow-other-keys ll))))
+ (restvar (compute-pbindings pattern chain))
+ (t (compute-pbindings pattern `(validate-max-args ,chain))))))
+ (when (lambda-list-keyvars ll)
+ ;; Keywords
+ (dolist (keyvar (lambda-list-keyvars ll))
+ (let ((variable (keyvar-variable keyvar))
+ (keyword (keyvar-keyword-name keyvar))
+ (supplied (or (keyvar-supplied-p-parameter keyvar)
+ (gensym))))
+ (when supplied
+ (compute-pbindings supplied `(keyword-supplied-p ,keyword ,rest)))
+ (compute-pbindings variable `(if ,supplied
+ (keyword-lookup ,keyword ,rest)
+ ,(keyvar-initform keyvar)))))))
+ ;; Aux variables
+ (dolist (auxvar (lambda-list-auxvars ll))
+ (compute-pbindings (auxvar-variable auxvar) (auxvar-initform auxvar))))
+
+ whole)))