X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fparse-defmacro.lisp;h=d6a13e366bdcfe246f5e00ceaf64aad0a357d867;hb=148e3820ad314a9b59d0133c1d60eaac4af9118b;hp=db903f31f67c78be3180d547781becc8690a1ec6;hpb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;p=sbcl.git diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp index db903f3..d6a13e3 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))) @@ -121,7 +121,9 @@ (defmacro-error "&ENVIRONMENT" error-kind name)))) ((or (eq var '&rest) (eq var '&body)) - (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) + (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)) @@ -140,8 +142,10 @@ ((eq var '&aux) (setq now-processing :auxs)) ((listp var) - (cond ; (since it's too early to use CASE) - ((eq now-processing :required) + (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) @@ -150,7 +154,7 @@ (setq path `(cdr ,path) minimum (1+ minimum) maximum (1+ maximum))) - ((eq now-processing :optionals) + ((:optionals) (destructuring-bind (varname &optional initform supplied-p) var (push-optional-binding varname initform supplied-p @@ -158,7 +162,7 @@ name error-kind error-fun)) (setq path `(cdr ,path) maximum (1+ maximum))) - ((eq now-processing :keywords) + ((:keywords) (let* ((keyword-given (consp (car var))) (variable (if keyword-given (cadar var) @@ -169,71 +173,88 @@ (supplied-p (caddr var))) (push-optional-binding variable (cadr var) supplied-p `(keyword-supplied-p ',keyword - ,rest-name) + ,rest-name) `(lookup-keyword ',keyword - ,rest-name) + ,rest-name) name error-kind error-fun) (push keyword keys))) - ((eq now-processing :auxs) + ((: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) + (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))) - ((eq now-processing :optionals) + ((:optionals) (push-let-binding var `(car ,path) nil `(not (null ,path))) (setq path `(cdr ,path) maximum (1+ maximum))) - ((eq now-processing :keywords) + ((:keywords) (let ((key (keywordicate var))) (push-let-binding var `(lookup-keyword ,key ,rest-name) nil) (push key keys))) - ((eq now-processing :auxs) + ((: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) - `(arg-count-error ',error-kind ',name ,path-0 - ',lambda-list ,minimum - ,(unless restp maximum)) - `(,error-fun '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))) + (unless (and restp (zerop minimum)) + (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-")))