X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fparse-defmacro.lisp;h=378d0ec3546da260a7ce214d6cb458fd15488394;hb=86210c4e406c1b2ff10cc3bac0e71435867db48b;hp=8ee93ec437159a403c90e24e1fad72d8ff615197;hpb=de201aeb12169d0bd377eca4da6116c2797a66ad;p=sbcl.git diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp index 8ee93ec..378d0ec 100644 --- a/src/code/parse-defmacro.lisp +++ b/src/code/parse-defmacro.lisp @@ -27,9 +27,9 @@ (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) @@ -61,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 @@ -70,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) @@ -110,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))) @@ -199,41 +199,57 @@ (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)))) + (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))) + (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) + `(arg-count-error ',error-kind ',name ,path-0 + ',lambda-list ,minimum + ,explicit-maximum) + `(,error-fun 'arg-count-error + :kind ',error-kind + ,@(when name `(:name ',name)) + :args ,path-0 + :lambda-list ',lambda-list + :minimum ,minimum + :maximum ,explicit-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-lambda-list-broken-key-list-error + :kind ',error-kind + ,@(when name `(:name ',name)) + :problem ,problem + :info ,info))) + *arg-tests*))) + (values env-arg-used minimum explicit-maximum)))) + +;;; We save space in macro definitions by calling this function. +(defun arg-count-error (error-kind name args lambda-list minimum maximum) + (let (#-sb-xc-host + (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame)))) + (error 'arg-count-error + :kind error-kind + :name name + :args args + :lambda-list lambda-list + :minimum minimum + :maximum maximum))) (defun push-sub-list-binding (variable path object name error-kind error-fun) (let ((var (gensym "TEMP-")))