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

Last change on this file since 4152 was 4152, checked in by piso, 19 years ago

(in-package "SYSTEM")

File size: 12.6 KB
Line 
1;;; destructuring-bind.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: destructuring-bind.lisp,v 1.5 2003-10-01 01:13:36 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 "SYSTEM")
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* ,(nreverse *system-lets*)
61     ,@(when *ignorable-vars*
62         `((declare (ignorable ,@*ignorable-vars*))))
63      ,@*arg-tests*
64      (let* ,(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 (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 (nreverse decls) doc))))
359        ((not (and (consp form) (symbolp (car form))))
360         (return (values tail (nreverse decls) doc)))
361        ((eq (car form) 'declare)
362         (push form decls))
363        (t
364         (return (values tail (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.