source: trunk/j/src/org/armedbear/lisp/destructuring-bind.lisp @ 1994

Last change on this file since 1994 was 1994, checked in by piso, 18 years ago

nreverse => list-nreverse

File size: 12.6 KB
Line 
1;;; destructuring-bind.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: destructuring-bind.lisp,v 1.3 2003-05-27 20:04:38 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20;;;; From CMUCL, via GCL.
21
22(in-package "COMMON-LISP")
23
24(export '(destructuring-bind))
25
26(defvar *arg-tests* ())
27
28(defvar *system-lets* nil)
29
30(defvar *user-lets* ())
31
32(defvar *ignorable-vars*)
33
34(defun do-arg-count-error (error-kind name arg lambda-list minimum maximum)
35  (error "Error in do-arg-count-error: ~S ~S ~S ~S ~S ~S~%"
36   error-kind
37   name
38   arg
39   lambda-list
40   minimum
41   maximum))
42
43(defun parse-defmacro (lambda-list arg-list-name code name error-kind
44           &key (anonymousp nil)
45           (doc-string-allowed t)
46           ((:environment env-arg-name))
47           (error-fun 'error))
48  (multiple-value-bind (body declarations documentation)
49           (parse-body code nil doc-string-allowed)
50    (let* ((*arg-tests* ())
51     (*user-lets* ())
52     (*system-lets* ())
53     (*ignorable-vars* ()))
54      (multiple-value-bind
55    (env-arg-used minimum maximum)
56    (parse-defmacro-lambda-list lambda-list arg-list-name name
57              error-kind error-fun (not anonymousp)
58              nil env-arg-name)
59  (values
60   `(let* ,(list-nreverse *system-lets*)
61     ,@(when *ignorable-vars*
62         `((declare (ignorable ,@*ignorable-vars*))))
63      ,@*arg-tests*
64      (let* ,(list-nreverse *user-lets*)
65        ,@declarations
66        ,@body))
67   `(,@(when (and env-arg-name (not env-arg-used))
68         `((declare (ignore ,env-arg-name)))))
69   documentation
70   minimum
71   maximum)))))
72
73(defun make-keyword (symbol)
74  "Takes a non-keyword symbol, symbol, and returns the corresponding keyword."
75  (intern (symbol-name symbol) (find-package "KEYWORD")))
76
77(defun defmacro-error (problem name)
78  (error 'type-error "~S is not of type ~S~%" problem name))
79
80(defun verify-keywords (key-list valid-keys allow-other-keys)
81  (do ((already-processed nil)
82       (unknown-keyword nil)
83       (remaining key-list (cddr remaining)))
84      ((null remaining)
85       (if (and unknown-keyword
86    (not allow-other-keys)
87    (not (lookup-keyword :allow-other-keys key-list)))
88     (values :unknown-keyword (list unknown-keyword valid-keys))
89     (values nil nil)))
90    (cond ((not (and (consp remaining) (listp (cdr remaining))))
91     (return (values :dotted-list key-list)))
92    ((null (cdr remaining))
93     (return (values :odd-length key-list)))
94    #+nil ;; Not ANSI compliant to disallow duplicate keywords.
95    ((member (car remaining) already-processed)
96     (return (values :duplicate (car remaining))))
97    ((or (eq (car remaining) :allow-other-keys)
98         (member (car remaining) valid-keys))
99     (push (car remaining) already-processed))
100    (t
101     (setf unknown-keyword (car remaining))))))
102
103(defun lookup-keyword (keyword key-list)
104  (do ((remaining key-list (cddr remaining)))
105      ((endp remaining))
106    (when (eq keyword (car remaining))
107      (return (cadr remaining)))))
108
109(defun keyword-supplied-p (keyword key-list)
110  (do ((remaining key-list (cddr remaining)))
111      ((endp remaining))
112    (when (eq keyword (car remaining))
113      (return t))))
114
115
116(defun parse-defmacro-lambda-list
117       (lambda-list arg-list-name name error-kind error-fun
118        &optional top-level env-illegal env-arg-name)
119  (let ((path (if top-level `(cdr ,arg-list-name) arg-list-name))
120  (now-processing :required)
121  (maximum 0)
122  (minimum 0)
123  (keys ())
124  rest-name restp allow-other-keys-p env-arg-used)
125    ;; This really strange way to test for '&whole is neccessary because member
126    ;; does not have to work on dotted lists, and dotted lists are legal
127    ;; in lambda-lists.
128    (when (and (do ((list lambda-list (cdr list)))
129       ((atom list) nil)
130     (when (eq (car list) '&whole) (return t)))
131         (not (eq (car lambda-list) '&whole)))
132      (error "&Whole must appear first in ~S lambda-list." error-kind))
133    (do ((rest-of-args lambda-list (cdr rest-of-args)))
134  ((atom rest-of-args)
135   (cond ((null rest-of-args) nil)
136         ;; Varlist is dotted, treat as &rest arg and exit.
137         (t (push-let-binding rest-of-args path nil)
138      (setf restp t))))
139      (let ((var (car rest-of-args)))
140  (cond ((eq var '&whole)
141         (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
142          (setf rest-of-args (cdr rest-of-args))
143          (push-let-binding (car rest-of-args) arg-list-name nil))
144         (t
145          (defmacro-error "&WHOLE" name))))
146        ((eq var '&environment)
147         (cond (env-illegal
148          (error "&ENVIRONMENT not valid with ~S" error-kind))
149         ((not top-level)
150          (error "&ENVIRONMENT only valid at top level of lambda list")))
151         (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
152          (setf rest-of-args (cdr rest-of-args))
153          (push-let-binding (car rest-of-args) env-arg-name nil)
154          (setf env-arg-used t))
155         (t
156          (defmacro-error "&ENVIRONMENT" error-kind name))))
157        ((or (eq var '&rest) (eq var '&body))
158         (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
159          (setf rest-of-args (cdr rest-of-args))
160          (setf restp t)
161          (push-let-binding (car rest-of-args) path nil))
162         ;;
163         ;; This branch implements an incompatible extension to
164         ;; Common Lisp.  In place of a symbol following &body,
165         ;; there may be a list of up to three elements which will
166         ;; be bound to the body, declarations, and doc-string of
167         ;; the body.
168         ((and (cdr rest-of-args)
169         (consp (cadr rest-of-args))
170         (symbolp (caadr rest-of-args)))
171          (setf rest-of-args (cdr rest-of-args))
172          (setf restp t)
173          (let ((body-name (caar rest-of-args))
174          (declarations-name (cadar rest-of-args))
175          (doc-string-name (caddar rest-of-args))
176          (parse-body-values (gensym)))
177      (push-let-binding
178       parse-body-values
179       `(multiple-value-list
180         (parse-body ,path ,env-arg-name
181               ,(not (null doc-string-name))))
182       t)
183      (setf env-arg-used t)
184      (when body-name
185        (push-let-binding body-name
186              `(car ,parse-body-values) nil))
187      (when declarations-name
188        (push-let-binding declarations-name
189              `(cadr ,parse-body-values) nil))
190      (when doc-string-name
191        (push-let-binding doc-string-name
192              `(caddr ,parse-body-values) nil))))
193         (t
194          (defmacro-error (symbol-name var) error-kind name))))
195        ((eq var '&optional)
196         (setf now-processing :optionals))
197        ((eq var '&key)
198         (setf now-processing :keywords)
199         (setf rest-name (gensym "KEYWORDS-"))
200         (push rest-name *ignorable-vars*)
201         (setf restp t)
202         (push-let-binding rest-name path t))
203        ((eq var '&allow-other-keys)
204         (setf allow-other-keys-p t))
205        ((eq var '&aux)
206         (setf now-processing :auxs))
207        ((listp var)
208         (case now-processing
209     (:required
210      (let ((sub-list-name (gensym "SUBLIST-")))
211        (push-sub-list-binding sub-list-name `(car ,path) var
212             name error-kind error-fun)
213        (parse-defmacro-lambda-list var sub-list-name name
214            error-kind error-fun))
215      (setf path `(cdr ,path))
216      (incf minimum)
217      (incf maximum))
218     (:optionals
219      (when (> (length var) 3)
220        (cerror "Ignore extra noise."
221          "More than variable, initform, and suppliedp ~
222          in &optional binding - ~S"
223          var))
224      (push-optional-binding (car var) (cadr var) (caddr var)
225           `(not (null ,path)) `(car ,path)
226           name error-kind error-fun)
227      (setf path `(cdr ,path))
228      (incf maximum))
229     (:keywords
230      (let* ((keyword-given (consp (car var)))
231       (variable (if keyword-given
232               (cadar var)
233               (car var)))
234       (keyword (if keyword-given
235              (caar var)
236              (make-keyword variable)))
237       (supplied-p (caddr var)))
238        (push-optional-binding variable (cadr var) supplied-p
239             `(keyword-supplied-p ',keyword
240                ,rest-name)
241             `(lookup-keyword ',keyword
242                  ,rest-name)
243             name error-kind error-fun)
244        (push keyword keys)))
245     (:auxs (push-let-binding (car var) (cadr var) nil))))
246        ((symbolp var)
247         (case now-processing
248     (:required
249      (incf minimum)
250      (incf maximum)
251      (push-let-binding var `(car ,path) nil)
252      (setf path `(cdr ,path)))
253     (:optionals
254      (incf maximum)
255      (push-let-binding var `(car ,path) nil `(not (null ,path)))
256      (setf path `(cdr ,path)))
257     (:keywords
258      (let ((key (make-keyword var)))
259        (push-let-binding var `(lookup-keyword ,key ,rest-name)
260              nil)
261        (push key keys)))
262     (:auxs
263      (push-let-binding var nil nil))))
264        (t
265         (error "non-symbol in lambda-list: ~S" var)))))
266    ;; Generate code to check the number of arguments, unless dotted
267    ;; in which case length will not work.
268    (unless restp
269       (push `(unless (<= ,minimum
270        (length (the list ,(if top-level
271             `(cdr ,arg-list-name)
272                 arg-list-name)))
273        ,@(unless restp
274            (list maximum)))
275          ,(let ((arg (if top-level
276              `(cdr ,arg-list-name)
277            arg-list-name)))
278       (if (eq error-fun 'error)
279           `(do-arg-count-error ',error-kind ',name ,arg
280              ',lambda-list ,minimum
281              ,(unless restp maximum))
282         `(,error-fun 'defmacro-ll-arg-count-error
283         :kind ',error-kind
284         ,@(when name `(:name ',name))
285         :argument ,arg
286         :lambda-list ',lambda-list
287         :minimum ,minimum
288         ,@(unless restp `(:maximum ,maximum))))))
289       *arg-tests*))
290    (if keys
291  (let ((problem (gensym "KEY-PROBLEM-"))
292        (info (gensym "INFO-")))
293    (push `(multiple-value-bind
294         (,problem ,info)
295         (verify-keywords ,rest-name ',keys ',allow-other-keys-p)
296       (when ,problem
297         (,error-fun
298          'defmacro-ll-broken-key-list-error
299          :kind ',error-kind
300          ,@(when name `(:name ',name))
301          :problem ,problem
302          :info ,info)))
303    *arg-tests*)))
304    (values env-arg-used minimum (if (null restp) maximum nil))))
305
306
307(defun push-sub-list-binding (variable path object name error-kind error-fun)
308  (let ((var (gensym "TEMP-")))
309    (push `(,variable
310      (let ((,var ,path))
311        (if (listp ,var)
312      ,var
313      (,error-fun 'defmacro-bogus-sublist-error
314            :kind ',error-kind
315            ,@(when name `(:name ',name))
316            :object ,var
317            :lambda-list ',object))))
318    *system-lets*)))
319
320(defun push-let-binding (variable path systemp &optional condition
321          (init-form nil))
322  (let ((let-form (if condition
323          `(,variable (if ,condition ,path ,init-form))
324          `(,variable ,path))))
325    (if systemp
326  (push let-form *system-lets*)
327  (push let-form *user-lets*))))
328
329(defun push-optional-binding (value-var init-form supplied-var condition path
330          name error-kind error-fun)
331  (unless supplied-var
332    (setf supplied-var (gensym "SUPLIEDP-")))
333  (push-let-binding supplied-var condition t)
334  (cond ((consp value-var)
335   (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
336     (push-sub-list-binding whole-thing
337          `(if ,supplied-var ,path ,init-form)
338          value-var name error-kind error-fun)
339     (parse-defmacro-lambda-list value-var whole-thing name
340               error-kind error-fun)))
341  ((symbolp value-var)
342   (push-let-binding value-var path nil supplied-var init-form))
343  (t
344   (error "Illegal optional variable name: ~S" value-var))))
345
346(defun parse-body (body environment &optional (doc-string-allowed t))
347  (let ((decls ())
348  (doc nil))
349    (do ((tail body (cdr tail)))
350  ((endp tail)
351   (values tail (list-nreverse decls) doc))
352      (let ((form (car tail)))
353  (cond ((and (stringp form) (cdr tail))
354         (if doc-string-allowed
355       (setq doc form
356       ;; Only one doc string is allowed.
357       doc-string-allowed nil)
358       (return (values tail (list-nreverse decls) doc))))
359        ((not (and (consp form) (symbolp (car form))))
360         (return (values tail (list-nreverse decls) doc)))
361        ((eq (car form) 'declare)
362         (push form decls))
363        (t
364         (return (values tail (list-nreverse decls) doc))))))))
365
366(defmacro destructuring-bind (lambda-list arg-list &rest body)
367  (let* ((arg-list-name (gensym "ARG-LIST-")))
368    (multiple-value-bind
369  (body local-decls)
370  (parse-defmacro lambda-list arg-list-name body nil 'destructuring-bind
371      :anonymousp t :doc-string-allowed nil)
372      `(let ((,arg-list-name ,arg-list))
373   ,@local-decls
374   ,body))))
Note: See TracBrowser for help on using the repository browser.