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