1 ;;; lambda-list.lisp --- Lambda list parsing and destructuring
3 ;; JSCL is free software: you can redistribute it and/or
4 ;; modify it under the terms of the GNU General Public License as
5 ;; published by the Free Software Foundation, either version 3 of the
6 ;; License, or (at your option) any later version.
8 ;; JSCL is distributed in the hope that it will be useful, but
9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 ;; General Public License for more details.
13 ;; You should have received a copy of the GNU General Public License
14 ;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
16 (defconstant !lambda-list-keywords
17 '(&optional &rest &key &aux &allow-other-keys &body &optional))
19 ;;;; Lambda list parsing
22 variable initform supplied-p-parameter)
25 variable keyword-name initform supplied-p-parameter)
30 (def!struct d-lambda-list
39 (defun var-or-pattern (x)
42 (cons (parse-destructuring-lambda-list x))))
44 (defun parse-optvar (desc)
47 (make-optvar :variable desc))
49 (let ((variable (first desc))
50 (initform (second desc))
51 (supplied-p-parameter (third desc)))
52 (unless (null (cdddr desc))
53 (error "Bad optional parameter specification `~S'" desc))
54 (unless (symbolp supplied-p-parameter)
55 (error "`~S' is not a valid supplied optional parameter." supplied-p-parameter))
56 (make-optvar :variable (var-or-pattern variable)
58 :supplied-p-parameter supplied-p-parameter)))))
60 (defun parse-keyvar (desc)
63 (make-keyvar :variable desc :keyword-name (intern (string desc) "KEYWORD")))
67 (initform (second desc))
68 (supplied-p-parameter (third desc)))
69 (unless (null (cdddr desc))
70 (error "Bad keyword parameter specification `~S'" desc))
71 (unless (symbolp supplied-p-parameter)
72 (error "`~S' is not a valid supplied optional parameter." supplied-p-parameter))
73 (let ((name (first desc)))
76 (setq keyword-name (intern (string name) "KEYWORD"))
79 (unless (null (cddr name))
80 (error "Bad keyword argument name description `~S'" name))
81 (setq keyword-name (first name))
82 (setq variable (second name)))))
83 (unless (symbolp keyword-name)
84 (error "~S is not a valid keyword-name." keyword-name))
85 (make-keyvar :variable (var-or-pattern variable)
86 :keyword-name keyword-name
88 :supplied-p-parameter supplied-p-parameter)))))
90 (defun parse-auxvar (desc)
93 (make-auxvar :variable desc))
95 (let ((variable (first desc))
96 (initform (second desc)))
97 (unless (null (cdddr desc))
98 (error "Bad aux variable specification `~S'" desc))
99 (make-auxvar :variable (var-or-pattern variable)
100 :initform initform)))))
102 (defun parse-destructuring-lambda-list (lambda-list)
103 (let (;; Destructured lambda list structure where we accumulate the
104 ;; results of the parsing.
105 (d-ll (make-d-lambda-list))
106 ;; List of lambda list keywords which we have already seen.
107 (lambda-keywords nil))
108 (flet ( ;; Check if we are in the beginning of the section NAME in
109 ;; the lambda list. It checks also if the section is in the
110 ;; proper place and it is new.
111 (lambda-section (name)
112 (let ((section (first lambda-list)))
113 (when (find section lambda-keywords)
114 (error "Bad placed ~a in the lambda-list ~S." section lambda-list))
115 (when (eq name section)
116 (push name lambda-keywords)
119 ;; Check if we are in the middle of a lambda list section,
120 ;; looking for a lambda list keyword in the current
121 ;; position of the lambda list.
123 (and (consp lambda-list)
124 (not (find (first lambda-list) !lambda-list-keywords)))))
127 (when (lambda-section '&whole)
128 (let ((wholevar (pop lambda-list)))
129 (setf (d-lambda-list-wholevar d-ll) (var-or-pattern wholevar))))
132 (while (in-section-p)
133 (let ((var (pop lambda-list)))
134 (push (var-or-pattern var) (d-lambda-list-reqvars d-ll))))
135 (setf (d-lambda-list-reqvars d-ll)
136 (reverse (d-lambda-list-reqvars d-ll)))
139 (when (lambda-section '&optional)
140 (while (in-section-p)
141 (push (parse-optvar (pop lambda-list))
142 (d-lambda-list-optvars d-ll)))
143 (setf (d-lambda-list-optvars d-ll)
144 (reverse (d-lambda-list-optvars d-ll))))
146 ;; Dotted lambda-list and &rest/&body vars. If the lambda-list
147 ;; is dotted. Convert it the tail to a &rest and finish.
148 (when (and lambda-list (atom lambda-list))
149 (push lambda-list (d-lambda-list-restvar d-ll))
150 (setq lambda-list nil))
151 (when (find (car lambda-list) '(&body &rest))
153 (setf (d-lambda-list-restvar d-ll)
154 (var-or-pattern (pop lambda-list))))
157 (when (lambda-section '&key)
158 (while (in-section-p)
159 (push (parse-keyvar (pop lambda-list))
160 (d-lambda-list-keyvars d-ll)))
161 (setf (d-lambda-list-keyvars d-ll)
162 (reverse (d-lambda-list-keyvars d-ll))))
163 (when (lambda-section '&allow-other-keys)
164 (setf (d-lambda-list-allow-other-keys d-ll) t))
167 (when (lambda-section '&aux)
168 (while (in-section-p)
169 (push (parse-auxvar (pop lambda-list))
170 (d-lambda-list-auxvars d-ll)))
171 (setf (d-lambda-list-auxvars d-ll)
172 (reverse (d-lambda-list-auxvars d-ll))))
178 (defmacro do-keywords (var value list &body body)
179 (let ((g!list (gensym)))
180 `(let ((,g!list ,list))
182 (let ((,var (car ,g!list))
183 (,value (cadr ,g!list)))
185 (setq ,g!list (cddr ,g!list))))))
187 ;;; Return T if KEYWORD is supplied in the list of arguments LIST.
188 (defun keyword-supplied-p (keyword list)
189 (do-keywords key value list
190 (declare (ignore value))
191 (when (eq key keyword) (return t))
192 (setq list (cddr list))))
194 ;;; Return the value of KEYWORD in the list of arguments LIST or NIL
195 ;;; if it is not supplied.
196 (defun keyword-lookup (keyword list)
197 (do-keywords key value list
198 (when (eq key keyword) (return value))
199 (setq list (cddr list))))
201 ;;; Validate a list of keyword arguments.
202 (defun validate-keyvars (list keyword-list &optional allow-other-keys)
203 (let (;; If it is non-NIL, we have to check for unknown keyword
204 ;; arguments in the list to signal an error in that case.
206 (or allow-other-keys (keyword-lookup :allow-other-keys list))))
207 (unless allow-other-keys
208 (do-keywords key value list
209 (declare (ignore value))
210 (unless (find key keyword-list)
211 (error "Unknown keyword argument `~S'." key))))
212 (do* ((tail list (cddr tail))
213 (key (car tail) (car tail)))
215 (unless (symbolp key)
216 (error "Keyword argument `~S' is not a symbol." key))
218 (error "Odd number of keyword arguments.")))))
220 (defmacro !destructuring-bind (lambda-list expression &body body)
221 (multiple-value-bind (d-ll)
222 (parse-destructuring-lambda-list lambda-list)
223 (let ((reqvar-count (length (d-lambda-list-reqvars d-ll)))
224 (optvar-count (length (d-lambda-list-optvars d-ll)))
226 (labels (;; Return a chain of the form (CAR (CDR (CDR ... (CDR X))),
227 ;; such that there are N calls to CDR.
228 (nth-chain (x n &optional tail)
230 (if (zerop n) x `(cdr ,(nth-chain x (1- n) t)))
231 `(car ,(nth-chain x n t))))
232 ;; Compute the bindings for a pattern against FORM. If
233 ;; PATTERN is a lambda-list the pattern is bound to an
234 ;; auxiliary variable, otherwise PATTERN must be a
235 ;; symbol it will be bound to the form. The variable
236 ;; where the form is bound is returned.
237 (compute-pbindings (pattern form)
240 ;; Bind the symbol to FORM.
242 (push `(,pattern ,form) bindings)
244 ((d-lambda-list-p pattern)
245 ;; Bind FORM to a auxiliar variable and bind
246 ;; pattern agains it recursively.
247 (let ((subpart (gensym)))
252 (compute-bindings pattern subpart)
255 ;; Compute the bindings for the full D-LAMBDA-LIST d-ll
257 (compute-bindings (d-ll form)
258 (compute-pbindings (d-lambda-list-wholevar d-ll) form)
261 (dolist (reqvar (d-lambda-list-reqvars d-ll))
262 (compute-pbindings reqvar (nth-chain form count))
265 (dolist (optvar (d-lambda-list-optvars d-ll))
266 (when (optvar-supplied-p-parameter optvar)
267 (compute-pbindings (optvar-supplied-p-parameter optvar)
268 `(not (null ,(nth-chain form count t)))))
269 (compute-pbindings (optvar-variable optvar)
270 `(if (null ,(nth-chain form count t))
271 ,(optvar-initform optvar)
272 ,(nth-chain form count)))
275 ;; Rest-variable and keywords
276 (when (or (d-lambda-list-restvar d-ll)
277 (d-lambda-list-keyvars d-ll))
278 ;; If there is a rest or keyword variable, we
279 ;; will add a binding for the rest or an
280 ;; auxiliary variable. The computations in of the
281 ;; keyword start in this variable, so we avoid
282 ;; the long tail of nested CAR/CDR operations
284 (let* ((chain (nth-chain form (+ reqvar-count optvar-count) t))
285 (pattern (or (d-lambda-list-restvar d-ll) (gensym)))
286 (rest (compute-pbindings pattern chain)))
287 (dolist (keyvar (d-lambda-list-keyvars d-ll))
288 (let ((variable (keyvar-variable keyvar))
289 (keyword (keyvar-keyword-name keyvar))
290 (supplied (or (keyvar-supplied-p-parameter keyvar)
293 (compute-pbindings supplied `(keyword-supplied-p ,keyword ,rest)))
294 (compute-pbindings variable `(if ,supplied
295 (keyword-lookup ,keyword ,rest)
296 ,(keyvar-initform keyvar)))))))
299 (dolist (auxvar (d-lambda-list-auxvars d-ll))
300 (compute-pbindings (auxvar-variable auxvar) (auxvar-initform auxvar))))))
302 ;; Macroexpansion. Compute bindings and generate code for them
303 ;; and some necessary checking.
304 (let ((whole (gensym)))
305 (compute-bindings d-ll whole)
306 `(let ((,whole ,expression))
307 (let* ,(reverse bindings)
312 (defmacro destructuring-bind (lambda-list expression &body body)
313 `(!destructuring-bind ,lambda-list ,expression ,@body))