1 ;;;; the PARSE-DEFMACRO function and related code
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!KERNEL")
14 ;;; variables for accumulating the results of parsing a DEFMACRO. (Declarations
15 ;;; in DEFMACRO are the reason this isn't as easy as it sounds.)
16 (defvar *arg-tests* nil) ; tests that do argument counting at expansion time
17 (declaim (type list *arg-tests*))
18 (defvar *system-lets* nil) ; LET bindings done to allow lambda-list parsing
19 (declaim (type list *system-lets*))
20 (defvar *user-lets* nil) ; LET bindings that the user has explicitly supplied
21 (declaim (type list *user-lets*))
23 ;; the default default for unsupplied &OPTIONAL and &KEY args
24 (defvar *default-default* nil)
26 ;;; temps that we introduce and might not reference
27 (defvar *ignorable-vars*)
28 (declaim (type list *ignorable-vars*))
30 ;;; Return, as multiple values, a body, possibly a declare form to put
31 ;;; where this code is inserted, the documentation for the parsed
32 ;;; body, and bounds on the number of arguments.
33 (defun parse-defmacro (lambda-list arg-list-name body name error-kind
36 (doc-string-allowed t)
37 ((:environment env-arg-name))
38 ((:default-default *default-default*))
40 (multiple-value-bind (forms declarations documentation)
41 (parse-body body doc-string-allowed)
42 (let ((*arg-tests* ())
45 (*ignorable-vars* ()))
46 (multiple-value-bind (env-arg-used minimum maximum)
47 (parse-defmacro-lambda-list lambda-list arg-list-name name
48 error-kind error-fun (not anonymousp)
50 (values `(let* ,(nreverse *system-lets*)
51 ,@(when *ignorable-vars*
52 `((declare (ignorable ,@*ignorable-vars*))))
54 (let* ,(nreverse *user-lets*)
57 `(,@(when (and env-arg-name (not env-arg-used))
58 `((declare (ignore ,env-arg-name)))))
63 ;;; partial reverse-engineered documentation:
64 ;;; TOPLEVEL is true for calls through PARSE-DEFMACRO from DEFSETF and
65 ;;; DESTRUCTURING-BIND, false otherwise.
67 (defun parse-defmacro-lambda-list (possibly-dotted-lambda-list
76 (let* (;; PATH is a sort of pointer into the part of the lambda list we're
77 ;; considering at this point in the code. PATH-0 is the root of the
78 ;; lambda list, which is the initial value of PATH.
82 (path path-0) ; (will change below)
83 (now-processing :required)
87 ;; ANSI specifies that dotted lists are "treated exactly as if the
88 ;; parameter name that ends the list had appeared preceded by &rest."
89 ;; We force this behavior by transforming dotted lists into ordinary
90 ;; lists with explicit &REST elements.
91 (lambda-list (do ((in-pdll possibly-dotted-lambda-list (cdr in-pdll))
92 (reversed-result nil))
95 (list* in-pdll '&rest reversed-result)
97 (push (car in-pdll) reversed-result)))
98 rest-name restp allow-other-keys-p env-arg-used)
99 (when (member '&whole (rest lambda-list))
100 (error "&WHOLE may only appear first in ~S lambda-list." error-kind))
101 (do ((rest-of-args lambda-list (cdr rest-of-args)))
102 ((null rest-of-args))
103 (macrolet ((process-sublist (var sublist-name path)
104 (once-only ((var var))
106 (let ((sub-list-name (gensym ,sublist-name)))
107 (push-sub-list-binding sub-list-name ,path ,var
108 name error-kind error-fun)
109 (parse-defmacro-lambda-list ,var sub-list-name name
110 error-kind error-fun))
111 (push-let-binding ,var ,path nil)))))
112 (let ((var (car rest-of-args)))
118 (defmacro-error "required argument after &REST/&BODY"
120 (process-sublist var "SUBLIST-" `(car ,path))
121 (setq path `(cdr ,path)
123 maximum (1+ maximum)))
125 (destructuring-bind (varname &optional initform supplied-p)
127 (push-optional-binding varname initform supplied-p
128 `(not (null ,path)) `(car ,path)
129 name error-kind error-fun))
130 (setq path `(cdr ,path)
131 maximum (1+ maximum)))
133 (let* ((keyword-given (consp (car var)))
134 (variable (if keyword-given
137 (keyword (if keyword-given
139 (keywordicate variable)))
140 (supplied-p (caddr var)))
141 (push-optional-binding variable (cadr var) supplied-p
142 `(keyword-supplied-p ',keyword
144 `(lookup-keyword ',keyword
146 name error-kind error-fun)
147 (push keyword keys)))
149 (push-let-binding (car var) (cadr var) nil))))
150 ((and symbol (not (eql nil)))
153 (cond ((cdr rest-of-args)
154 (setq rest-of-args (cdr rest-of-args))
155 (process-sublist (car rest-of-args)
156 "WHOLE-LIST-" arg-list-name))
158 (defmacro-error "&WHOLE" error-kind name))))
161 (error "&ENVIRONMENT is not valid with ~S." error-kind))
163 (error "&ENVIRONMENT is only valid at top level of ~
165 (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
166 (setq rest-of-args (cdr rest-of-args))
167 (push-let-binding (car rest-of-args) env-arg-name nil)
168 (setq env-arg-used t))
170 (defmacro-error "&ENVIRONMENT" error-kind name))))
172 (cond ((and (not restp) (cdr rest-of-args))
173 (setq rest-of-args (cdr rest-of-args))
175 (process-sublist (car rest-of-args) "REST-LIST-" path))
177 (defmacro-error (symbol-name var) error-kind name))))
179 (setq now-processing :optionals))
181 (setq now-processing :keywords)
182 (setq rest-name (gensym "KEYWORDS-"))
183 (push rest-name *ignorable-vars*)
185 (push-let-binding rest-name path t))
187 (setq allow-other-keys-p t))
189 (setq now-processing :auxs))
190 ;; FIXME: Other lambda list keywords.
195 (defmacro-error "required argument after &REST/&BODY"
197 (push-let-binding var `(car ,path) nil)
198 (setq minimum (1+ minimum)
202 (push-let-binding var `(car ,path) nil `(not (null ,path)))
203 (setq path `(cdr ,path)
204 maximum (1+ maximum)))
206 (let ((key (keywordicate var)))
207 (push-let-binding var
208 `(lookup-keyword ,key ,rest-name)
212 (push-let-binding var nil nil))))))
214 (error "non-symbol in lambda-list: ~S" var))))))
215 (let (;; common subexpression, suitable for passing to functions
216 ;; which expect a MAXIMUM argument regardless of whether
217 ;; there actually is a maximum number of arguments
218 ;; (expecting MAXIMUM=NIL when there is no maximum)
219 (explicit-maximum (and (not restp) maximum)))
220 (unless (and restp (zerop minimum))
221 (push `(unless ,(if restp
222 ;; (If RESTP, then the argument list might be
223 ;; dotted, in which case ordinary LENGTH won't
225 `(list-of-length-at-least-p ,path-0 ,minimum)
226 `(proper-list-of-length-p ,path-0 ,minimum ,maximum))
227 ,(if (eq error-fun 'error)
228 `(arg-count-error ',error-kind ',name ,path-0
229 ',lambda-list ,minimum
231 `(,error-fun 'arg-count-error
233 ,@(when name `(:name ',name))
235 :lambda-list ',lambda-list
237 :maximum ,explicit-maximum)))
240 (let ((problem (gensym "KEY-PROBLEM-"))
241 (info (gensym "INFO-")))
242 (push `(multiple-value-bind (,problem ,info)
243 (verify-keywords ,rest-name
245 ',allow-other-keys-p)
248 'defmacro-lambda-list-broken-key-list-error
250 ,@(when name `(:name ',name))
254 (values env-arg-used minimum explicit-maximum))))
256 ;;; We save space in macro definitions by calling this function.
257 (defun arg-count-error (error-kind name args lambda-list minimum maximum)
259 (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
260 (error 'arg-count-error
264 :lambda-list lambda-list
268 (defun push-sub-list-binding (variable path object name error-kind error-fun)
269 (let ((var (gensym "TEMP-")))
274 (,error-fun 'defmacro-bogus-sublist-error
276 ,@(when name `(:name ',name))
278 :lambda-list ',object))))
281 (defun push-let-binding (variable path systemp &optional condition
282 (init-form *default-default*))
283 (let ((let-form (if condition
284 `(,variable (if ,condition ,path ,init-form))
285 `(,variable ,path))))
287 (push let-form *system-lets*)
288 (push let-form *user-lets*))))
290 (defun push-optional-binding (value-var init-form supplied-var condition path
291 name error-kind error-fun)
293 (setq supplied-var (gensym "SUPPLIEDP-")))
294 (push-let-binding supplied-var condition t)
295 (cond ((consp value-var)
296 (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
297 (push-sub-list-binding whole-thing
298 `(if ,supplied-var ,path ,init-form)
299 value-var name error-kind error-fun)
300 (parse-defmacro-lambda-list value-var whole-thing name
301 error-kind error-fun)))
303 (push-let-binding value-var path nil supplied-var init-form))
305 (error "illegal optional variable name: ~S" value-var))))
307 (defun defmacro-error (problem kind name)
308 (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]"
311 ;;; Determine whether KEY-LIST is a valid list of keyword/value pairs.
312 ;;; Do not signal the error directly, 'cause we don't know how it
313 ;;; should be signaled.
314 (defun verify-keywords (key-list valid-keys allow-other-keys)
315 (do ((already-processed nil)
316 (unknown-keyword nil)
317 (remaining key-list (cddr remaining)))
319 (if (and unknown-keyword
320 (not allow-other-keys)
321 (not (lookup-keyword :allow-other-keys key-list)))
322 (values :unknown-keyword (list unknown-keyword valid-keys))
324 (cond ((not (and (consp remaining) (listp (cdr remaining))))
325 (return (values :dotted-list key-list)))
326 ((null (cdr remaining))
327 (return (values :odd-length key-list)))
328 ((or (eq (car remaining) :allow-other-keys)
329 (member (car remaining) valid-keys))
330 (push (car remaining) already-processed))
332 (setq unknown-keyword (car remaining))))))
334 (defun lookup-keyword (keyword key-list)
335 (do ((remaining key-list (cddr remaining)))
337 (when (eq keyword (car remaining))
338 (return (cadr remaining)))))
340 (defun keyword-supplied-p (keyword key-list)
341 (do ((remaining key-list (cddr remaining)))
343 (when (eq keyword (car remaining))