;;; 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
+(defun parse-defmacro (lambda-list arg-list-name body name context
&key
(anonymousp nil)
(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*)
+ context error-fun (not anonymousp)
+ 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)))))
(defun parse-defmacro-lambda-list (possibly-dotted-lambda-list
arg-list-name
name
- error-kind
+ context
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.
(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
(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))
+ (error "&WHOLE may only appear first in ~S lambda-list." context))
(do ((rest-of-args lambda-list (cdr rest-of-args)))
((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)
+ name context error-fun)
(parse-defmacro-lambda-list ,var sub-list-name name
- error-kind error-fun))
- (push-let-binding ,var ,path nil)))))
+ context error-fun))
+ (push-let-binding ,var ,path nil))))
+ (normalize-singleton (var)
+ `(when (null (cdr ,var))
+ (setf (cdr ,var) (list *default-default*)))))
(let ((var (car rest-of-args)))
(typecase var
(list
((:required)
(when restp
(defmacro-error "required argument after &REST/&BODY"
- error-kind name))
+ context name))
(process-sublist var "SUBLIST-" `(car ,path))
(setq path `(cdr ,path)
minimum (1+ minimum)
maximum (1+ maximum)))
((:optionals)
+ (normalize-singleton var)
(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))
+ name context 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)
,rest-name)
`(lookup-keyword ',keyword
,rest-name)
- name error-kind error-fun)
+ name context error-fun)
(push keyword keys)))
((:auxs)
(push-let-binding (car var) (cadr var) nil))))
(&whole
(cond ((cdr rest-of-args)
(setq rest-of-args (cdr rest-of-args))
+ ;; Special case for compiler-macros: if car of
+ ;; the form is FUNCALL skip over it for
+ ;; destructuring, pretending cdr of the form is
+ ;; the actual form.
+ (when (eq context 'define-compiler-macro)
+ (push-let-binding
+ arg-list-name
+ arg-list-name
+ t
+ `(not (and (listp ,arg-list-name)
+ (eq 'funcall (car ,arg-list-name))))
+ `(setf ,arg-list-name (cdr ,arg-list-name))))
(process-sublist (car rest-of-args)
"WHOLE-LIST-" arg-list-name))
(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))
+ (error "&ENVIRONMENT is not valid with ~S." context))
((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))))
+ (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))
(t
- (defmacro-error (symbol-name var) error-kind name))))
+ (defmacro-error (symbol-name var) context name))))
(&optional
(setq now-processing :optionals))
(&key
(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))
((:required)
(when restp
(defmacro-error "required argument after &REST/&BODY"
- error-kind name))
+ context name))
(push-let-binding var `(car ,path) nil)
(setq minimum (1+ minimum)
maximum (1+ maximum)
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)
+ nil
+ `(keyword-supplied-p ,key ,rest-name))
(push key keys)))
((:auxs)
(push-let-binding var nil nil))))))
`(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
+ `(arg-count-error ',context ',name ,path-0
',lambda-list ,minimum
,explicit-maximum)
`(,error-fun 'arg-count-error
- :kind ',error-kind
+ :kind ',context
,@(when name `(:name ',name))
:args ,path-0
:lambda-list ',lambda-list
: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)
(when ,problem
(,error-fun
'defmacro-lambda-list-broken-key-list-error
- :kind ',error-kind
+ :kind ',context
,@(when name `(:name ',name))
:problem ,problem
:info ,info)))
(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))))
(error 'arg-count-error
- :kind error-kind
+ :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-sub-list-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
+ :kind ',context
,@(when name `(:name ',name))
:object ,var
:lambda-list ',object))))
(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))))
(push let-form *user-lets*))))
(defun push-optional-binding (value-var init-form supplied-var condition path
- name error-kind error-fun)
+ name context error-fun)
(unless supplied-var
(setq supplied-var (gensym "SUPPLIEDP-")))
(push-let-binding supplied-var condition t)
(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)
+ value-var name context error-fun)
(parse-defmacro-lambda-list value-var whole-thing name
- error-kind error-fun)))
+ context 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))))
-(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*))
+ (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