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