source: trunk/abcl/src/org/armedbear/lisp/destructuring-bind.lisp @ 14207

Last change on this file since 14207 was 14133, checked in by ehuelsmann, 9 years ago

Remove code duplication. Rename MAKE-EXPANDER-FOR-MACROLET because it
is no longer used solely for MACROLET.

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