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*) ; tests that do argument counting at expansion time
17 (declaim (type list *arg-tests*))
18 (defvar *system-lets*) ; LET bindings done to allow lambda-list parsing
19 (declaim (type list *system-lets*))
20 (defvar *user-lets*) ; LET bindings that the user has explicitly supplied
21 (declaim (type list *user-lets*))
22 (defvar *env-var*) ; &ENVIRONMENT variable name
24 ;; the default default for unsupplied &OPTIONAL and &KEY args
25 (defvar *default-default*)
27 ;;; temps that we introduce and might not reference
28 (defvar *ignorable-vars*)
29 (declaim (type list *ignorable-vars*))
31 ;;; Return, as multiple values, a body, possibly a DECLARE form to put
32 ;;; where this code is inserted, the documentation for the parsed
33 ;;; body, and bounds on the number of arguments.
34 (defun parse-defmacro (lambda-list whole-var body name context
37 (doc-string-allowed t)
38 ((:environment env-arg-name))
39 ((:default-default *default-default*))
42 (unless (listp lambda-list)
43 (bad-type lambda-list 'list "~S lambda-list is not a list: ~S"
45 (multiple-value-bind (forms declarations documentation)
46 (parse-body body :doc-string-allowed doc-string-allowed)
47 (let ((*arg-tests* ())
52 (multiple-value-bind (env-arg-used minimum maximum)
53 (parse-defmacro-lambda-list lambda-list whole-var name context
55 :anonymousp anonymousp)
56 (values `(let* (,@(nreverse *system-lets*))
58 (declare (muffle-conditions sb!ext:code-deletion-note))
59 ,@(when *ignorable-vars*
60 `((declare (ignorable ,@*ignorable-vars*))))
62 (let* (,@(when env-arg-used
63 `((,*env-var* ,env-arg-name)))
64 ,@(nreverse *user-lets*))
67 `((block ,(fun-name-block-name name)
70 `(,@(when (and env-arg-name (not env-arg-used))
71 `((declare (ignore ,env-arg-name)))))
76 (defun parse-defmacro-lambda-list (possibly-dotted-lambda-list
85 (let* (;; PATH is a sort of pointer into the part of the lambda list we're
86 ;; considering at this point in the code. PATH-0 is the root of the
87 ;; lambda list, which is the initial value of PATH.
88 (path-0 (if (or anonymousp sublist) whole-var `(cdr ,whole-var)))
89 (path path-0) ; will change below
90 (compiler-macro-whole (gensym "CMACRO-&WHOLE"))
91 (now-processing :required)
98 ;; ANSI specifies that dotted lists are "treated exactly as if the
99 ;; parameter name that ends the list had appeared preceded by &REST."
100 ;; We force this behavior by transforming dotted lists into ordinary
101 ;; lists with explicit &REST elements.
102 (lambda-list (do ((in-pdll possibly-dotted-lambda-list (cdr in-pdll))
103 (reversed-result nil))
105 (nreverse (if in-pdll
106 (list* in-pdll '&rest reversed-result)
108 (push (car in-pdll) reversed-result)))
109 rest-name restp allow-other-keys-p env-arg-used)
110 (when (member '&whole (rest lambda-list))
111 (error "&WHOLE may only appear first in ~S lambda-list." context))
112 ;; Special case compiler-macros: if car of the form is FUNCALL,
113 ;; skip over it for destructuring, pretending cdr of the form is
114 ;; the actual form. Save original for &WHOLE.
115 (when (and (not sublist) (eq context 'define-compiler-macro))
116 (push-let-binding compiler-macro-whole whole-var :system t)
117 (push compiler-macro-whole *ignorable-vars*)
118 (push-let-binding whole-var whole-var
120 :when `(not (eq 'funcall (car ,whole-var)))
121 ;; Do we need to SETF too?
122 :else `(setf ,whole-var (cdr ,whole-var))))
123 (do ((rest-of-lambda-list lambda-list (cdr rest-of-lambda-list)))
124 ((null rest-of-lambda-list))
125 (macrolet ((process-sublist (var kind path)
126 (once-only ((var var))
128 (let ((sublist-name (gensym ,kind)))
129 (push-sublist-binding sublist-name ,path ,var
130 name context error-fun)
131 (parse-defmacro-lambda-list ,var sublist-name name
135 (push-let-binding ,var ,path))))
136 (normalize-singleton (var)
137 `(when (null (cdr ,var))
138 (setf (cdr ,var) (list *default-default*)))))
139 (let ((var (car rest-of-lambda-list)))
145 (defmacro-error (format nil "required argument after ~A"
148 (when (process-sublist var "REQUIRED-" `(car ,path))
149 ;; Note &ENVIRONMENT from DEFSETF sublist
150 (aver (eq context 'defsetf))
151 (setf env-arg-used t))
152 (setq path `(cdr ,path)
154 maximum (1+ maximum)))
156 (normalize-singleton var)
158 (varname &optional default-form suppliedp-name)
160 (push-optional-binding varname default-form suppliedp-name
161 :is-supplied-p `(not (null ,path))
165 :error-fun error-fun))
166 (setq path `(cdr ,path)
167 maximum (1+ maximum)))
169 (normalize-singleton var)
170 (let* ((keyword-given (consp (car var)))
171 (variable (if keyword-given
174 (keyword (if keyword-given
176 (keywordicate variable)))
177 (default-form (cadr var))
178 (suppliedp-name (caddr var)))
179 (push-optional-binding variable default-form suppliedp-name
181 `(keyword-supplied-p ',keyword
184 `(lookup-keyword ',keyword ,rest-name)
187 :error-fun error-fun)
188 (push keyword keys)))
190 (push-let-binding (car var) (cadr var)))))
191 ((and symbol (not (eql nil)))
194 (cond ((cdr rest-of-lambda-list)
195 (pop rest-of-lambda-list)
196 (process-sublist (car rest-of-lambda-list)
198 (if (eq 'define-compiler-macro context)
202 (defmacro-error "&WHOLE" context name))))
205 (error "&ENVIRONMENT is not valid with ~S." context))
206 ;; DEFSETF explicitly allows &ENVIRONMENT, and we get
207 ;; it here in a sublist.
208 ((and sublist (neq context 'defsetf))
209 (error "&ENVIRONMENT is only valid at top level of ~
212 (error "Repeated &ENVIRONMENT.")))
213 (cond ((and (cdr rest-of-lambda-list)
214 (symbolp (cadr rest-of-lambda-list)))
215 (setq rest-of-lambda-list (cdr rest-of-lambda-list))
216 (check-defmacro-arg (car rest-of-lambda-list))
217 (setq *env-var* (car rest-of-lambda-list)
220 (defmacro-error "&ENVIRONMENT" context name))))
222 (cond ((or key-seen aux-seen)
223 (error "~A after ~A in ~A"
224 var (or key-seen aux-seen) context))
225 ((and (not restp) (cdr rest-of-lambda-list))
226 (setq rest-of-lambda-list (cdr rest-of-lambda-list)
228 (process-sublist (car rest-of-lambda-list)
231 (defmacro-error (symbol-name var) context name))))
233 (when (or key-seen aux-seen restp)
234 (error "~A after ~A in ~A lambda-list."
235 var (or key-seen aux-seen restp) context))
237 (error "Multiple ~A in ~A lambda list." var context))
238 (setq now-processing :optionals
242 (error "~A after ~A in ~A lambda-list." '&key '&aux context))
244 (error "Multiple ~A in ~A lambda-list." '&key context))
245 (setf now-processing :keywords
246 rest-name (gensym "KEYWORDS-")
249 (push rest-name *ignorable-vars*)
250 (push-let-binding rest-name path :system t))
252 (unless (eq now-processing :keywords)
253 (error "~A outside ~A section of lambda-list in ~A."
255 (when allow-other-keys-p
256 (error "Multiple ~A in ~A lambda-list." var context))
257 (setq allow-other-keys-p t))
259 (when (eq context 'defsetf)
260 (error "~A not allowed in a ~A lambda-list." var context))
262 (error "Multiple ~A in ~A lambda-list." '&aux context))
263 (setq now-processing :auxs
265 ;; FIXME: Other lambda list keywords.
270 (defmacro-error (format nil "required argument after ~A"
273 (push-let-binding var `(car ,path))
274 (setq minimum (1+ minimum)
278 (push-let-binding var `(car ,path)
279 :when `(not (null ,path)))
280 (setq path `(cdr ,path)
281 maximum (1+ maximum)))
283 (let ((key (keywordicate var)))
286 `(lookup-keyword ,key ,rest-name)
287 :when `(keyword-supplied-p ,key ,rest-name))
290 (push-let-binding var nil))))))
292 (error "non-symbol in lambda-list: ~S" var))))))
293 (let (;; common subexpression, suitable for passing to functions
294 ;; which expect a MAXIMUM argument regardless of whether
295 ;; there actually is a maximum number of arguments
296 ;; (expecting MAXIMUM=NIL when there is no maximum)
297 (explicit-maximum (and (not restp) maximum)))
298 (unless (and restp (zerop minimum))
299 (push (let ((args-form (if (eq 'define-compiler-macro context)
300 `(if (eq 'funcall (car ,whole-var))
304 (with-unique-names (args)
305 `(let ((,args ,args-form))
307 ;; (If RESTP, then the argument list
308 ;; might be dotted, in which case
309 ;; ordinary LENGTH won't work.)
310 `(list-of-length-at-least-p ,args ,minimum)
311 `(proper-list-of-length-p ,args
314 ,(if (eq error-fun 'error)
315 `(arg-count-error ',context ',name ,args
316 ',lambda-list ,minimum
318 `(,error-fun 'arg-count-error
320 ,@(when name `(:name ',name))
322 :lambda-list ',lambda-list
324 :maximum ,explicit-maximum))))))
327 (with-unique-names (problem info)
328 (push `(multiple-value-bind (,problem ,info)
329 (verify-keywords ,rest-name
332 ,(eq 'define-compiler-macro context))
335 'defmacro-lambda-list-broken-key-list-error
337 ,@(when name `(:name ',name))
341 (values env-arg-used minimum explicit-maximum))))
343 ;;; We save space in macro definitions by calling this function.
344 (defun arg-count-error (context name args lambda-list minimum maximum)
346 (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'arg-count-error)))
347 (error 'arg-count-error
351 :lambda-list lambda-list
355 (defun push-sublist-binding (variable path object name context error-fun)
356 (check-defmacro-arg variable)
357 (let ((var (gensym "TEMP-")))
362 (,error-fun 'defmacro-bogus-sublist-error
364 ,@(when name `(:name ',name))
366 :lambda-list ',object))))
369 (defun push-let-binding (variable form
370 &key system when (else *default-default*))
371 (check-defmacro-arg variable)
372 (let ((let-form (if when
373 `(,variable (if ,when ,form ,else))
374 `(,variable ,form))))
376 (push let-form *system-lets*)
377 (push let-form *user-lets*))))
379 (defun push-optional-binding (value-var init-form suppliedp-name
380 &key is-supplied-p path name context error-fun)
381 (unless suppliedp-name
382 (setq suppliedp-name (gensym "SUPPLIEDP-")))
383 (push-let-binding suppliedp-name is-supplied-p :system t)
384 (cond ((consp value-var)
385 (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
386 (push-sublist-binding whole-thing
387 `(if ,suppliedp-name ,path ,init-form)
388 value-var name context error-fun)
389 (parse-defmacro-lambda-list value-var whole-thing name
394 (push-let-binding value-var path :when suppliedp-name :else init-form))
396 (error "illegal optional variable name: ~S" value-var))))
398 (defun defmacro-error (problem context name)
399 (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]"
400 problem context name))
402 (defun check-defmacro-arg (arg)
403 (when (or (and *env-var* (eq arg *env-var*))
404 (member arg *system-lets* :key #'car)
405 (member arg *user-lets* :key #'car))
406 (error "variable ~S occurs more than once" arg)))
408 ;;; Determine whether KEY-LIST is a valid list of keyword/value pairs.
409 ;;; Do not signal the error directly, 'cause we don't know how it
410 ;;; should be signaled.
411 (defun verify-keywords (key-list valid-keys allow-other-keys &optional compiler-macro)
412 (do ((already-processed nil)
413 (unknown-keyword nil)
414 (remaining key-list (cddr remaining)))
416 (if (and unknown-keyword
417 (not allow-other-keys)
418 (not (lookup-keyword :allow-other-keys key-list)))
419 (values :unknown-keyword (list unknown-keyword valid-keys))
421 (let ((key (when (consp remaining)
423 (cond ((not (and (consp remaining) (listp (cdr remaining))))
424 (return (values :dotted-list key-list)))
425 ((null (cdr remaining))
426 (return (values :odd-length key-list))))
427 ;; Compiler-macro lambda lists are macro lambda lists -- meaning that
428 ;; &key ((a a) t) should match a literal A, not a form evaluating to A
429 ;; as in an ordinary lambda list.
431 ;; That, however, breaks the evaluation model unless A is also a
432 ;; constant evaluating to itself. So, signal a condition telling the
433 ;; compiler to punt on the expansion.
434 (when (and compiler-macro
435 (not (or (keywordp key)
438 (eq key (symbol-value key))))))
439 (signal 'compiler-macro-keyword-problem :argument key))
440 (cond ((or (eq key :allow-other-keys)
441 (member key valid-keys))
442 (push key already-processed))
444 (setq unknown-keyword key))))))
446 (defun lookup-keyword (keyword key-list)
447 (do ((remaining key-list (cddr remaining)))
449 (when (eq keyword (car remaining))
450 (return (cadr remaining)))))
452 (defun keyword-supplied-p (keyword key-list)
453 (do ((remaining key-list (cddr remaining)))
455 (when (eq keyword (car remaining))