X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fparse-defmacro.lisp;h=af0c7baf13a0701ede0b732f5bd9feada2cba3d8;hb=4281f3b99891120fea5cabbc3a9d091b19f45995;hp=edd93230522cd251de8df1b9fd9613b098031ecd;hpb=c3a38a27324501dc5261640cfb08dd6b2dee35c1;p=sbcl.git diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp index edd9323..af0c7ba 100644 --- a/src/code/parse-defmacro.lisp +++ b/src/code/parse-defmacro.lisp @@ -13,21 +13,22 @@ ;;; 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*) ; &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*) (declaim (type list *ignorable-vars*)) -;;; Return, as multiple values, a body, possibly a declare form to put +;;; 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 @@ -36,26 +37,33 @@ (doc-string-allowed t) ((:environment env-arg-name)) ((:default-default *default-default*)) - (error-fun 'error)) + (error-fun 'error) + (wrap-block t)) (multiple-value-bind (forms declarations documentation) - (parse-body body doc-string-allowed) + (parse-body body :doc-string-allowed doc-string-allowed) (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* (let* ,(nreverse *user-lets*) ,@declarations - ,@forms)) + ,@(if wrap-block + `((block ,(fun-name-block-name name) + ,@forms)) + forms))) `(,@(when (and env-arg-name (not env-arg-used)) - `((declare (ignore ,env-arg-name))))) + `((declare (ignore ,env-arg-name))))) documentation minimum maximum))))) @@ -71,8 +79,7 @@ error-fun &optional toplevel - env-illegal - env-arg-name) + 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. @@ -84,6 +91,7 @@ (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 @@ -102,7 +110,7 @@ ((null rest-of-args)) (macrolet ((process-sublist (var sublist-name path) (once-only ((var var)) - `(if (consp ,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) @@ -161,10 +169,13 @@ (error "&ENVIRONMENT is not valid with ~S." error-kind)) ((not toplevel) (error "&ENVIRONMENT is only valid at top level of ~ - lambda-list."))) + 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)) - (push-let-binding (car rest-of-args) env-arg-name nil) + (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)))) @@ -182,6 +193,7 @@ (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)) @@ -236,7 +248,7 @@ :minimum ,minimum :maximum ,explicit-maximum))) *arg-tests*)) - (when keys + (when key-seen (let ((problem (gensym "KEY-PROBLEM-")) (info (gensym "INFO-"))) (push `(multiple-value-bind (,problem ,info) @@ -266,6 +278,7 @@ :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)) @@ -280,6 +293,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)))) @@ -308,6 +322,12 @@ (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]" problem kind name)) +(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.