(defvar *user-lets* nil) ; LET bindings that the user has explicitly supplied
(declaim (type list *user-lets*))
-;; 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)
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
error-kind
error-fun
&optional
- top-level
+ toplevel
env-illegal
env-arg-name)
(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
+ (path-0 (if toplevel
`(cdr ,arg-list-name)
arg-list-name))
(path path-0) ; (will change below)
((eq var '&environment)
(cond (env-illegal
(error "&ENVIRONMENT is not valid with ~S." error-kind))
- ((not top-level)
+ ((not toplevel)
(error "&ENVIRONMENT is only valid at top level of ~
lambda-list.")))
(cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
(defmacro-error "&ENVIRONMENT" error-kind name))))
((or (eq var '&rest)
(eq var '&body))
- (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
+ (cond (restp
+ (defmacro-error (symbol-name var) error-kind name))
+ ((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))
((eq var '&aux)
(setq now-processing :auxs))
((listp var)
- (cond ; (since it's too early to use CASE)
- ((eq now-processing :required)
+ (case now-processing
+ ((:required)
+ (when restp
+ (defmacro-error "required argument after &REST/&BODY" error-kind name))
(let ((sub-list-name (gensym "SUBLIST-")))
(push-sub-list-binding sub-list-name `(car ,path) var
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)
+ ((: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)))
- ((eq now-processing :keywords)
+ ((:keywords)
(let* ((keyword-given (consp (car var)))
(variable (if keyword-given
(cadar var)
(supplied-p (caddr var)))
(push-optional-binding variable (cadr var) supplied-p
`(keyword-supplied-p ',keyword
- ,rest-name)
+ ,rest-name)
`(lookup-keyword ',keyword
- ,rest-name)
+ ,rest-name)
name error-kind error-fun)
(push keyword keys)))
- ((eq now-processing :auxs)
+ ((: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)
+ (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)))
- ((eq now-processing :optionals)
+ ((:optionals)
(push-let-binding var `(car ,path) nil `(not (null ,path)))
(setq path `(cdr ,path)
maximum (1+ maximum)))
- ((eq now-processing :keywords)
+ ((:keywords)
(let ((key (keywordicate var)))
(push-let-binding var
`(lookup-keyword ,key ,rest-name)
nil)
(push key keys)))
- ((eq now-processing :auxs)
+ ((: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))))
+ (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 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-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)
(let ((var (gensym "TEMP-")))
((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.
+;;; 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)
(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))
projects / sbcl.git / blobdiff