Silence notes about being specialised EQ templates on x86oids
[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 whole-var 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   (unless (listp lambda-list)
43     (bad-type lambda-list 'list "~S lambda-list is not a list: ~S"
44               context lambda-list))
45   (multiple-value-bind (forms declarations documentation)
46       (parse-body body :doc-string-allowed doc-string-allowed)
47     (let ((*arg-tests* ())
48           (*user-lets* ())
49           (*system-lets* ())
50           (*ignorable-vars* ())
51           (*env-var* nil))
52       (multiple-value-bind (env-arg-used minimum maximum)
53           (parse-defmacro-lambda-list lambda-list whole-var name context
54                                       :error-fun error-fun
55                                       :anonymousp anonymousp)
56         (values `(let* (,@(nreverse *system-lets*))
57                    #-sb-xc-host
58                    (declare (muffle-conditions sb!ext:code-deletion-note))
59                    ,@(when *ignorable-vars*
60                        `((declare (ignorable ,@*ignorable-vars*))))
61                    ,@*arg-tests*
62                    (let* (,@(when env-arg-used
63                             `((,*env-var* ,env-arg-name)))
64                           ,@(nreverse *user-lets*))
65                      ,@declarations
66                      ,@(if wrap-block
67                            `((block ,(fun-name-block-name name)
68                                ,@forms))
69                            forms)))
70                 `(,@(when (and env-arg-name (not env-arg-used))
71                       `((declare (ignore ,env-arg-name)))))
72                 documentation
73                 minimum
74                 maximum)))))
75
76 (defun parse-defmacro-lambda-list (possibly-dotted-lambda-list
77                                    whole-var
78                                    name
79                                    context
80                                    &key
81                                    error-fun
82                                    anonymousp
83                                    env-illegal
84                                    sublist)
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)
92          (maximum 0)
93          (minimum 0)
94          (keys ())
95          (key-seen nil)
96          (aux-seen nil)
97          (optional-seen nil)
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))
104                           ((atom in-pdll)
105                            (nreverse (if in-pdll
106                                          (list* in-pdll '&rest reversed-result)
107                                          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
119                         :system t
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))
127                      `(if (listp ,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
132                                                         context
133                                                         :error-fun error-fun
134                                                         :sublist t))
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)))
140           (typecase var
141             (list
142              (case now-processing
143                ((:required)
144                 (when restp
145                   (defmacro-error (format nil "required argument after ~A"
146                                           restp)
147                       context name))
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)
153                       minimum (1+ minimum)
154                       maximum (1+ maximum)))
155                ((:optionals)
156                 (normalize-singleton var)
157                 (destructuring-bind
158                       (varname &optional default-form suppliedp-name)
159                     var
160                   (push-optional-binding varname default-form suppliedp-name
161                                          :is-supplied-p `(not (null ,path))
162                                          :path `(car ,path)
163                                          :name name
164                                          :context context
165                                          :error-fun error-fun))
166                 (setq path `(cdr ,path)
167                       maximum (1+ maximum)))
168                ((:keywords)
169                 (normalize-singleton var)
170                 (let* ((keyword-given (consp (car var)))
171                        (variable (if keyword-given
172                                      (cadar var)
173                                      (car var)))
174                        (keyword (if keyword-given
175                                     (caar var)
176                                     (keywordicate variable)))
177                        (default-form (cadr var))
178                        (suppliedp-name (caddr var)))
179                   (push-optional-binding variable default-form suppliedp-name
180                                          :is-supplied-p
181                                          `(keyword-supplied-p ',keyword
182                                                               ,rest-name)
183                                          :path
184                                          `(lookup-keyword ',keyword ,rest-name)
185                                          :name name
186                                          :context context
187                                          :error-fun error-fun)
188                   (push keyword keys)))
189                ((:auxs)
190                 (push-let-binding (car var) (cadr var)))))
191             ((and symbol (not (eql nil)))
192              (case var
193                (&whole
194                 (cond ((cdr rest-of-lambda-list)
195                        (pop rest-of-lambda-list)
196                        (process-sublist (car rest-of-lambda-list)
197                                         "WHOLE-LIST-"
198                                         (if (eq 'define-compiler-macro context)
199                                             compiler-macro-whole
200                                             whole-var)))
201                       (t
202                        (defmacro-error "&WHOLE" context name))))
203                (&environment
204                 (cond (env-illegal
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 ~
210                              lambda-list."))
211                       (env-arg-used
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)
218                              env-arg-used t))
219                       (t
220                        (defmacro-error "&ENVIRONMENT" context name))))
221                ((&rest &body)
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)
227                              restp var)
228                        (process-sublist (car rest-of-lambda-list)
229                                         "REST-LIST-" path))
230                       (t
231                        (defmacro-error (symbol-name var) context name))))
232                (&optional
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))
236                 (when optional-seen
237                   (error "Multiple ~A in ~A lambda list." var context))
238                 (setq now-processing :optionals
239                       optional-seen var))
240                (&key
241                 (when aux-seen
242                   (error "~A after ~A in ~A lambda-list." '&key '&aux context))
243                 (when key-seen
244                   (error "Multiple ~A in ~A lambda-list." '&key context))
245                 (setf now-processing :keywords
246                       rest-name (gensym "KEYWORDS-")
247                       restp var
248                       key-seen var)
249                 (push rest-name *ignorable-vars*)
250                 (push-let-binding rest-name path :system t))
251                (&allow-other-keys
252                 (unless (eq now-processing :keywords)
253                   (error "~A outside ~A section of lambda-list in ~A."
254                          var '&key context))
255                 (when allow-other-keys-p
256                   (error "Multiple ~A in ~A lambda-list." var context))
257                 (setq allow-other-keys-p t))
258                (&aux
259                 (when (eq context 'defsetf)
260                   (error "~A not allowed in a ~A lambda-list." var context))
261                 (when aux-seen
262                   (error "Multiple ~A in ~A lambda-list." '&aux context))
263                 (setq now-processing :auxs
264                       aux-seen var))
265                ;; FIXME: Other lambda list keywords.
266                (t
267                 (case now-processing
268                   ((:required)
269                    (when restp
270                      (defmacro-error (format nil "required argument after ~A"
271                                              restp)
272                          context name))
273                    (push-let-binding var `(car ,path))
274                    (setq minimum (1+ minimum)
275                          maximum (1+ maximum)
276                          path `(cdr ,path)))
277                   ((:optionals)
278                    (push-let-binding var `(car ,path)
279                                      :when `(not (null ,path)))
280                    (setq path `(cdr ,path)
281                          maximum (1+ maximum)))
282                   ((:keywords)
283                    (let ((key (keywordicate var)))
284                      (push-let-binding
285                       var
286                       `(lookup-keyword ,key ,rest-name)
287                       :when `(keyword-supplied-p ,key ,rest-name))
288                      (push key keys)))
289                   ((:auxs)
290                    (push-let-binding var nil))))))
291             (t
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))
301                                         (cdr ,path-0)
302                                         ,path-0)
303                                    path-0)))
304                 (with-unique-names (args)
305                   `(let ((,args ,args-form))
306                      (unless ,(if restp
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
312                                                             ,minimum
313                                                             ,maximum))
314                        ,(if (eq error-fun 'error)
315                             `(arg-count-error ',context ',name ,args
316                                               ',lambda-list ,minimum
317                                               ,explicit-maximum)
318                             `(,error-fun 'arg-count-error
319                                          :kind ',context
320                                          ,@(when name `(:name ',name))
321                                          :args ,args
322                                          :lambda-list ',lambda-list
323                                          :minimum ,minimum
324                                          :maximum ,explicit-maximum))))))
325               *arg-tests*))
326       (when key-seen
327         (with-unique-names (problem info)
328           (push `(multiple-value-bind (,problem ,info)
329                      (verify-keywords ,rest-name
330                                       ',keys
331                                       ',allow-other-keys-p
332                                       ,(eq 'define-compiler-macro context))
333                    (when ,problem
334                      (,error-fun
335                       'defmacro-lambda-list-broken-key-list-error
336                       :kind ',context
337                       ,@(when name `(:name ',name))
338                       :problem ,problem
339                       :info ,info)))
340                 *arg-tests*)))
341       (values env-arg-used minimum explicit-maximum))))
342
343 ;;; We save space in macro definitions by calling this function.
344 (defun arg-count-error (context name args lambda-list minimum maximum)
345   (let (#-sb-xc-host
346         (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'arg-count-error)))
347     (error 'arg-count-error
348            :kind context
349            :name name
350            :args args
351            :lambda-list lambda-list
352            :minimum minimum
353            :maximum maximum)))
354
355 (defun push-sublist-binding (variable path object name context error-fun)
356   (check-defmacro-arg variable)
357   (let ((var (gensym "TEMP-")))
358     (push `(,variable
359             (let ((,var ,path))
360               (if (listp ,var)
361                 ,var
362                 (,error-fun 'defmacro-bogus-sublist-error
363                             :kind ',context
364                             ,@(when name `(:name ',name))
365                             :object ,var
366                             :lambda-list ',object))))
367           *system-lets*)))
368
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))))
375     (if system
376         (push let-form *system-lets*)
377         (push let-form *user-lets*))))
378
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
390                                        context
391                                        :error-fun error-fun
392                                        :sublist t)))
393         ((symbolp value-var)
394          (push-let-binding value-var path :when suppliedp-name :else init-form))
395         (t
396          (error "illegal optional variable name: ~S" value-var))))
397
398 (defun defmacro-error (problem context name)
399   (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]"
400          problem context name))
401
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)))
407
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)))
415       ((null 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))
420            (values nil nil)))
421     (let ((key (when (consp remaining)
422                  (car 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.
430       ;;
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)
436                           (and (symbolp key)
437                                (constantp 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))
443             (t
444              (setq unknown-keyword key))))))
445
446 (defun lookup-keyword (keyword key-list)
447   (do ((remaining key-list (cddr remaining)))
448       ((endp remaining))
449     (when (eq keyword (car remaining))
450       (return (cadr remaining)))))
451
452 (defun keyword-supplied-p (keyword key-list)
453   (do ((remaining key-list (cddr remaining)))
454       ((endp remaining))
455     (when (eq keyword (car remaining))
456       (return t))))