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