diff --git a/code/defmacro.lisp b/code/defmacro.lisp index c3dda3fde208917bdab2aee8aea0010330b3a0f1..31104a47480678805cf0450fda01ded25c3c02a1 100644 --- a/code/defmacro.lisp +++ b/code/defmacro.lisp @@ -47,7 +47,7 @@ ((:environment env-arg-name)) ((:default-default *default-default*)) ((:key-finder *key-finder*)) - error-fun) + (error-fun 'error)) "Returns as multiple-values a parsed body, any local-declarations that should be made where this body is inserted, and a doc-string if there is one." @@ -104,7 +104,7 @@ (setf rest-of-args (cdr rest-of-args)) (push-let-binding (car rest-of-args) arg-list-name nil)) (t - (defmacro-error name "&whole")))) + (defmacro-error "&WHOLE" error-kind name)))) ((eq var '&environment) (cond (env-illegal (error "&Environment not valid with ~S." error-kind)) @@ -116,7 +116,7 @@ (push-let-binding (car rest-of-args) env-arg-name nil) (setf env-arg-used t)) (t - (defmacro-error name "&environment")))) + (defmacro-error "&ENVIRONMENT" error-kind name)))) ((or (eq var '&rest) (eq var '&body)) (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) (setf rest-of-args (cdr rest-of-args)) @@ -154,7 +154,7 @@ (push-let-binding doc-string-name `(caddr ,parse-body-values) nil)))) (t - (defmacro-error name (symbol-name var))))) + (defmacro-error (symbol-name var) error-kind name)))) ((eq var '&optional) (setf now-processing :optionals)) ((eq var '&key) @@ -179,7 +179,7 @@ (setf path `(cdr ,path))) (:keywords (let ((key (make-keyword var))) - (push-let-binding var `(keyword-argument ,key ,rest-name) + (push-let-binding var `(lookup-keyword ,key ,rest-name) nil) (push key keys))) (:auxs @@ -225,22 +225,36 @@ name error-kind error-fun) (push keyword keys))) (:auxs (push-let-binding (car var) (cadr var) nil))))))) - (push `(verify-arg-counts ,(if top-level - `(cdr ,arg-list-name) - arg-list-name) - ,minimum - ,(or (not (null restp)) maximum) - ',lambda-list - ',name - ',error-kind - ,@(if error-fun `(#',error-fun))) + (push `(unless (<= ,minimum + (length ,(if top-level + `(cdr ,arg-list-name) + arg-list-name)) + ,@(unless restp + (list maximum))) + (,error-fun 'defmacro-ll-arg-count-error + :kind ',error-kind + ,@(when name `(:name ',name)) + :argument ,(if top-level + `(cdr ,arg-list-name) + arg-list-name) + :lambda-list ',lambda-list + :minimum ,minimum + ,@(unless restp `(:maximum ,maximum)))) *arg-tests*) (if keys - (push `(verify-valid-keys ,rest-name - ,(if allow-other-keys-p t `',keys) - ',name ',error-kind - ,@(if error-fun `(#',error-fun))) - *arg-tests*)) + (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)))) (defun push-sub-list-binding (variable path object name error-kind) @@ -275,100 +289,113 @@ (t (error "Illegal optional variable name: ~S" value-var)))) -(defun defmacro-error (name kind) - (error "Illegal or ill-formed ~A argument in ~S." kind name)) - - - -;;;; Destructuring argument testing routines. +(defun make-keyword (symbol) + "Takes a non-keyword symbol, symbol, and returns the corresponding keyword." + (intern (symbol-name symbol) *keyword-package*)) -;;; DESTRUCTURING-ARG-COUNT-TEST tests an argument list against a maximum -;;; and minimum number of arguments. NIL for maximum means there is no -;;; limit. Keywords are checked. T for keylist means allow-other-keys. -;;; -(defun verify-arg-counts - (arg-list minimum maximum lambda-list name error-kind - &optional (error-fun #'destructuring-arg-count-error)) - (unless (listp arg-list) - (funcall error-fun nil - "~S should have been a list of arguments for lambda-list ~S." - name error-kind arg-list lambda-list)) - (let ((length (length arg-list))) - (cond ((< length minimum) - (funcall error-fun nil - "Too few arguments in ~S to satisfy lambda-list ~S.~% ~ - Expected at least ~D." - name error-kind arg-list lambda-list minimum)) - ((and (not (eq maximum t)) - (> length maximum)) - (funcall error-fun nil - "Too many arguments in ~S to satisfy lambda-list ~S.~% ~ - Expected no more than ~D." - name error-kind arg-list lambda-list maximum))))) +(defun defmacro-error (problem kind name) + (error "Illegal or ill-formed ~A argument in ~A~@[ ~S~]." + problem kind name)) -(defun verify-valid-keys - (key-bindings valid-keys name kind - &optional (error-fun #'destructuring-arg-count-error)) - (when (keyword-argument :allow-other-keys key-bindings) - (setf valid-keys t)) - (do ((test-key key-bindings (cddr test-key))) - ((endp test-key)) - (let ((key (car test-key))) - (unless (keywordp key) - (funcall error-fun name kind "Ignore it." "Bogus keyword: ~S" key)) - (unless (or (eq valid-keys t) - (member key valid-keys)) - (funcall error-fun name kind "Ignore it." "Unknown keyword: ~S" key))))) + +;;;; Routines used at runtime by the resultant body. -;;; DESTRUCTURING-ARG-COUNT-ERROR --- internal. +;;; VERIFY-KEYWORDS -- internal ;;; -;;; Default error function for destructuring-arg-count-test. +;;; Determine if 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 destructuring-arg-count-error (name kind continue string &rest args) - (if continue - (cerror "~4*~?" - "While expanding ~A ~S:~% ~?" - kind name string args - continue args) - (error "While expanding ~A ~S:~% ~?" - kind name string args))) +(defun verify-keywords (key-list valid-keys allow-other-keys) + (do ((already-processed nil) + (unknown-keyword nil) + (remaining key-list (cddr key-list))) + ((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))) + ((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)) + (t + (setf unknown-keyword (car remaining)))))) +(defun lookup-keyword (keyword key-list) + (do ((remaining key-list (cddr key-list))) + ((endp remaining)) + (when (eq keyword (car key-list)) + (return (cadr key-list))))) + +(defun keyword-supplied-p (keyword key-list) + (do ((remaining key-list (cddr key-list))) + ((endp remaining)) + (when (eq keyword (car key-list)) + (return (cadr key-list))))) -;;;; Helpful Keyword Routines. +;;;; Conditions signaled at runtime by the resultant body. -(defun make-keyword (symbol) - "Takes a non-keyword symbol, symbol, and returns the corresponding keyword." - (intern (symbol-name symbol) *keyword-package*)) +(define-condition defmacro-lambda-list-bind-error (error) (kind name)) -(defun keyword-supplied-p (keyword key-list) - "Return T iff the given keyword is a key in key-list. Signal an error if it - appears twice." - (let ((foundp nil)) - (do ((keys key-list (cddr keys))) - ((endp keys) foundp) - (let ((key (car keys))) - (cond ((not (eq key keyword))) - (foundp - (cerror "Use first occurrence." - "Keyword ~S appears in keyword-list ~S more than once." - key key-list) - (return t)) - ((consp (cdr keys)) - (setf foundp t)) - (t - (cerror - "Stick a NIL on the end and go on." - "Unpaired item in keyword portion of macro call.") - (setf (cdr keys) (list nil)))))))) +(defun print-defmacro-ll-bind-error-intro (condition stream) + (if (null (defmacro-lambda-list-bind-error-name condition)) + (format stream + "Error while parsing arguments to ~A in ~S:~%" + (defmacro-lambda-list-bind-error-kind condition) + (defmacro-lambda-list-bind-error-function-name condition)) + (format stream + "Error while parsing arguments to ~A ~S:~%" + (defmacro-lambda-list-bind-error-kind condition) + (defmacro-lambda-list-bind-error-name condition)))) -(defun keyword-argument (keyword key-list) - "If keyword is present in the keylist, return it's associated value." - (do ((keys key-list (cddr keys))) - ((endp keys)) - (when (eq (car keys) keyword) - (return (cadr keys))))) +(define-condition defmacro-ll-arg-count-error (defmacro-lambda-list-bind-error) + (argument lambda-list minimum maximum) + (:report + (lambda (condition stream) + (print-defmacro-ll-bind-error-intro condition stream) + (format stream + "Invalid number of elements in:~% ~:S~%~ + to satisfy lambda-list:~% ~:S~%" + (defmacro-ll-arg-count-error-argument condition) + (defmacro-ll-arg-count-error-lambda-list condition)) + (cond ((null (defmacro-ll-arg-count-error-maximum condition)) + (format stream "Expected at least ~D" + (defmacro-ll-arg-count-error-minimum condition))) + ((= (defmacro-ll-arg-count-error-minimum condition) + (defmacro-ll-arg-count-error-maximum condition)) + (format stream "Expected exactly ~D" + (defmacro-ll-arg-count-error-minimum condition))) + (t + (format stream "Expected between ~D and ~D" + (defmacro-ll-arg-count-error-minimum condition) + (defmacro-ll-arg-count-error-maximum condition)))) + (format stream ", but got ~D." + (length (defmacro-ll-arg-count-error-argument condition)))))) +(define-condition defmacro-ll-broken-key-list-error + (defmacro-lambda-list-bind-error) + (problem info) + (:report (lambda (condition stream) + (print-defmacro-ll-bind-error-intro condition stream) + (format stream + (ecase + (defmacro-ll-broken-key-list-error-problem condition) + (:dotted-list + "Keyword/value list is dotted: ~S") + (:odd-length + "Odd number of elements in keyword/value list: ~S") + (:duplicate + "Duplicate keyword: ~S") + (:unknown-keyword + "~{Unknown keyword: ~S; expected one of ~{~S~^, ~}~}")) + (defmacro-ll-broken-key-list-error-info condition)))))