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