X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fparse-defmacro.lisp;h=4cf203f2c6f5cfe28d18b477594ebc25d90506d1;hb=0051cc0532da9f68a0ba5db5c07ebee1c91ee4d8;hp=eb9efae80fd18daf7b374b315a289888057185bf;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp index eb9efae..4cf203f 100644 --- a/src/code/parse-defmacro.lisp +++ b/src/code/parse-defmacro.lisp @@ -11,9 +11,6 @@ (in-package "SB!KERNEL") -(file-comment - "$Header$") - ;;; 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 @@ -22,17 +19,18 @@ (declaim (type list *system-lets*)) (defvar *user-lets* nil) ; LET bindings that the user has explicitly supplied (declaim (type list *user-lets*)) +(defvar *env-var* nil) ; &ENVIRONMENT variable name -;; the default default for unsupplied optional and keyword args +;; the default default for unsupplied &OPTIONAL and &KEY args (defvar *default-default* nil) ;;; 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. +;;; 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) @@ -45,12 +43,15 @@ (let ((*arg-tests* ()) (*user-lets* ()) (*system-lets* ()) - (*ignorable-vars* ())) + (*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*) + nil) + (values `(let* (,@(when env-arg-used + `((,*env-var* ,env-arg-name))) + ,@(nreverse *system-lets*)) ,@(when *ignorable-vars* `((declare (ignorable ,@*ignorable-vars*)))) ,@*arg-tests* @@ -58,13 +59,13 @@ ,@declarations ,@forms)) `(,@(when (and env-arg-name (not env-arg-used)) - `((declare (ignore ,env-arg-name))))) + `((declare (ignore ,env-arg-name))))) documentation minimum 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 @@ -73,20 +74,20 @@ error-kind error-fun &optional - top-level - env-illegal - env-arg-name) + toplevel + env-illegal) (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-0 (if toplevel + `(cdr ,arg-list-name) + arg-list-name)) (path path-0) ; (will change below) (now-processing :required) (maximum 0) (minimum 0) (keys ()) + (key-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 @@ -95,153 +96,185 @@ (reversed-result nil)) ((atom in-pdll) (nreverse (if in-pdll - (list* in-pdll '&rest reversed-result) - reversed-result))) + (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) - (when (> (length var) 3) - (cerror "Ignore extra noise." - "more than variable, initform, and suppliedp ~ - in &optional binding: ~S" - var)) - (push-optional-binding (car var) (cadr var) (caddr var) - `(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)))) + (macrolet ((process-sublist (var sublist-name path) + (once-only ((var var)) + `(if (listp ,var) + (let ((sub-list-name (gensym ,sublist-name))) + (push-sub-list-binding sub-list-name ,path ,var + name error-kind error-fun) + (parse-defmacro-lambda-list ,var sub-list-name name + error-kind error-fun)) + (push-let-binding ,var ,path nil))))) + (let ((var (car rest-of-args))) + (typecase var + (list + (case now-processing + ((:required) + (when restp + (defmacro-error "required argument after &REST/&BODY" + error-kind name)) + (process-sublist var "SUBLIST-" `(car ,path)) + (setq path `(cdr ,path) + minimum (1+ minimum) + maximum (1+ maximum))) + ((: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))) + ((: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))) + ((:auxs) + (push-let-binding (car var) (cadr var) nil)))) + ((and symbol (not (eql nil))) + (case var + (&whole + (cond ((cdr rest-of-args) + (setq rest-of-args (cdr rest-of-args)) + (process-sublist (car rest-of-args) + "WHOLE-LIST-" arg-list-name)) + (t + (defmacro-error "&WHOLE" error-kind name)))) + (&environment + (cond (env-illegal + (error "&ENVIRONMENT is not valid with ~S." error-kind)) + ((not toplevel) + (error "&ENVIRONMENT is only valid at top level of ~ + lambda-list.")) + (env-arg-used + (error "Repeated &ENVIRONMENT."))) + (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) + (setq rest-of-args (cdr rest-of-args)) + (check-defmacro-arg (car rest-of-args)) + (setq *env-var* (car rest-of-args)) + (setq env-arg-used t)) + (t + (defmacro-error "&ENVIRONMENT" error-kind name)))) + ((&rest &body) + (cond ((and (not restp) (cdr rest-of-args)) + (setq rest-of-args (cdr rest-of-args)) + (setq restp t) + (process-sublist (car rest-of-args) "REST-LIST-" path)) + (t + (defmacro-error (symbol-name var) error-kind name)))) + (&optional + (setq now-processing :optionals)) + (&key + (setq now-processing :keywords) + (setq rest-name (gensym "KEYWORDS-")) + (push rest-name *ignorable-vars*) + (setq restp t) + (setq key-seen t) + (push-let-binding rest-name path t)) + (&allow-other-keys + (setq allow-other-keys-p t)) + (&aux + (setq now-processing :auxs)) + ;; FIXME: Other lambda list keywords. + (t + (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))) + ((:optionals) + (push-let-binding var `(car ,path) nil `(not (null ,path))) + (setq path `(cdr ,path) + maximum (1+ maximum))) + ((:keywords) + (let ((key (keywordicate var))) + (push-let-binding var + `(lookup-keyword ,key ,rest-name) + nil) + (push key keys))) + ((:auxs) + (push-let-binding var nil 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 `(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 key-seen + (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) + (check-defmacro-arg variable) (let ((var (gensym "TEMP-"))) (push `(,variable (let ((,var ,path)) @@ -256,6 +289,7 @@ (defun push-let-binding (variable path systemp &optional condition (init-form *default-default*)) + (check-defmacro-arg variable) (let ((let-form (if condition `(,variable (if ,condition ,path ,init-form)) `(,variable ,path)))) @@ -278,14 +312,21 @@ ((symbolp value-var) (push-let-binding value-var path nil supplied-var init-form)) (t - (error "Illegal optional variable name: ~S" value-var)))) + (error "illegal optional variable name: ~S" value-var)))) (defun defmacro-error (problem kind name) - (error "Illegal or ill-formed ~A argument in ~A~@[ ~S~]." + (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]" problem kind name)) -;;; 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 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) (do ((already-processed nil) (unknown-keyword nil) @@ -300,8 +341,6 @@ (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))