0.8.0.52
[sbcl.git] / src / code / parse-defmacro.lisp
1 ;;;; the PARSE-DEFMACRO function and related code
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!KERNEL")
13
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
23
24 ;; the default default for unsupplied &OPTIONAL and &KEY args
25 (defvar *default-default* nil)
26
27 ;;; temps that we introduce and might not reference
28 (defvar *ignorable-vars*)
29 (declaim (type list *ignorable-vars*))
30
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
35                                    &key
36                                    (anonymousp nil)
37                                    (doc-string-allowed t)
38                                    ((:environment env-arg-name))
39                                    ((:default-default *default-default*))
40                                    (error-fun 'error))
41   (multiple-value-bind (forms declarations documentation)
42       (parse-body body doc-string-allowed)
43     (let ((*arg-tests* ())
44           (*user-lets* ())
45           (*system-lets* ())
46           (*ignorable-vars* ())
47           (*env-var* nil))
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)
51                                       nil)
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*))))
57                    ,@*arg-tests*
58                    (let* ,(nreverse *user-lets*)
59                      ,@declarations
60                      ,@forms))
61                 `(,@(when (and env-arg-name (not env-arg-used))
62                       `((declare (ignore ,env-arg-name)))))
63                 documentation
64                 minimum
65                 maximum)))))
66
67 ;;; partial reverse-engineered documentation:
68 ;;;   TOPLEVEL is true for calls through PARSE-DEFMACRO from DEFSETF and
69 ;;;     DESTRUCTURING-BIND, false otherwise.
70 ;;; -- WHN 19990620
71 (defun parse-defmacro-lambda-list (possibly-dotted-lambda-list
72                                    arg-list-name
73                                    name
74                                    error-kind
75                                    error-fun
76                                    &optional
77                                    toplevel
78                                    env-illegal)
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.
82          (path-0 (if toplevel
83                      `(cdr ,arg-list-name)
84                      arg-list-name))
85          (path path-0) ; (will change below)
86          (now-processing :required)
87          (maximum 0)
88          (minimum 0)
89          (keys ())
90          (key-seen nil)
91          ;; ANSI specifies that dotted lists are "treated exactly as if the
92          ;; parameter name that ends the list had appeared preceded by &rest."
93          ;; We force this behavior by transforming dotted lists into ordinary
94          ;; lists with explicit &REST elements.
95          (lambda-list (do ((in-pdll possibly-dotted-lambda-list (cdr in-pdll))
96                            (reversed-result nil))
97                           ((atom in-pdll)
98                            (nreverse (if in-pdll
99                                          (list* in-pdll '&rest reversed-result)
100                                          reversed-result)))
101                         (push (car in-pdll) reversed-result)))
102          rest-name restp allow-other-keys-p env-arg-used)
103     (when (member '&whole (rest lambda-list))
104       (error "&WHOLE may only appear first in ~S lambda-list." error-kind))
105     (do ((rest-of-args lambda-list (cdr rest-of-args)))
106         ((null rest-of-args))
107       (macrolet ((process-sublist (var sublist-name path)
108                    (once-only ((var var))
109                      `(if (listp ,var)
110                           (let ((sub-list-name (gensym ,sublist-name)))
111                             (push-sub-list-binding sub-list-name ,path ,var
112                                                    name error-kind error-fun)
113                             (parse-defmacro-lambda-list ,var sub-list-name name
114                                                         error-kind error-fun))
115                           (push-let-binding ,var ,path nil)))))
116         (let ((var (car rest-of-args)))
117           (typecase var
118             (list
119              (case now-processing
120                ((:required)
121                 (when restp
122                   (defmacro-error "required argument after &REST/&BODY"
123                       error-kind name))
124                 (process-sublist var "SUBLIST-" `(car ,path))
125                 (setq path `(cdr ,path)
126                       minimum (1+ minimum)
127                       maximum (1+ maximum)))
128                ((:optionals)
129                 (destructuring-bind (varname &optional initform supplied-p)
130                     var
131                   (push-optional-binding varname initform supplied-p
132                                          `(not (null ,path)) `(car ,path)
133                                          name error-kind error-fun))
134                 (setq path `(cdr ,path)
135                       maximum (1+ maximum)))
136                ((:keywords)
137                 (let* ((keyword-given (consp (car var)))
138                        (variable (if keyword-given
139                                      (cadar var)
140                                      (car var)))
141                        (keyword (if keyword-given
142                                     (caar var)
143                                     (keywordicate variable)))
144                        (supplied-p (caddr var)))
145                   (push-optional-binding variable (cadr var) supplied-p
146                                          `(keyword-supplied-p ',keyword
147                                                               ,rest-name)
148                                          `(lookup-keyword ',keyword
149                                                           ,rest-name)
150                                          name error-kind error-fun)
151                   (push keyword keys)))
152                ((:auxs)
153                 (push-let-binding (car var) (cadr var) nil))))
154             ((and symbol (not (eql nil)))
155              (case var
156                (&whole
157                 (cond ((cdr rest-of-args)
158                        (setq rest-of-args (cdr rest-of-args))
159                        (process-sublist (car rest-of-args)
160                                         "WHOLE-LIST-" arg-list-name))
161                       (t
162                        (defmacro-error "&WHOLE" error-kind name))))
163                (&environment
164                 (cond (env-illegal
165                        (error "&ENVIRONMENT is not valid with ~S." error-kind))
166                       ((not toplevel)
167                        (error "&ENVIRONMENT is only valid at top level of ~
168                              lambda-list."))
169                       (env-arg-used
170                        (error "Repeated &ENVIRONMENT.")))
171                 (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
172                        (setq rest-of-args (cdr rest-of-args))
173                        (check-defmacro-arg (car rest-of-args))
174                        (setq *env-var* (car rest-of-args))
175                        (setq env-arg-used t))
176                       (t
177                        (defmacro-error "&ENVIRONMENT" error-kind name))))
178                ((&rest &body)
179                 (cond ((and (not restp) (cdr rest-of-args))
180                        (setq rest-of-args (cdr rest-of-args))
181                        (setq restp t)
182                        (process-sublist (car rest-of-args) "REST-LIST-" path))
183                       (t
184                        (defmacro-error (symbol-name var) error-kind name))))
185                (&optional
186                 (setq now-processing :optionals))
187                (&key
188                 (setq now-processing :keywords)
189                 (setq rest-name (gensym "KEYWORDS-"))
190                 (push rest-name *ignorable-vars*)
191                 (setq restp t)
192                 (setq key-seen t)
193                 (push-let-binding rest-name path t))
194                (&allow-other-keys
195                 (setq allow-other-keys-p t))
196                (&aux
197                 (setq now-processing :auxs))
198                ;; FIXME: Other lambda list keywords.
199                (t
200                 (case now-processing
201                   ((:required)
202                    (when restp
203                      (defmacro-error "required argument after &REST/&BODY"
204                          error-kind name))
205                    (push-let-binding var `(car ,path) nil)
206                    (setq minimum (1+ minimum)
207                          maximum (1+ maximum)
208                          path `(cdr ,path)))
209                   ((:optionals)
210                    (push-let-binding var `(car ,path) nil `(not (null ,path)))
211                    (setq path `(cdr ,path)
212                          maximum (1+ maximum)))
213                   ((:keywords)
214                    (let ((key (keywordicate var)))
215                      (push-let-binding var
216                                        `(lookup-keyword ,key ,rest-name)
217                                        nil)
218                      (push key keys)))
219                   ((:auxs)
220                    (push-let-binding var nil nil))))))
221             (t
222              (error "non-symbol in lambda-list: ~S" var))))))
223     (let (;; common subexpression, suitable for passing to functions
224           ;; which expect a MAXIMUM argument regardless of whether
225           ;; there actually is a maximum number of arguments
226           ;; (expecting MAXIMUM=NIL when there is no maximum)
227           (explicit-maximum (and (not restp) maximum)))
228       (unless (and restp (zerop minimum))
229         (push `(unless ,(if restp
230                             ;; (If RESTP, then the argument list might be
231                             ;; dotted, in which case ordinary LENGTH won't
232                             ;; work.)
233                             `(list-of-length-at-least-p ,path-0 ,minimum)
234                             `(proper-list-of-length-p ,path-0 ,minimum ,maximum))
235                  ,(if (eq error-fun 'error)
236                       `(arg-count-error ',error-kind ',name ,path-0
237                                         ',lambda-list ,minimum
238                                         ,explicit-maximum)
239                       `(,error-fun 'arg-count-error
240                                    :kind ',error-kind
241                                    ,@(when name `(:name ',name))
242                                    :args ,path-0
243                                    :lambda-list ',lambda-list
244                                    :minimum ,minimum
245                                    :maximum ,explicit-maximum)))
246               *arg-tests*))
247       (when key-seen
248         (let ((problem (gensym "KEY-PROBLEM-"))
249               (info (gensym "INFO-")))
250           (push `(multiple-value-bind (,problem ,info)
251                      (verify-keywords ,rest-name
252                                       ',keys
253                                       ',allow-other-keys-p)
254                    (when ,problem
255                      (,error-fun
256                       'defmacro-lambda-list-broken-key-list-error
257                       :kind ',error-kind
258                       ,@(when name `(:name ',name))
259                       :problem ,problem
260                       :info ,info)))
261                 *arg-tests*)))
262       (values env-arg-used minimum explicit-maximum))))
263
264 ;;; We save space in macro definitions by calling this function.
265 (defun arg-count-error (error-kind name args lambda-list minimum maximum)
266   (let (#-sb-xc-host
267         (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
268     (error 'arg-count-error
269            :kind error-kind
270            :name name
271            :args args
272            :lambda-list lambda-list
273            :minimum minimum
274            :maximum maximum)))
275
276 (defun push-sub-list-binding (variable path object name error-kind error-fun)
277   (check-defmacro-arg variable)
278   (let ((var (gensym "TEMP-")))
279     (push `(,variable
280             (let ((,var ,path))
281               (if (listp ,var)
282                 ,var
283                 (,error-fun 'defmacro-bogus-sublist-error
284                             :kind ',error-kind
285                             ,@(when name `(:name ',name))
286                             :object ,var
287                             :lambda-list ',object))))
288           *system-lets*)))
289
290 (defun push-let-binding (variable path systemp &optional condition
291                                   (init-form *default-default*))
292   (check-defmacro-arg variable)
293   (let ((let-form (if condition
294                       `(,variable (if ,condition ,path ,init-form))
295                       `(,variable ,path))))
296     (if systemp
297       (push let-form *system-lets*)
298       (push let-form *user-lets*))))
299
300 (defun push-optional-binding (value-var init-form supplied-var condition path
301                                         name error-kind error-fun)
302   (unless supplied-var
303     (setq supplied-var (gensym "SUPPLIEDP-")))
304   (push-let-binding supplied-var condition t)
305   (cond ((consp value-var)
306          (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
307            (push-sub-list-binding whole-thing
308                                   `(if ,supplied-var ,path ,init-form)
309                                   value-var name error-kind error-fun)
310            (parse-defmacro-lambda-list value-var whole-thing name
311                                        error-kind error-fun)))
312         ((symbolp value-var)
313          (push-let-binding value-var path nil supplied-var init-form))
314         (t
315          (error "illegal optional variable name: ~S" value-var))))
316
317 (defun defmacro-error (problem kind name)
318   (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]"
319          problem kind name))
320
321 (defun check-defmacro-arg (arg)
322   (when (or (and *env-var* (eq arg *env-var*))
323             (member arg *system-lets* :key #'car)
324             (member arg *user-lets* :key #'car))
325     (error "variable ~S occurs more than once" arg)))
326
327 ;;; Determine whether KEY-LIST is a valid list of keyword/value pairs.
328 ;;; Do not signal the error directly, 'cause we don't know how it
329 ;;; should be signaled.
330 (defun verify-keywords (key-list valid-keys allow-other-keys)
331   (do ((already-processed nil)
332        (unknown-keyword nil)
333        (remaining key-list (cddr remaining)))
334       ((null remaining)
335        (if (and unknown-keyword
336                 (not allow-other-keys)
337                 (not (lookup-keyword :allow-other-keys key-list)))
338            (values :unknown-keyword (list unknown-keyword valid-keys))
339            (values nil nil)))
340     (cond ((not (and (consp remaining) (listp (cdr remaining))))
341            (return (values :dotted-list key-list)))
342           ((null (cdr remaining))
343            (return (values :odd-length key-list)))
344           ((or (eq (car remaining) :allow-other-keys)
345                (member (car remaining) valid-keys))
346            (push (car remaining) already-processed))
347           (t
348            (setq unknown-keyword (car remaining))))))
349
350 (defun lookup-keyword (keyword key-list)
351   (do ((remaining key-list (cddr remaining)))
352       ((endp remaining))
353     (when (eq keyword (car remaining))
354       (return (cadr remaining)))))
355
356 (defun keyword-supplied-p (keyword key-list)
357   (do ((remaining key-list (cddr remaining)))
358       ((endp remaining))
359     (when (eq keyword (car remaining))
360       (return t))))