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*))
22 (defvar *env-var* nil) ; &ENVIRONMENT variable name
24 ;; the default default for unsupplied &OPTIONAL and &KEY args
25 (defvar *default-default* nil)
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 arg-list-name body name error-kind
37 (doc-string-allowed t)
38 ((:environment env-arg-name))
39 ((:default-default *default-default*))
41 (multiple-value-bind (forms declarations documentation)
42 (parse-body body doc-string-allowed)
43 (let ((*arg-tests* ())
48 (multiple-value-bind (env-arg-used minimum maximum)
49 (parse-defmacro-lambda-list lambda-list arg-list-name name
50 error-kind error-fun (not anonymousp)
52 (values `(let* (,@(when env-arg-used
53 `((,*env-var* ,env-arg-name)))
54 ,@(nreverse *system-lets*))
55 ,@(when *ignorable-vars*
56 `((declare (ignorable ,@*ignorable-vars*))))
58 (let* ,(nreverse *user-lets*)
61 `(,@(when (and env-arg-name (not env-arg-used))
62 `((declare (ignore ,env-arg-name)))))
67 ;;; partial reverse-engineered documentation:
68 ;;; TOPLEVEL is true for calls through PARSE-DEFMACRO from DEFSETF and
69 ;;; DESTRUCTURING-BIND, false otherwise.
71 (defun parse-defmacro-lambda-list (possibly-dotted-lambda-list
79 (let* (;; PATH is a sort of pointer into the part of the lambda list we're
80 ;; considering at this point in the code. PATH-0 is the root of the
81 ;; lambda list, which is the initial value of PATH.
85 (path path-0) ; (will change below)
86 (now-processing :required)
90 ;; ANSI specifies that dotted lists are "treated exactly as if the
91 ;; parameter name that ends the list had appeared preceded by &rest."
92 ;; We force this behavior by transforming dotted lists into ordinary
93 ;; lists with explicit &REST elements.
94 (lambda-list (do ((in-pdll possibly-dotted-lambda-list (cdr in-pdll))
95 (reversed-result nil))
98 (list* in-pdll '&rest reversed-result)
100 (push (car in-pdll) reversed-result)))
101 rest-name restp allow-other-keys-p env-arg-used)
102 (when (member '&whole (rest lambda-list))
103 (error "&WHOLE may only appear first in ~S lambda-list." error-kind))
104 (do ((rest-of-args lambda-list (cdr rest-of-args)))
105 ((null rest-of-args))
106 (macrolet ((process-sublist (var sublist-name path)
107 (once-only ((var var))
109 (let ((sub-list-name (gensym ,sublist-name)))
110 (push-sub-list-binding sub-list-name ,path ,var
111 name error-kind error-fun)
112 (parse-defmacro-lambda-list ,var sub-list-name name
113 error-kind error-fun))
114 (push-let-binding ,var ,path nil)))))
115 (let ((var (car rest-of-args)))
121 (defmacro-error "required argument after &REST/&BODY"
123 (process-sublist var "SUBLIST-" `(car ,path))
124 (setq path `(cdr ,path)
126 maximum (1+ maximum)))
128 (destructuring-bind (varname &optional initform supplied-p)
130 (push-optional-binding varname initform supplied-p
131 `(not (null ,path)) `(car ,path)
132 name error-kind error-fun))
133 (setq path `(cdr ,path)
134 maximum (1+ maximum)))
136 (let* ((keyword-given (consp (car var)))
137 (variable (if keyword-given
140 (keyword (if keyword-given
142 (keywordicate variable)))
143 (supplied-p (caddr var)))
144 (push-optional-binding variable (cadr var) supplied-p
145 `(keyword-supplied-p ',keyword
147 `(lookup-keyword ',keyword
149 name error-kind error-fun)
150 (push keyword keys)))
152 (push-let-binding (car var) (cadr var) nil))))
153 ((and symbol (not (eql nil)))
156 (cond ((cdr rest-of-args)
157 (setq rest-of-args (cdr rest-of-args))
158 (process-sublist (car rest-of-args)
159 "WHOLE-LIST-" arg-list-name))
161 (defmacro-error "&WHOLE" error-kind name))))
164 (error "&ENVIRONMENT is not valid with ~S." error-kind))
166 (error "&ENVIRONMENT is only valid at top level of ~
169 (error "Repeated &ENVIRONMENT.")))
170 (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
171 (setq rest-of-args (cdr rest-of-args))
172 (check-defmacro-arg (car rest-of-args))
173 (setq *env-var* (car rest-of-args))
174 (setq env-arg-used t))
176 (defmacro-error "&ENVIRONMENT" error-kind name))))
178 (cond ((and (not restp) (cdr rest-of-args))
179 (setq rest-of-args (cdr rest-of-args))
181 (process-sublist (car rest-of-args) "REST-LIST-" path))
183 (defmacro-error (symbol-name var) error-kind name))))
185 (setq now-processing :optionals))
187 (setq now-processing :keywords)
188 (setq rest-name (gensym "KEYWORDS-"))
189 (push rest-name *ignorable-vars*)
191 (push-let-binding rest-name path t))
193 (setq allow-other-keys-p t))
195 (setq now-processing :auxs))
196 ;; FIXME: Other lambda list keywords.
201 (defmacro-error "required argument after &REST/&BODY"
203 (push-let-binding var `(car ,path) nil)
204 (setq minimum (1+ minimum)
208 (push-let-binding var `(car ,path) nil `(not (null ,path)))
209 (setq path `(cdr ,path)
210 maximum (1+ maximum)))
212 (let ((key (keywordicate var)))
213 (push-let-binding var
214 `(lookup-keyword ,key ,rest-name)
218 (push-let-binding var nil nil))))))
220 (error "non-symbol in lambda-list: ~S" var))))))
221 (let (;; common subexpression, suitable for passing to functions
222 ;; which expect a MAXIMUM argument regardless of whether
223 ;; there actually is a maximum number of arguments
224 ;; (expecting MAXIMUM=NIL when there is no maximum)
225 (explicit-maximum (and (not restp) maximum)))
226 (unless (and restp (zerop minimum))
227 (push `(unless ,(if restp
228 ;; (If RESTP, then the argument list might be
229 ;; dotted, in which case ordinary LENGTH won't
231 `(list-of-length-at-least-p ,path-0 ,minimum)
232 `(proper-list-of-length-p ,path-0 ,minimum ,maximum))
233 ,(if (eq error-fun 'error)
234 `(arg-count-error ',error-kind ',name ,path-0
235 ',lambda-list ,minimum
237 `(,error-fun 'arg-count-error
239 ,@(when name `(:name ',name))
241 :lambda-list ',lambda-list
243 :maximum ,explicit-maximum)))
246 (let ((problem (gensym "KEY-PROBLEM-"))
247 (info (gensym "INFO-")))
248 (push `(multiple-value-bind (,problem ,info)
249 (verify-keywords ,rest-name
251 ',allow-other-keys-p)
254 'defmacro-lambda-list-broken-key-list-error
256 ,@(when name `(:name ',name))
260 (values env-arg-used minimum explicit-maximum))))
262 ;;; We save space in macro definitions by calling this function.
263 (defun arg-count-error (error-kind name args lambda-list minimum maximum)
265 (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
266 (error 'arg-count-error
270 :lambda-list lambda-list
274 (defun push-sub-list-binding (variable path object name error-kind error-fun)
275 (check-defmacro-arg variable)
276 (let ((var (gensym "TEMP-")))
281 (,error-fun 'defmacro-bogus-sublist-error
283 ,@(when name `(:name ',name))
285 :lambda-list ',object))))
288 (defun push-let-binding (variable path systemp &optional condition
289 (init-form *default-default*))
290 (check-defmacro-arg variable)
291 (let ((let-form (if condition
292 `(,variable (if ,condition ,path ,init-form))
293 `(,variable ,path))))
295 (push let-form *system-lets*)
296 (push let-form *user-lets*))))
298 (defun push-optional-binding (value-var init-form supplied-var condition path
299 name error-kind error-fun)
301 (setq supplied-var (gensym "SUPPLIEDP-")))
302 (push-let-binding supplied-var condition t)
303 (cond ((consp value-var)
304 (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
305 (push-sub-list-binding whole-thing
306 `(if ,supplied-var ,path ,init-form)
307 value-var name error-kind error-fun)
308 (parse-defmacro-lambda-list value-var whole-thing name
309 error-kind error-fun)))
311 (push-let-binding value-var path nil supplied-var init-form))
313 (error "illegal optional variable name: ~S" value-var))))
315 (defun defmacro-error (problem kind name)
316 (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]"
319 (defun check-defmacro-arg (arg)
320 (when (or (and *env-var* (eq arg *env-var*))
321 (member arg *system-lets* :key #'car)
322 (member arg *user-lets* :key #'car))
323 (error "variable ~S occurs more than once" arg)))
325 ;;; Determine whether KEY-LIST is a valid list of keyword/value pairs.
326 ;;; Do not signal the error directly, 'cause we don't know how it
327 ;;; should be signaled.
328 (defun verify-keywords (key-list valid-keys allow-other-keys)
329 (do ((already-processed nil)
330 (unknown-keyword nil)
331 (remaining key-list (cddr remaining)))
333 (if (and unknown-keyword
334 (not allow-other-keys)
335 (not (lookup-keyword :allow-other-keys key-list)))
336 (values :unknown-keyword (list unknown-keyword valid-keys))
338 (cond ((not (and (consp remaining) (listp (cdr remaining))))
339 (return (values :dotted-list key-list)))
340 ((null (cdr remaining))
341 (return (values :odd-length key-list)))
342 ((or (eq (car remaining) :allow-other-keys)
343 (member (car remaining) valid-keys))
344 (push (car remaining) already-processed))
346 (setq unknown-keyword (car remaining))))))
348 (defun lookup-keyword (keyword key-list)
349 (do ((remaining key-list (cddr remaining)))
351 (when (eq keyword (car remaining))
352 (return (cadr remaining)))))
354 (defun keyword-supplied-p (keyword key-list)
355 (do ((remaining key-list (cddr remaining)))
357 (when (eq keyword (car remaining))