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 where
31 ;;; this code is inserted, the documentation for the parsed body, and bounds
32 ;;; 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 ;;; TOP-LEVEL 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 (let ((var (car rest-of-args)))
104 (cond ((eq var '&whole)
105 (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
106 (setq rest-of-args (cdr rest-of-args))
107 (push-let-binding (car rest-of-args) arg-list-name nil))
109 (defmacro-error "&WHOLE" error-kind name))))
110 ((eq var '&environment)
112 (error "&ENVIRONMENT is not valid with ~S." error-kind))
114 (error "&ENVIRONMENT is only valid at top level of ~
116 (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
117 (setq rest-of-args (cdr rest-of-args))
118 (push-let-binding (car rest-of-args) env-arg-name nil)
119 (setq env-arg-used t))
121 (defmacro-error "&ENVIRONMENT" error-kind name))))
124 (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
125 (setq rest-of-args (cdr rest-of-args))
127 (push-let-binding (car rest-of-args) path nil))
129 (defmacro-error (symbol-name var) error-kind name))))
131 (setq now-processing :optionals))
133 (setq now-processing :keywords)
134 (setq rest-name (gensym "KEYWORDS-"))
135 (push rest-name *ignorable-vars*)
137 (push-let-binding rest-name path t))
138 ((eq var '&allow-other-keys)
139 (setq allow-other-keys-p t))
141 (setq now-processing :auxs))
143 (cond ; (since it's too early to use CASE)
144 ((eq now-processing :required)
145 (let ((sub-list-name (gensym "SUBLIST-")))
146 (push-sub-list-binding sub-list-name `(car ,path) var
147 name error-kind error-fun)
148 (parse-defmacro-lambda-list var sub-list-name name
149 error-kind error-fun))
150 (setq path `(cdr ,path)
152 maximum (1+ maximum)))
153 ((eq now-processing :optionals)
154 (when (> (length var) 3)
155 (cerror "Ignore extra noise."
156 "more than variable, initform, and suppliedp ~
157 in &optional binding: ~S"
159 (push-optional-binding (car var) (cadr var) (caddr var)
160 `(not (null ,path)) `(car ,path)
161 name error-kind error-fun)
162 (setq path `(cdr ,path)
163 maximum (1+ maximum)))
164 ((eq now-processing :keywords)
165 (let* ((keyword-given (consp (car var)))
166 (variable (if keyword-given
169 (keyword (if keyword-given
171 (keywordicate variable)))
172 (supplied-p (caddr var)))
173 (push-optional-binding variable (cadr var) supplied-p
174 `(keyword-supplied-p ',keyword
176 `(lookup-keyword ',keyword
178 name error-kind error-fun)
179 (push keyword keys)))
180 ((eq now-processing :auxs)
181 (push-let-binding (car var) (cadr var) nil))))
183 (cond ; (too early in bootstrapping to use CASE)
184 ;; FIXME: ^ This "too early in bootstrapping" is no
185 ;; longer an issue in current SBCL bootstrapping.
186 ((eq now-processing :required)
187 (push-let-binding var `(car ,path) nil)
188 (setq minimum (1+ minimum)
191 ((eq now-processing :optionals)
192 (push-let-binding var `(car ,path) nil `(not (null ,path)))
193 (setq path `(cdr ,path)
194 maximum (1+ maximum)))
195 ((eq now-processing :keywords)
196 (let ((key (keywordicate var)))
197 (push-let-binding var
198 `(lookup-keyword ,key ,rest-name)
201 ((eq now-processing :auxs)
202 (push-let-binding var nil nil))))
204 (error "non-symbol in lambda-list: ~S" var)))))
205 (push `(unless ,(if restp
206 ;; (If RESTP, then the argument list might be
207 ;; dotted, in which case ordinary LENGTH won't
209 `(list-of-length-at-least-p ,path-0 ,minimum)
210 `(proper-list-of-length-p ,path-0 ,minimum ,maximum))
211 ,(if (eq error-fun 'error)
212 `(do-arg-count-error ',error-kind ',name ,path-0
213 ',lambda-list ,minimum
214 ,(unless restp maximum))
215 `(,error-fun 'defmacro-ll-arg-count-error
217 ,@(when name `(:name ',name))
219 :lambda-list ',lambda-list
222 `(:maximum ,maximum)))))
225 (let ((problem (gensym "KEY-PROBLEM-"))
226 (info (gensym "INFO-")))
227 (push `(multiple-value-bind (,problem ,info)
228 (verify-keywords ,rest-name
230 ',allow-other-keys-p)
233 'defmacro-ll-broken-key-list-error
235 ,@(when name `(:name ',name))
239 (values env-arg-used minimum (if (null restp) maximum nil))))
241 (defun push-sub-list-binding (variable path object name error-kind error-fun)
242 (let ((var (gensym "TEMP-")))
247 (,error-fun 'defmacro-bogus-sublist-error
249 ,@(when name `(:name ',name))
251 :lambda-list ',object))))
254 (defun push-let-binding (variable path systemp &optional condition
255 (init-form *default-default*))
256 (let ((let-form (if condition
257 `(,variable (if ,condition ,path ,init-form))
258 `(,variable ,path))))
260 (push let-form *system-lets*)
261 (push let-form *user-lets*))))
263 (defun push-optional-binding (value-var init-form supplied-var condition path
264 name error-kind error-fun)
266 (setq supplied-var (gensym "SUPPLIEDP-")))
267 (push-let-binding supplied-var condition t)
268 (cond ((consp value-var)
269 (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
270 (push-sub-list-binding whole-thing
271 `(if ,supplied-var ,path ,init-form)
272 value-var name error-kind error-fun)
273 (parse-defmacro-lambda-list value-var whole-thing name
274 error-kind error-fun)))
276 (push-let-binding value-var path nil supplied-var init-form))
278 (error "Illegal optional variable name: ~S" value-var))))
280 (defun defmacro-error (problem kind name)
281 (error "Illegal or ill-formed ~A argument in ~A~@[ ~S~]."
284 ;;; Determine whether KEY-LIST is a valid list of keyword/value pairs. Do not
285 ;;; signal the error directly, 'cause we don't know how it should be signaled.
286 (defun verify-keywords (key-list valid-keys allow-other-keys)
287 (do ((already-processed nil)
288 (unknown-keyword nil)
289 (remaining key-list (cddr remaining)))
291 (if (and unknown-keyword
292 (not allow-other-keys)
293 (not (lookup-keyword :allow-other-keys key-list)))
294 (values :unknown-keyword (list unknown-keyword valid-keys))
296 (cond ((not (and (consp remaining) (listp (cdr remaining))))
297 (return (values :dotted-list key-list)))
298 ((null (cdr remaining))
299 (return (values :odd-length key-list)))
300 ((member (car remaining) already-processed)
301 (return (values :duplicate (car remaining))))
302 ((or (eq (car remaining) :allow-other-keys)
303 (member (car remaining) valid-keys))
304 (push (car remaining) already-processed))
306 (setq unknown-keyword (car remaining))))))
308 (defun lookup-keyword (keyword key-list)
309 (do ((remaining key-list (cddr remaining)))
311 (when (eq keyword (car remaining))
312 (return (cadr remaining)))))
314 (defun keyword-supplied-p (keyword key-list)
315 (do ((remaining key-list (cddr remaining)))
317 (when (eq keyword (car remaining))