X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fparse-defmacro.lisp;h=f745a8425eff8505842f2f3b6b1ce3443b7650aa;hb=0c3bbfaa2286626a2d915c8810f690aefc702661;hp=94f8325720b91dac16fc8632e074d835d8dccb62;hpb=c41cb4c87eae7b04f844dca5f7edb5086c5d2d68;p=sbcl.git diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp index 94f8325..f745a84 100644 --- a/src/code/parse-defmacro.lisp +++ b/src/code/parse-defmacro.lisp @@ -13,16 +13,16 @@ ;;; 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 +(defvar *arg-tests*) ; tests that do argument counting at expansion time (declaim (type list *arg-tests*)) -(defvar *system-lets* nil) ; LET bindings done to allow lambda-list parsing +(defvar *system-lets*) ; LET bindings done to allow lambda-list parsing (declaim (type list *system-lets*)) -(defvar *user-lets* nil) ; LET bindings that the user has explicitly supplied +(defvar *user-lets*) ; LET bindings that the user has explicitly supplied (declaim (type list *user-lets*)) -(defvar *env-var* nil) ; &ENVIRONMENT variable name +(defvar *env-var*) ; &ENVIRONMENT variable name ;; the default default for unsupplied &OPTIONAL and &KEY args -(defvar *default-default* nil) +(defvar *default-default*) ;;; temps that we introduce and might not reference (defvar *ignorable-vars*) @@ -31,113 +31,142 @@ ;;; 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) - (doc-string-allowed t) - ((:environment env-arg-name)) - ((:default-default *default-default*)) - (error-fun 'error) - (wrap-block t)) +(defun parse-defmacro (lambda-list whole-var body name context + &key + (anonymousp nil) + (doc-string-allowed t) + ((:environment env-arg-name)) + ((:default-default *default-default*)) + (error-fun 'error) + (wrap-block t)) + (unless (listp lambda-list) + (bad-type lambda-list 'list "~S lambda-list is not a list: ~S" + context lambda-list)) (multiple-value-bind (forms declarations documentation) (parse-body body :doc-string-allowed doc-string-allowed) (let ((*arg-tests* ()) - (*user-lets* ()) - (*system-lets* ()) - (*ignorable-vars* ()) + (*user-lets* ()) + (*system-lets* ()) + (*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) - (values `(let* (,@(when env-arg-used + (parse-defmacro-lambda-list lambda-list whole-var name context + :error-fun error-fun + :anonymousp anonymousp) + (values `(let* (,@(nreverse *system-lets*)) + #-sb-xc-host + (declare (muffle-conditions sb!ext:code-deletion-note)) + ,@(when *ignorable-vars* + `((declare (ignorable ,@*ignorable-vars*)))) + ,@*arg-tests* + (let* (,@(when env-arg-used `((,*env-var* ,env-arg-name))) - ,@(nreverse *system-lets*)) - ,@(when *ignorable-vars* - `((declare (ignorable ,@*ignorable-vars*)))) - ,@*arg-tests* - (let* ,(nreverse *user-lets*) - ,@declarations + ,@(nreverse *user-lets*)) + ,@declarations ,@(if wrap-block `((block ,(fun-name-block-name name) ,@forms)) forms))) - `(,@(when (and env-arg-name (not env-arg-used)) + `(,@(when (and env-arg-name (not env-arg-used)) `((declare (ignore ,env-arg-name))))) - documentation - minimum - maximum))))) + documentation + minimum + maximum))))) -;;; partial reverse-engineered documentation: -;;; 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 - arg-list-name - name - error-kind - error-fun - &optional - toplevel - env-illegal) + whole-var + name + context + &key + error-fun + anonymousp + env-illegal + sublist) (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 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 - ;; lists with explicit &REST elements. - (lambda-list (do ((in-pdll possibly-dotted-lambda-list (cdr in-pdll)) - (reversed-result nil)) - ((atom in-pdll) - (nreverse (if in-pdll + ;; 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 (or anonymousp sublist) whole-var `(cdr ,whole-var))) + (path path-0) ; will change below + (compiler-macro-whole (gensym "CMACRO-&WHOLE")) + (now-processing :required) + (maximum 0) + (minimum 0) + (keys ()) + (key-seen nil) + (aux-seen nil) + (optional-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 + ;; lists with explicit &REST elements. + (lambda-list (do ((in-pdll possibly-dotted-lambda-list (cdr in-pdll)) + (reversed-result nil)) + ((atom in-pdll) + (nreverse (if in-pdll (list* in-pdll '&rest reversed-result) reversed-result))) - (push (car in-pdll) reversed-result))) - rest-name restp allow-other-keys-p env-arg-used) + (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)) - (macrolet ((process-sublist (var sublist-name path) + (error "&WHOLE may only appear first in ~S lambda-list." context)) + ;; Special case compiler-macros: if car of the form is FUNCALL, + ;; skip over it for destructuring, pretending cdr of the form is + ;; the actual form. Save original for &WHOLE. + (when (and (not sublist) (eq context 'define-compiler-macro)) + (push-let-binding compiler-macro-whole whole-var :system t) + (push compiler-macro-whole *ignorable-vars*) + (push-let-binding whole-var whole-var + :system t + :when `(not (eq 'funcall (car ,whole-var))) + ;; Do we need to SETF too? + :else `(setf ,whole-var (cdr ,whole-var)))) + (do ((rest-of-lambda-list lambda-list (cdr rest-of-lambda-list))) + ((null rest-of-lambda-list)) + (macrolet ((process-sublist (var kind 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))) + (let ((sublist-name (gensym ,kind))) + (push-sublist-binding sublist-name ,path ,var + name context error-fun) + (parse-defmacro-lambda-list ,var sublist-name name + context + :error-fun error-fun + :sublist t)) + (push-let-binding ,var ,path)))) + (normalize-singleton (var) + `(when (null (cdr ,var)) + (setf (cdr ,var) (list *default-default*))))) + (let ((var (car rest-of-lambda-list))) (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)) + (defmacro-error (format nil "required argument after ~A" + restp) + context name)) + (when (process-sublist var "REQUIRED-" `(car ,path)) + ;; Note &ENVIRONMENT from DEFSETF sublist + (aver (eq context 'defsetf)) + (setf env-arg-used t)) (setq path `(cdr ,path) minimum (1+ minimum) maximum (1+ maximum))) ((:optionals) - (destructuring-bind (varname &optional initform supplied-p) + (normalize-singleton var) + (destructuring-bind + (varname &optional default-form suppliedp-name) var - (push-optional-binding varname initform supplied-p - `(not (null ,path)) `(car ,path) - name error-kind error-fun)) + (push-optional-binding varname default-form suppliedp-name + :is-supplied-p `(not (null ,path)) + :path `(car ,path) + :name name + :context context + :error-fun error-fun)) (setq path `(cdr ,path) maximum (1+ maximum))) ((:keywords) + (normalize-singleton var) (let* ((keyword-given (consp (car var))) (variable (if keyword-given (cadar var) @@ -145,182 +174,230 @@ (keyword (if keyword-given (caar var) (keywordicate variable))) - (supplied-p (caddr var))) - (push-optional-binding variable (cadr var) supplied-p + (default-form (cadr var)) + (suppliedp-name (caddr var))) + (push-optional-binding variable default-form suppliedp-name + :is-supplied-p `(keyword-supplied-p ',keyword ,rest-name) - `(lookup-keyword ',keyword - ,rest-name) - name error-kind error-fun) + :path + `(lookup-keyword ',keyword ,rest-name) + :name name + :context context + :error-fun error-fun) (push keyword keys))) ((:auxs) - (push-let-binding (car var) (cadr var) nil)))) + (push-let-binding (car var) (cadr var))))) ((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)) + (cond ((cdr rest-of-lambda-list) + (pop rest-of-lambda-list) + (process-sublist (car rest-of-lambda-list) + "WHOLE-LIST-" + (if (eq 'define-compiler-macro context) + compiler-macro-whole + whole-var))) (t - (defmacro-error "&WHOLE" error-kind name)))) + (defmacro-error "&WHOLE" context name)))) (&environment (cond (env-illegal - (error "&ENVIRONMENT is not valid with ~S." error-kind)) - ((not toplevel) + (error "&ENVIRONMENT is not valid with ~S." context)) + ;; DEFSETF explicitly allows &ENVIRONMENT, and we get + ;; it here in a sublist. + ((and sublist (neq context 'defsetf)) (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)) + (cond ((and (cdr rest-of-lambda-list) + (symbolp (cadr rest-of-lambda-list))) + (setq rest-of-lambda-list (cdr rest-of-lambda-list)) + (check-defmacro-arg (car rest-of-lambda-list)) + (setq *env-var* (car rest-of-lambda-list) + env-arg-used t)) (t - (defmacro-error "&ENVIRONMENT" error-kind name)))) + (defmacro-error "&ENVIRONMENT" context 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)) + (cond ((or key-seen aux-seen) + (error "~A after ~A in ~A" + var (or key-seen aux-seen) context)) + ((and (not restp) (cdr rest-of-lambda-list)) + (setq rest-of-lambda-list (cdr rest-of-lambda-list) + restp var) + (process-sublist (car rest-of-lambda-list) + "REST-LIST-" path)) (t - (defmacro-error (symbol-name var) error-kind name)))) + (defmacro-error (symbol-name var) context name)))) (&optional - (setq now-processing :optionals)) + (when (or key-seen aux-seen restp) + (error "~A after ~A in ~A lambda-list." + var (or key-seen aux-seen restp) context)) + (when optional-seen + (error "Multiple ~A in ~A lambda list." var context)) + (setq now-processing :optionals + optional-seen var)) (&key - (setq now-processing :keywords) - (setq rest-name (gensym "KEYWORDS-")) + (when aux-seen + (error "~A after ~A in ~A lambda-list." '&key '&aux context)) + (when key-seen + (error "Multiple ~A in ~A lambda-list." '&key context)) + (setf now-processing :keywords + rest-name (gensym "KEYWORDS-") + restp var + key-seen var) (push rest-name *ignorable-vars*) - (setq restp t) - (setq key-seen t) - (push-let-binding rest-name path t)) + (push-let-binding rest-name path :system t)) (&allow-other-keys + (unless (eq now-processing :keywords) + (error "~A outside ~A section of lambda-list in ~A." + var '&key context)) + (when allow-other-keys-p + (error "Multiple ~A in ~A lambda-list." var context)) (setq allow-other-keys-p t)) (&aux - (setq now-processing :auxs)) + (when (eq context 'defsetf) + (error "~A not allowed in a ~A lambda-list." var context)) + (when aux-seen + (error "Multiple ~A in ~A lambda-list." '&aux context)) + (setq now-processing :auxs + aux-seen var)) ;; 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) + (defmacro-error (format nil "required argument after ~A" + restp) + context name)) + (push-let-binding var `(car ,path)) (setq minimum (1+ minimum) maximum (1+ maximum) path `(cdr ,path))) ((:optionals) - (push-let-binding var `(car ,path) nil `(not (null ,path))) + (push-let-binding var `(car ,path) + :when `(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-let-binding + var + `(lookup-keyword ,key ,rest-name) + :when `(keyword-supplied-p ,key ,rest-name)) (push key keys))) ((:auxs) - (push-let-binding var nil nil)))))) + (push-let-binding var 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))) + ;; 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))) + (push (let ((args-form (if (eq 'define-compiler-macro context) + `(if (eq 'funcall (car ,whole-var)) + (cdr ,path-0) + ,path-0) + path-0))) + (with-unique-names (args) + `(let ((,args ,args-form)) + (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 ,args ,minimum) + `(proper-list-of-length-p ,args + ,minimum + ,maximum)) + ,(if (eq error-fun 'error) + `(arg-count-error ',context ',name ,args + ',lambda-list ,minimum + ,explicit-maximum) + `(,error-fun 'arg-count-error + :kind ',context + ,@(when name `(:name ',name)) + :args ,args + :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*))) + (with-unique-names (problem info) + (push `(multiple-value-bind (,problem ,info) + (verify-keywords ,rest-name + ',keys + ',allow-other-keys-p + ,(eq 'define-compiler-macro context)) + (when ,problem + (,error-fun + 'defmacro-lambda-list-broken-key-list-error + :kind ',context + ,@(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) +(defun arg-count-error (context name args lambda-list minimum maximum) (let (#-sb-xc-host - (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame)))) + (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'arg-count-error))) (error 'arg-count-error - :kind error-kind - :name name - :args args - :lambda-list lambda-list - :minimum minimum - :maximum maximum))) + :kind context + :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) +(defun push-sublist-binding (variable path object name context error-fun) (check-defmacro-arg variable) (let ((var (gensym "TEMP-"))) (push `(,variable - (let ((,var ,path)) - (if (listp ,var) - ,var - (,error-fun 'defmacro-bogus-sublist-error - :kind ',error-kind - ,@(when name `(:name ',name)) - :object ,var - :lambda-list ',object)))) - *system-lets*))) + (let ((,var ,path)) + (if (listp ,var) + ,var + (,error-fun 'defmacro-bogus-sublist-error + :kind ',context + ,@(when name `(:name ',name)) + :object ,var + :lambda-list ',object)))) + *system-lets*))) -(defun push-let-binding (variable path systemp &optional condition - (init-form *default-default*)) +(defun push-let-binding (variable form + &key system when (else *default-default*)) (check-defmacro-arg variable) - (let ((let-form (if condition - `(,variable (if ,condition ,path ,init-form)) - `(,variable ,path)))) - (if systemp - (push let-form *system-lets*) - (push let-form *user-lets*)))) + (let ((let-form (if when + `(,variable (if ,when ,form ,else)) + `(,variable ,form)))) + (if system + (push let-form *system-lets*) + (push let-form *user-lets*)))) -(defun push-optional-binding (value-var init-form supplied-var condition path - name error-kind error-fun) - (unless supplied-var - (setq supplied-var (gensym "SUPPLIEDP-"))) - (push-let-binding supplied-var condition t) +(defun push-optional-binding (value-var init-form suppliedp-name + &key is-supplied-p path name context error-fun) + (unless suppliedp-name + (setq suppliedp-name (gensym "SUPPLIEDP-"))) + (push-let-binding suppliedp-name is-supplied-p :system t) (cond ((consp value-var) - (let ((whole-thing (gensym "OPTIONAL-SUBLIST-"))) - (push-sub-list-binding whole-thing - `(if ,supplied-var ,path ,init-form) - value-var name error-kind error-fun) - (parse-defmacro-lambda-list value-var whole-thing name - error-kind error-fun))) - ((symbolp value-var) - (push-let-binding value-var path nil supplied-var init-form)) - (t - (error "illegal optional variable name: ~S" value-var)))) + (let ((whole-thing (gensym "OPTIONAL-SUBLIST-"))) + (push-sublist-binding whole-thing + `(if ,suppliedp-name ,path ,init-form) + value-var name context error-fun) + (parse-defmacro-lambda-list value-var whole-thing name + context + :error-fun error-fun + :sublist t))) + ((symbolp value-var) + (push-let-binding value-var path :when suppliedp-name :else init-form)) + (t + (error "illegal optional variable name: ~S" value-var)))) -(defun defmacro-error (problem kind name) +(defun defmacro-error (problem context name) (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]" - problem kind name)) + problem context name)) (defun check-defmacro-arg (arg) (when (or (and *env-var* (eq arg *env-var*)) @@ -331,25 +408,40 @@ ;;; 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) +(defun verify-keywords (key-list valid-keys allow-other-keys &optional compiler-macro) (do ((already-processed nil) (unknown-keyword nil) (remaining key-list (cddr remaining))) ((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))) - ((or (eq (car remaining) :allow-other-keys) - (member (car remaining) valid-keys)) - (push (car remaining) already-processed)) - (t - (setq unknown-keyword (car remaining)))))) + (not allow-other-keys) + (not (lookup-keyword :allow-other-keys key-list))) + (values :unknown-keyword (list unknown-keyword valid-keys)) + (values nil nil))) + (let ((key (when (consp remaining) + (car remaining)))) + (cond ((not (and (consp remaining) (listp (cdr remaining)))) + (return (values :dotted-list key-list))) + ((null (cdr remaining)) + (return (values :odd-length key-list)))) + ;; Compiler-macro lambda lists are macro lambda lists -- meaning that + ;; &key ((a a) t) should match a literal A, not a form evaluating to A + ;; as in an ordinary lambda list. + ;; + ;; That, however, breaks the evaluation model unless A is also a + ;; constant evaluating to itself. So, signal a condition telling the + ;; compiler to punt on the expansion. + (when (and compiler-macro + (not (or (keywordp key) + (and (symbolp key) + (constantp key) + (eq key (symbol-value key)))))) + (signal 'compiler-macro-keyword-problem :argument key)) + (cond ((or (eq key :allow-other-keys) + (member key valid-keys)) + (push key already-processed)) + (t + (setq unknown-keyword key)))))) (defun lookup-keyword (keyword key-list) (do ((remaining key-list (cddr remaining)))