1 ;;; lambda-list.lisp --- Lambda list parsing and destructuring
3 ;;; Copyright (C) 2013 David Vazquez
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.
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.
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/>.
18 (/debug "loading lambda-list.lisp!")
21 (defvar !lambda-list-keywords
22 '(&optional &rest &key &aux &allow-other-keys &body &optional))
24 ;;;; Lambda list parsing
27 variable initform supplied-p-parameter)
30 variable keyword-name initform supplied-p-parameter)
35 (def!struct lambda-list
44 (defun var-or-pattern (x)
47 (cons (parse-destructuring-lambda-list x))))
49 (defun parse-optvar (desc)
52 (make-optvar :variable desc))
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)
63 :supplied-p-parameter supplied-p-parameter)))))
65 (defun parse-keyvar (desc)
68 (make-keyvar :variable desc :keyword-name (intern (string desc) "KEYWORD")))
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)))
81 (setq keyword-name (intern (string name) "KEYWORD"))
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
93 :supplied-p-parameter supplied-p-parameter)))))
95 (defun parse-auxvar (desc)
98 (make-auxvar :variable desc))
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)))))
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)
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.
128 (and (consp lambda-list)
129 (not (find (first lambda-list) !lambda-list-keywords)))))
132 (when (lambda-section '&whole)
133 (let ((wholevar (pop lambda-list)))
134 (setf (lambda-list-wholevar ll) (var-or-pattern wholevar))))
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)))
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))))
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))
158 (setf (lambda-list-restvar ll)
159 (var-or-pattern (pop lambda-list))))
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))
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))))
183 (defmacro do-keywords (var value list &body body)
184 (let ((g!list (gensym)))
185 `(let ((,g!list ,list))
187 (let ((,var (car ,g!list))
188 (,value (cadr ,g!list)))
190 (setq ,g!list (cddr ,g!list))))))
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))))
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))))
206 (defun validate-reqvars (list n)
208 (error "`~S' is not a list." list))
209 (unless (<= n (length list))
210 (error "Invalid number of elements in `~S'" list))
213 (defun validate-max-args (list)
215 (error "Too many elements `~S' in the lambda-list" list))
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.
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)))
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.")))))
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)
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)
257 (push `(,pattern ,form) bindings)
259 ((lambda-list-p pattern)
260 (compute-bindings pattern form))))
262 ;; Compute the bindings for the full LAMBDA-LIST ll
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))
275 (dolist (reqvar (lambda-list-reqvars ll))
276 (compute-pbindings reqvar (nth-chain whole count))
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)))
289 ;; Rest-variable and keywords
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)))
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
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)
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)
322 (compute-pbindings supplied `(keyword-supplied-p ,keyword ,rest)))
323 (compute-pbindings variable `(if ,supplied
324 (keyword-lookup ,keyword ,rest)
325 ,(keyvar-initform keyvar)))))))
327 (dolist (auxvar (lambda-list-auxvars ll))
328 (compute-pbindings (auxvar-variable auxvar) (auxvar-initform auxvar))))
332 ;; Macroexpansion. Compute bindings and generate code for them
333 ;; and some necessary checking.
334 (compute-bindings ll expression)
335 `(let* ,(reverse bindings)
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
345 (defmacro !destructuring-bind (lambda-list expression &body body)
346 (apply #'!expand-destructuring-bind lambda-list expression body))
349 (eval-when (:compile-toplevel)
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)))