;;; 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 context
;;; 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 context
(wrap-block t))
(multiple-value-bind (forms declarations documentation)
(parse-body body :doc-string-allowed doc-string-allowed)
(let ((*arg-tests* ())
(wrap-block t))
(multiple-value-bind (forms declarations documentation)
(parse-body body :doc-string-allowed doc-string-allowed)
(let ((*arg-tests* ())
- (parse-defmacro-lambda-list lambda-list arg-list-name name
- context error-fun (not anonymousp)
- nil)
- (values `(let* (,@(when env-arg-used
+ (parse-defmacro-lambda-list lambda-list arg-list-name name
+ context error-fun (not anonymousp)
+ nil)
+ (values `(let* (,@(when env-arg-used
`((,*env-var* ,env-arg-name)))
,@(nreverse *system-lets*))
`((,*env-var* ,env-arg-name)))
,@(nreverse *system-lets*))
- ,@(when *ignorable-vars*
- `((declare (ignorable ,@*ignorable-vars*))))
- ,@*arg-tests*
- (let* ,(nreverse *user-lets*)
- ,@declarations
+ ,@(when *ignorable-vars*
+ `((declare (ignorable ,@*ignorable-vars*))))
+ ,@*arg-tests*
+ (let* ,(nreverse *user-lets*)
+ ,@declarations
;;; 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
;;; 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
- ;; 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
+ ;; 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
- ;; 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
+ ;; 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
(when (member '&whole (rest lambda-list))
(error "&WHOLE may only appear first in ~S lambda-list." context))
(do ((rest-of-args lambda-list (cdr rest-of-args)))
(when (member '&whole (rest lambda-list))
(error "&WHOLE may only appear first in ~S lambda-list." context))
(do ((rest-of-args lambda-list (cdr rest-of-args)))
(parse-defmacro-lambda-list ,var sub-list-name name
context error-fun))
(push-let-binding ,var ,path nil))))
(parse-defmacro-lambda-list ,var sub-list-name name
context error-fun))
(push-let-binding ,var ,path nil))))
- (normalize-singleton (var)
- `(when (null (cdr ,var))
- (setf (cdr ,var) (list *default-default*)))))
+ (normalize-singleton (var)
+ `(when (null (cdr ,var))
+ (setf (cdr ,var) (list *default-default*)))))
(destructuring-bind (varname &optional initform supplied-p)
var
(push-optional-binding varname initform supplied-p
(destructuring-bind (varname &optional initform supplied-p)
var
(push-optional-binding varname initform supplied-p
- ;; 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))))
+ ;; 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))))
- var
- `(lookup-keyword ,key ,rest-name)
- nil
- `(keyword-supplied-p ,key ,rest-name))
+ var
+ `(lookup-keyword ,key ,rest-name)
+ nil
+ `(keyword-supplied-p ,key ,rest-name))
(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
(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)))
+ ;; 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
(unless (and restp (zerop minimum))
(push `(unless ,(if restp
;; (If RESTP, then the argument list might be
- (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 ',context
- ,@(when name `(:name ',name))
- :problem ,problem
- :info ,info)))
- *arg-tests*)))
+ (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 ',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 (context name args lambda-list minimum maximum)
(let (#-sb-xc-host
(values env-arg-used minimum explicit-maximum))))
;;; We save space in macro definitions by calling this function.
(defun arg-count-error (context name args lambda-list minimum maximum)
(let (#-sb-xc-host
(defun push-sub-list-binding (variable path object name context error-fun)
(check-defmacro-arg variable)
(let ((var (gensym "TEMP-")))
(push `(,variable
(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 ',context
- ,@(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*)))
- `(,variable (if ,condition ,path ,init-form))
- `(,variable ,path))))
+ `(,variable (if ,condition ,path ,init-form))
+ `(,variable ,path))))
(if systemp
(push let-form *system-lets*)
(push let-form *user-lets*))))
(defun push-optional-binding (value-var init-form supplied-var condition path
(if systemp
(push let-form *system-lets*)
(push let-form *user-lets*))))
(defun push-optional-binding (value-var init-form supplied-var condition path
- (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
- (push-sub-list-binding whole-thing
- `(if ,supplied-var ,path ,init-form)
- value-var name context error-fun)
- (parse-defmacro-lambda-list value-var whole-thing name
- 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))))
+ (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
+ (push-sub-list-binding whole-thing
+ `(if ,supplied-var ,path ,init-form)
+ value-var name context error-fun)
+ (parse-defmacro-lambda-list value-var whole-thing name
+ 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 context name)
(error "illegal or ill-formed ~A argument in ~A~@[ ~S~]"
(defun defmacro-error (problem context name)
(error "illegal or ill-formed ~A argument in ~A~@[ ~S~]"
- (not allow-other-keys)
- (not (lookup-keyword :allow-other-keys key-list)))
- (values :unknown-keyword (list unknown-keyword valid-keys))
- (values nil nil)))
+ (not allow-other-keys)
+ (not (lookup-keyword :allow-other-keys key-list)))
+ (values :unknown-keyword (list unknown-keyword valid-keys))
+ (values nil nil)))
- (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))))))
+ (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))))))