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

Last change on this file since 9266 was 9204, checked in by piso, 16 years ago

BLOCK-NAME => FDEFINITION-BLOCK-NAME

File size: 13.7 KB
Line 
1;;; destructuring-bind.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: destructuring-bind.lisp,v 1.18 2005-05-19 15:09:55 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;;;; Adapted from CMUCL/SBCL.
21
22(in-package #:system)
23
24(export '(parse-body))
25
26(defun parse-body (body &optional (doc-string-allowed t))
27  (let ((decls ())
28  (doc nil))
29    (do ((tail body (cdr tail)))
30  ((endp tail)
31   (values tail (nreverse decls) doc))
32      (let ((form (car tail)))
33  (cond ((and (stringp form) (cdr tail))
34         (if doc-string-allowed
35       (setq doc form
36       ;; Only one doc string is allowed.
37       doc-string-allowed nil)
38       (return (values tail (nreverse decls) doc))))
39        ((not (and (consp form) (symbolp (car form))))
40         (return (values tail (nreverse decls) doc)))
41        ((eq (car form) 'declare)
42         (push form decls))
43        (t
44         (return (values tail (nreverse decls) doc))))))))
45
46;; We don't have DEFVAR yet...
47(eval-when (:compile-toplevel :load-toplevel :execute)
48  (%defvar '*arg-tests* ())
49  (%defvar '*system-lets* ())
50  (%defvar '*user-lets* ())
51  (%defvar '*ignorable-vars* ())
52  (%defvar '*env-var* nil))
53
54(defun arg-count-error (error-kind name arg lambda-list minimum maximum)
55  (error 'program-error
56         :format-control "Wrong number of arguments for ~S."
57         :format-arguments (list name)))
58
59;;; Return, as multiple values, a body, possibly a DECLARE form to put
60;;; where this code is inserted, the documentation for the parsed
61;;; body, and bounds on the number of arguments.
62(defun parse-defmacro (lambda-list arg-list-name body name context
63           &key
64           (anonymousp nil)
65           (doc-string-allowed t)
66           ((:environment env-arg-name))
67           (error-fun 'error)
68                                   (wrap-block t))
69  (multiple-value-bind (forms declarations documentation)
70      (parse-body body doc-string-allowed)
71    (let ((*arg-tests* ())
72    (*user-lets* ())
73    (*system-lets* ())
74    (*ignorable-vars* ())
75          (*env-var* nil))
76      (multiple-value-bind (env-arg-used minimum maximum)
77    (parse-defmacro-lambda-list lambda-list arg-list-name name
78              context error-fun (not anonymousp)
79              nil)
80  (values `(let* (,@(when env-arg-used
81                            `((,*env-var* ,env-arg-name)))
82                        ,@(nreverse *system-lets*))
83       ,@(when *ignorable-vars*
84           `((declare (ignorable ,@*ignorable-vars*))))
85       ,@*arg-tests*
86       (let* ,(nreverse *user-lets*)
87         ,@declarations
88                     ,@(if wrap-block
89                           `((block ,(fdefinition-block-name name) ,@forms))
90                           forms)))
91    `(,@(when (and env-arg-name (not env-arg-used))
92                      `((declare (ignore ,env-arg-name)))))
93    documentation
94    minimum
95    maximum)))))
96
97(defun defmacro-error (problem name)
98  (error 'type-error "~S is not of type ~S~%" problem name))
99
100(defun verify-keywords (key-list valid-keys allow-other-keys)
101  (do ((already-processed nil)
102       (unknown-keyword nil)
103       (remaining key-list (cddr remaining)))
104      ((null remaining)
105       (if (and unknown-keyword
106    (not allow-other-keys)
107    (not (lookup-keyword :allow-other-keys key-list)))
108     (values :unknown-keyword (list unknown-keyword valid-keys))
109     (values nil nil)))
110    (cond ((not (and (consp remaining) (listp (cdr remaining))))
111     (return (values :dotted-list key-list)))
112    ((null (cdr remaining))
113     (return (values :odd-length key-list)))
114    ((or (eq (car remaining) :allow-other-keys)
115         (memql (car remaining) valid-keys))
116     (push (car remaining) already-processed))
117    (t
118     (setq unknown-keyword (car remaining))))))
119
120(defun lookup-keyword (keyword key-list)
121  (do ((remaining key-list (cddr remaining)))
122      ((endp remaining))
123    (when (eq keyword (car remaining))
124      (return (cadr remaining)))))
125
126(defun keyword-supplied-p (keyword key-list)
127  (do ((remaining key-list (cddr remaining)))
128      ((endp remaining))
129    (when (eq keyword (car remaining))
130      (return t))))
131
132(defun parse-defmacro-lambda-list
133       (lambda-list arg-list-name name error-kind error-fun
134        &optional top-level env-illegal ;;env-arg-name
135                    )
136  (let* ((path-0 (if top-level `(cdr ,arg-list-name) arg-list-name))
137         (path path-0)
138         (now-processing :required)
139         (maximum 0)
140         (minimum 0)
141         (keys ())
142         rest-name restp allow-other-keys-p env-arg-used)
143    ;; This really strange way to test for '&whole is neccessary because member
144    ;; does not have to work on dotted lists, and dotted lists are legal
145    ;; in lambda-lists.
146    (when (and (do ((list lambda-list (cdr list)))
147       ((atom list) nil)
148     (when (eq (car list) '&whole) (return t)))
149         (not (eq (car lambda-list) '&whole)))
150      (error "&Whole must appear first in ~S lambda-list." error-kind))
151    (do ((rest-of-args lambda-list (cdr rest-of-args)))
152  ((atom rest-of-args)
153   (cond ((null rest-of-args) nil)
154         ;; Varlist is dotted, treat as &rest arg and exit.
155         (t (push-let-binding rest-of-args path nil)
156      (setq restp t))))
157      (let ((var (car rest-of-args)))
158  (cond ((eq var '&whole)
159         (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
160          (setq rest-of-args (cdr rest-of-args))
161          (push-let-binding (car rest-of-args) arg-list-name nil))
162         ((and (cdr rest-of-args) (consp (cadr rest-of-args)))
163          (pop rest-of-args)
164          (let* ((destructuring-lambda-list (car rest-of-args))
165           (sub (gensym "WHOLE-SUBLIST")))
166      (push-sub-list-binding
167       sub arg-list-name destructuring-lambda-list
168       name error-kind error-fun)
169      (parse-defmacro-lambda-list
170       destructuring-lambda-list sub name error-kind error-fun)))
171         (t
172          (defmacro-error "&WHOLE" name))))
173        ((eq var '&environment)
174         (cond (env-illegal
175          (error "&ENVIRONMENT is not valid with ~S." error-kind))
176         ((not top-level)
177          (error "&ENVIRONMENT is only valid at top level of lambda list.")))
178         (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
179          (setq rest-of-args (cdr rest-of-args))
180                      (setq *env-var* (car rest-of-args)
181                            env-arg-used t))
182         (t
183          (defmacro-error "&ENVIRONMENT" error-kind name))))
184        ((or (eq var '&rest) (eq var '&body))
185         (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
186          (setq rest-of-args (cdr rest-of-args))
187          (setq restp t)
188          (push-let-binding (car rest-of-args) path nil))
189         ((and (cdr rest-of-args) (consp (cadr rest-of-args)))
190          (pop rest-of-args)
191          (setq restp t)
192          (let* ((destructuring-lambda-list (car rest-of-args))
193           (sub (gensym "REST-SUBLIST")))
194      (push-sub-list-binding sub path destructuring-lambda-list
195                                               name error-kind error-fun)
196      (parse-defmacro-lambda-list
197       destructuring-lambda-list sub name error-kind error-fun)))
198         (t
199          (defmacro-error (symbol-name var) error-kind name))))
200        ((eq var '&optional)
201         (setq now-processing :optionals))
202        ((eq var '&key)
203         (setq now-processing :keywords)
204         (setq rest-name (gensym "KEYWORDS-"))
205         (push rest-name *ignorable-vars*)
206         (setq restp t)
207         (push-let-binding rest-name path t))
208        ((eq var '&allow-other-keys)
209         (setq allow-other-keys-p t))
210        ((eq var '&aux)
211         (setq now-processing :auxs))
212        ((listp var)
213         (case now-processing
214     (:required
215      (let ((sub-list-name (gensym "SUBLIST-")))
216        (push-sub-list-binding sub-list-name `(car ,path) var
217             name error-kind error-fun)
218        (parse-defmacro-lambda-list var sub-list-name name
219            error-kind error-fun))
220      (setq path `(cdr ,path))
221      (incf minimum)
222      (incf maximum))
223     (:optionals
224      (when (> (length var) 3)
225        (error "more than variable, initform, and suppliedp in &optional binding ~S"
226                           var))
227      (push-optional-binding (car var) (cadr var) (caddr var)
228           `(not (null ,path)) `(car ,path)
229           name error-kind error-fun)
230      (setq path `(cdr ,path))
231      (incf maximum))
232     (:keywords
233      (let* ((keyword-given (consp (car var)))
234       (variable (if keyword-given
235               (cadar var)
236               (car var)))
237       (keyword (if keyword-given
238              (caar var)
239              (make-keyword variable)))
240       (supplied-p (caddr var)))
241        (push-optional-binding variable (cadr var) supplied-p
242             `(keyword-supplied-p ',keyword
243                ,rest-name)
244             `(lookup-keyword ',keyword
245                  ,rest-name)
246             name error-kind error-fun)
247        (push keyword keys)))
248     (:auxs (push-let-binding (car var) (cadr var) nil))))
249        ((symbolp var)
250         (case now-processing
251     (:required
252      (incf minimum)
253      (incf maximum)
254      (push-let-binding var `(car ,path) nil)
255      (setq path `(cdr ,path)))
256     (:optionals
257      (incf maximum)
258      (push-let-binding var `(car ,path) nil `(not (null ,path)))
259      (setq path `(cdr ,path)))
260     (:keywords
261      (let ((key (make-keyword var)))
262        (push-let-binding var `(lookup-keyword ,key ,rest-name)
263              nil)
264        (push key keys)))
265     (:auxs
266      (push-let-binding var nil nil))))
267        (t
268         (error "non-symbol in lambda-list: ~S" var)))))
269    ;; Generate code to check the number of arguments, unless dotted
270    ;; in which case length will not work.
271    (unless restp
272      (push `(unless (<= ,minimum
273                         (length ,path-0)
274                         ,@(unless restp
275                             (list maximum)))
276               ,(if (eq error-fun 'error)
277                    `(arg-count-error ',error-kind ',name ,path-0
278                                      ',lambda-list ,minimum
279                                      ,(unless restp maximum))
280                    `(,error-fun 'arg-count-error
281                      :kind ',error-kind
282                      ,@(when name `(:name ',name))
283                      :argument ,path-0
284                      :lambda-list ',lambda-list
285                      :minimum ,minimum
286                      ,@(unless restp `(:maximum ,maximum)))))
287            *arg-tests*))
288    (if keys
289  (let ((problem (gensym "KEY-PROBLEM-"))
290        (info (gensym "INFO-")))
291    (push `(multiple-value-bind (,problem ,info)
292         (verify-keywords ,rest-name ',keys ',allow-other-keys-p)
293       (when ,problem
294         (,error-fun
295          'defmacro-lambda-list-broken-key-list-error
296          :kind ',error-kind
297          ,@(when name `(:name ',name))
298          :problem ,problem
299          :info ,info)))
300    *arg-tests*)))
301    (values env-arg-used minimum (if (null restp) maximum nil))))
302
303
304(defun push-sub-list-binding (variable path object name error-kind error-fun)
305  (let ((var (gensym "TEMP-")))
306    (push `(,variable
307      (let ((,var ,path))
308        (if (listp ,var)
309      ,var
310      (,error-fun 'defmacro-bogus-sublist-error
311            :kind ',error-kind
312            ,@(when name `(:name ',name))
313            :object ,var
314            :lambda-list ',object))))
315    *system-lets*)))
316
317(defun push-let-binding (variable path systemp &optional condition
318          (init-form nil))
319  (let ((let-form (if condition
320          `(,variable (if ,condition ,path ,init-form))
321          `(,variable ,path))))
322    (if systemp
323  (push let-form *system-lets*)
324  (push let-form *user-lets*))))
325
326(defun push-optional-binding (value-var init-form supplied-var condition path
327          name error-kind error-fun)
328  (unless supplied-var
329    (setq supplied-var (gensym "SUPPLIEDP-")))
330  (push-let-binding supplied-var condition t)
331  (cond ((consp value-var)
332   (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
333     (push-sub-list-binding whole-thing
334          `(if ,supplied-var ,path ,init-form)
335          value-var name error-kind error-fun)
336     (parse-defmacro-lambda-list value-var whole-thing name
337               error-kind error-fun)))
338  ((symbolp value-var)
339   (push-let-binding value-var path nil supplied-var init-form))
340  (t
341   (error "Illegal optional variable name: ~S" value-var))))
342
343(defmacro destructuring-bind (lambda-list arg-list &rest body)
344  (let* ((arg-list-name (gensym "ARG-LIST-")))
345    (multiple-value-bind (body local-decls)
346  (parse-defmacro lambda-list arg-list-name body nil 'destructuring-bind
347      :anonymousp t :doc-string-allowed nil)
348      `(let ((,arg-list-name ,arg-list))
349   ,@local-decls
350   ,body))))
351
352;; Redefine DEFMACRO to use PARSE-DEFMACRO.
353(defmacro defmacro (name lambda-list &rest body)
354  (let* ((form (gensym "WHOLE-"))
355         (env (gensym "ENVIRONMENT-"))
356         (body (parse-defmacro lambda-list form body name 'defmacro
357                               :environment env))
358         (expander `(lambda (,form ,env) (block ,name ,body))))
359    `(progn
360       (let ((macro (make-macro ',name ,expander)))
361         (if (special-operator-p ',name)
362             (%put ',name 'macroexpand-macro macro)
363             (fset ',name macro))
364         (%set-arglist macro ',lambda-list)
365         ',name))))
366
367;; Redefine SYS:MAKE-EXPANDER-FOR-MACROLET to use PARSE-DEFMACRO.
368(defun make-expander-for-macrolet (definition)
369  (let* ((name (car definition))
370         (lambda-list (cadr definition))
371         (form (gensym "WHOLE-"))
372         (env (gensym "ENVIRONMENT-"))
373         (body (parse-defmacro lambda-list form (cddr definition) name 'defmacro
374                               :environment env)))
375    `(lambda (,form ,env) (block ,name ,body))))
Note: See TracBrowser for help on using the repository browser.