Add TEST-NOT keyword argument to TREE-EQUAL
[jscl.git] / src / lambda-list.lisp
1 ;;; lambda-list.lisp --- Lambda list parsing and destructuring
2
3 ;;; Copyright (C) 2013 David Vazquez
4
5 ;; JSCL is free software: you can redistribute it and/or
6 ;; modify it under the terms of the GNU General Public License as
7 ;; published by the Free Software Foundation, either version 3 of the
8 ;; License, or (at your option) any later version.
9 ;;
10 ;; JSCL is distributed in the hope that it will be useful, but
11 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13 ;; General Public License for more details.
14 ;;
15 ;; You should have received a copy of the GNU General Public License
16 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
17
18 (defvar !lambda-list-keywords
19   '(&optional &rest &key &aux &allow-other-keys &body &optional))
20
21 ;;;; Lambda list parsing
22
23 (def!struct optvar
24   variable initform supplied-p-parameter)
25
26 (def!struct keyvar
27   variable keyword-name initform supplied-p-parameter)
28
29 (def!struct auxvar
30   variable initform)
31
32 (def!struct d-lambda-list
33   wholevar
34   reqvars
35   optvars
36   restvar
37   allow-other-keys
38   keyvars
39   auxvars)
40
41 (defun var-or-pattern (x)
42   (etypecase x
43     (symbol x)
44     (cons (parse-destructuring-lambda-list x))))
45
46 (defun parse-optvar (desc)
47   (etypecase desc
48     (symbol
49      (make-optvar :variable desc))
50     (cons
51      (let ((variable (first desc))
52            (initform (second desc))
53            (supplied-p-parameter (third desc)))
54        (unless (null (cdddr desc))
55          (error "Bad optional parameter specification `~S'" desc))
56        (unless (symbolp supplied-p-parameter)
57          (error "`~S' is not a valid supplied optional parameter." supplied-p-parameter))
58        (make-optvar :variable (var-or-pattern variable)
59                     :initform initform
60                     :supplied-p-parameter supplied-p-parameter)))))
61
62 (defun parse-keyvar (desc)
63   (etypecase desc
64     (symbol
65      (make-keyvar :variable desc :keyword-name (intern (string desc) "KEYWORD")))
66     (cons
67      (let (variable
68            keyword-name
69            (initform (second desc))
70            (supplied-p-parameter (third desc)))
71        (unless (null (cdddr desc))
72          (error "Bad keyword parameter specification `~S'" desc))
73        (unless (symbolp supplied-p-parameter)
74          (error "`~S' is not a valid supplied optional parameter." supplied-p-parameter))
75        (let ((name (first desc)))
76          (etypecase name
77            (symbol
78             (setq keyword-name (intern (string name) "KEYWORD"))
79             (setq variable name))
80            (cons
81             (unless (null (cddr name))
82               (error "Bad keyword argument name description `~S'" name))
83             (setq keyword-name (first name))
84             (setq variable (second name)))))
85        (unless (symbolp keyword-name)
86          (error "~S is not a valid keyword-name." keyword-name))
87        (make-keyvar :variable (var-or-pattern variable)
88                     :keyword-name keyword-name
89                     :initform initform
90                     :supplied-p-parameter supplied-p-parameter)))))
91
92 (defun parse-auxvar (desc)
93   (etypecase desc
94     (symbol
95      (make-auxvar :variable desc))
96     (cons
97      (let ((variable (first desc))
98            (initform (second desc)))
99        (unless (null (cdddr desc))
100          (error "Bad aux variable specification `~S'" desc))
101        (make-auxvar :variable (var-or-pattern variable)
102                     :initform initform)))))
103
104 (defun parse-destructuring-lambda-list (lambda-list)
105   (let (;; Destructured lambda list structure where we accumulate the
106         ;; results of the parsing.
107         (d-ll (make-d-lambda-list))
108         ;; List of lambda list keywords which we have already seen.
109         (lambda-keywords nil))
110     (flet ( ;; Check if we are in the beginning of the section NAME in
111            ;; the lambda list. It checks also if the section is in the
112            ;; proper place and it is new.
113            (lambda-section (name)
114              (let ((section (first lambda-list)))
115                (when (find section lambda-keywords)
116                  (error "Bad placed ~a in the lambda-list ~S." section lambda-list))
117                (when (eq name section)
118                  (push name lambda-keywords)
119                  (pop lambda-list)
120                  t)))
121            ;; Check if we are in the middle of a lambda list section,
122            ;; looking for a lambda list keyword in the current
123            ;; position of the lambda list.
124            (in-section-p ()
125              (and (consp lambda-list)
126                   (not (find (first lambda-list) !lambda-list-keywords)))))
127       
128       ;; &whole var
129       (when (lambda-section '&whole)
130         (let ((wholevar (pop lambda-list)))
131           (setf (d-lambda-list-wholevar d-ll) (var-or-pattern wholevar))))
132       
133       ;; required vars
134       (while (in-section-p)
135         (let ((var (pop lambda-list)))
136           (push (var-or-pattern var) (d-lambda-list-reqvars d-ll))))
137       (setf (d-lambda-list-reqvars d-ll)
138             (reverse (d-lambda-list-reqvars d-ll)))
139       
140       ;; optional vars
141       (when (lambda-section '&optional)
142         (while (in-section-p)
143           (push (parse-optvar (pop lambda-list))
144                 (d-lambda-list-optvars d-ll)))
145         (setf (d-lambda-list-optvars d-ll)
146               (reverse (d-lambda-list-optvars d-ll))))
147       
148       ;; Dotted lambda-list and &rest/&body vars. If the lambda-list
149       ;; is dotted. Convert it the tail to a &rest and finish.
150       (when (and lambda-list (atom lambda-list))
151         (push lambda-list (d-lambda-list-restvar d-ll))
152         (setq lambda-list nil))
153       (when (find (car lambda-list) '(&body &rest))
154         (pop lambda-list)
155         (setf (d-lambda-list-restvar d-ll)
156               (var-or-pattern (pop lambda-list))))
157
158       ;; Keyword arguments
159       (when (lambda-section '&key)
160         (while (in-section-p)
161           (push (parse-keyvar (pop lambda-list))
162                 (d-lambda-list-keyvars d-ll)))
163         (setf (d-lambda-list-keyvars d-ll)
164               (reverse (d-lambda-list-keyvars d-ll))))      
165       (when (lambda-section '&allow-other-keys)
166         (setf (d-lambda-list-allow-other-keys d-ll) t))
167
168       ;; Aux variables
169       (when (lambda-section '&aux)
170         (while (in-section-p)
171           (push (parse-auxvar (pop lambda-list))
172                 (d-lambda-list-auxvars d-ll)))
173         (setf (d-lambda-list-auxvars d-ll)
174               (reverse (d-lambda-list-auxvars d-ll))))
175       d-ll)))
176
177
178 ;;;; Destructuring
179
180 (defmacro do-keywords (var value list &body body)
181   (let ((g!list (gensym)))
182     `(let ((,g!list ,list))
183        (while ,g!list
184          (let ((,var (car ,g!list))
185                (,value (cadr ,g!list)))
186            ,@body)
187          (setq ,g!list (cddr ,g!list))))))
188
189 ;;; Return T if KEYWORD is supplied in the list of arguments LIST.
190 (defun keyword-supplied-p (keyword list)
191   (do-keywords key value list
192     (declare (ignore value))
193     (when (eq key keyword) (return t))
194     (setq list (cddr list))))
195
196 ;;; Return the value of KEYWORD in the list of arguments LIST or NIL
197 ;;; if it is not supplied.
198 (defun keyword-lookup (keyword list)
199   (do-keywords key value list
200     (when (eq key keyword) (return value))
201     (setq list (cddr list))))
202
203 (defun validate-reqvars (list n)
204   (unless (listp list)
205     (error "`~S' is not a list." list))
206   (unless (<= n (length list))
207     (error "Invalid number of elements in `~S'" list))
208   list)
209
210 (defun validate-max-args (list)
211   (unless (null list)
212     (error "Too many elements `~S' in the lambda-list" list))
213   list)
214
215 ;;; Validate a list of keyword arguments.
216 (defun validate-keyvars (list keyword-list &optional allow-other-keys)
217   (let (;; If it is non-NIL, we have to check for unknown keyword
218         ;; arguments in the list to signal an error in that case.
219         (allow-other-keys
220          (or allow-other-keys (keyword-lookup :allow-other-keys list))))
221     (unless allow-other-keys
222       (do-keywords key value list
223         (declare (ignore value))
224         (unless (find key keyword-list)
225           (error "Unknown keyword argument `~S'." key))))
226     (do* ((tail list (cddr tail))
227           (key (car tail) (car tail)))
228          ((null tail) list)
229       (unless (symbolp key)
230         (error "Keyword argument `~S' is not a symbol." key))
231       (unless (consp (cdr tail))
232         (error "Odd number of keyword arguments.")))))
233
234
235 (defun !expand-destructuring-bind (lambda-list expression &rest body)
236   (multiple-value-bind (d-ll)
237       (parse-destructuring-lambda-list lambda-list)
238     (let ((bindings '()))
239       (labels ( ;; Return a chain of the form (CAR (CDR (CDR ... (CDR X))),
240                ;; such that there are N calls to CDR.
241                (nth-chain (x n &optional tail)
242                  (if tail
243                      (if (zerop n) x `(cdr ,(nth-chain x (1- n) t)))
244                      `(car ,(nth-chain x n t))))
245                ;; Compute the bindings for a pattern against FORM. If
246                ;; PATTERN is a lambda-list the pattern is bound to an
247                ;; auxiliary variable, otherwise PATTERN must be a
248                ;; symbol it will be bound to the form. The variable
249                ;; where the form is bound is returned.
250                (compute-pbindings (pattern form)
251                  (cond
252                    ((null pattern))
253                    ((symbolp pattern)
254                     (push `(,pattern ,form) bindings)
255                     pattern)
256                    ((d-lambda-list-p pattern)
257                     (compute-bindings pattern form))))
258                
259                ;; Compute the bindings for the full D-LAMBDA-LIST d-ll
260                ;; against FORM.
261                (compute-bindings (d-ll form)
262                  (let ((reqvar-count (length (d-lambda-list-reqvars d-ll)))
263                        (optvar-count (length (d-lambda-list-optvars d-ll)))
264                        (whole (or (d-lambda-list-wholevar d-ll) (gensym))))
265                    ;; Create a binding for the whole expression
266                    ;; FORM. It will match to D-LL, so we validate the
267                    ;; number of elements on the result of FORM.
268                    (compute-pbindings whole `(validate-reqvars ,form ,reqvar-count))
269                    
270                    (let ((count 0))
271                      ;; Required vars
272                      (dolist (reqvar (d-lambda-list-reqvars d-ll))
273                        (compute-pbindings reqvar (nth-chain whole count))
274                        (incf count))
275                      ;; Optional vars
276                      (dolist (optvar (d-lambda-list-optvars d-ll))
277                        (when (optvar-supplied-p-parameter optvar)
278                          (compute-pbindings (optvar-supplied-p-parameter optvar)
279                                             `(not (null ,(nth-chain whole count t)))))
280                        (compute-pbindings (optvar-variable optvar)
281                                           `(if (null ,(nth-chain whole count t))
282                                                ,(optvar-initform optvar)
283                                                ,(nth-chain whole count)))
284                        (incf count))
285
286                      ;; Rest-variable and keywords
287                      
288                      ;; If there is a rest or keyword variable, we
289                      ;; will add a binding for the rest or an
290                      ;; auxiliary variable. The computations in of the
291                      ;; keyword start in this variable, so we avoid
292                      ;; the long tail of nested CAR/CDR operations
293                      ;; each time. We also include validation of
294                      ;; keywords if there is any.
295                      (let* ((chain (nth-chain whole (+ reqvar-count optvar-count) t))
296                             (restvar (d-lambda-list-restvar d-ll))
297                             (pattern (or restvar (gensym)))
298                             (keywords (mapcar #'keyvar-keyword-name (d-lambda-list-keyvars d-ll)))
299                             (rest
300                              ;; Create a binding for the rest of the
301                              ;; arguments. If there is keywords, then
302                              ;; validate this list. If there is no
303                              ;; keywords and no &rest variable, then
304                              ;; validate that the rest is empty, it is
305                              ;; to say, there is no more arguments
306                              ;; that we expect.
307                              (cond
308                                (keywords (compute-pbindings pattern `(validate-keyvars ,chain ',keywords ,(d-lambda-list-allow-other-keys d-ll))))
309                                (restvar  (compute-pbindings pattern chain))
310                                (t        (compute-pbindings pattern `(validate-max-args ,chain))))))
311                        (when (d-lambda-list-keyvars d-ll)
312                          ;; Keywords
313                          (dolist (keyvar (d-lambda-list-keyvars d-ll))
314                            (let ((variable (keyvar-variable keyvar))
315                                  (keyword (keyvar-keyword-name keyvar))
316                                  (supplied (or (keyvar-supplied-p-parameter keyvar)
317                                                (gensym))))
318                              (when supplied
319                                (compute-pbindings supplied `(keyword-supplied-p ,keyword ,rest)))
320                              (compute-pbindings variable `(if ,supplied
321                                                               (keyword-lookup ,keyword ,rest)
322                                                               ,(keyvar-initform keyvar)))))))
323                      ;; Aux variables
324                      (dolist (auxvar (d-lambda-list-auxvars d-ll))
325                        (compute-pbindings (auxvar-variable auxvar) (auxvar-initform auxvar))))
326                    
327                    whole)))
328
329         ;; Macroexpansion. Compute bindings and generate code for them
330         ;; and some necessary checking.
331         (compute-bindings d-ll expression)
332         `(let* ,(reverse bindings)
333            ,@body)))))
334
335
336 ;;; Because DEFMACRO uses destructuring-bind to parse the arguments of
337 ;;; the macro-function, we can't define DESTRUCTURING-BIND with
338 ;;; defmacro to avoid a circularity. So just define the macro function
339 ;;; explicitly.
340
341 #-jscl
342 (defmacro !destructuring-bind (lambda-list expression &body body)
343   (apply #'!expand-destructuring-bind lambda-list expression body))
344
345 #+jscl
346 (eval-when-compile
347   (let ((macroexpander
348          '#'(lambda (form &optional environment)
349               (declare (ignore environment))
350               (apply #'!expand-destructuring-bind form))))
351     (%compile-defmacro '!destructuring-bind macroexpander)
352     (%compile-defmacro  'destructuring-bind macroexpander)))