source: trunk/abcl/src/org/armedbear/lisp/collect.lisp @ 14215

Last change on this file since 14215 was 11391, checked in by vvoutilainen, 12 years ago

ABCL license is GPL + Classpath exception. This was intended
by Peter Graves, the original author. For reference, see
http://sourceforge.net/mailarchive/forum.php?thread_name=20040721115302.839%40prufrock&forum_name=armedbear-j-announce

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 4.7 KB
Line 
1;;; collect.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: collect.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $
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(in-package "EXT")
33
34(export '(collect))
35
36;;; From CMUCL.
37
38;;;; The Collect macro:
39
40;;; Collect-Normal-Expander  --  Internal
41;;;
42;;;    This function does the real work of macroexpansion for normal collection
43;;; macros.  N-Value is the name of the variable which holds the current
44;;; value.  Fun is the function which does collection.  Forms is the list of
45;;; forms whose values we are supposed to collect.
46;;;
47(defun collect-normal-expander (n-value fun forms)
48  `(progn
49    ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
50    ,n-value))
51
52;;; Collect-List-Expander  --  Internal
53;;;
54;;;    This function deals with the list collection case.  N-Tail is the pointer
55;;; to the current tail of the list, which is NIL if the list is empty.
56;;;
57(defun collect-list-expander (n-value n-tail forms)
58  (let ((n-res (gensym)))
59    `(progn
60      ,@(mapcar #'(lambda (form)
61        `(let ((,n-res (cons ,form nil)))
62           (cond (,n-tail
63            (setf (cdr ,n-tail) ,n-res)
64            (setq ,n-tail ,n-res))
65           (t
66            (setq ,n-tail ,n-res  ,n-value ,n-res)))))
67    forms)
68      ,n-value)))
69
70
71;;; Collect  --  Public
72;;;
73;;;    The ultimate collection macro...
74;;;
75(defmacro collect (collections &body body)
76  "Collect ({(Name [Initial-Value] [Function])}*) {Form}*
77  Collect some values somehow.  Each of the collections specifies a bunch of
78  things which collected during the evaluation of the body of the form.  The
79  name of the collection is used to define a local macro, a la MACROLET.
80  Within the body, this macro will evaluate each of its arguments and collect
81  the result, returning the current value after the collection is done.  The
82  body is evaluated as a PROGN; to get the final values when you are done, just
83  call the collection macro with no arguments.
84
85  Initial-Value is the value that the collection starts out with, which
86  defaults to NIL.  Function is the function which does the collection.  It is
87  a function which will accept two arguments: the value to be collected and the
88  current collection.  The result of the function is made the new value for the
89  collection.  As a totally magical special-case, the Function may be Collect,
90  which tells us to build a list in forward order; this is the default.  If an
91  Initial-Value is supplied for Collect, the stuff will be rplacd'd onto the
92  end.  Note that Function may be anything that can appear in the functional
93  position, including macros and lambdas."
94
95  (let ((macros ())
96  (binds ()))
97    (dolist (spec collections)
98      (unless (<= 1 (length spec) 3)
99  (error "Malformed collection specifier: ~S." spec))
100      (let ((n-value (gensym))
101      (name (first spec))
102      (default (second spec))
103      (kind (or (third spec) 'collect)))
104  (push `(,n-value ,default) binds)
105  (if (eq kind 'collect)
106      (let ((n-tail (gensym)))
107        (if default
108      (push `(,n-tail (last ,n-value)) binds)
109      (push n-tail binds))
110        (push `(,name (&rest args)
111          (collect-list-expander ',n-value ',n-tail args))
112        macros))
113      (push `(,name (&rest args)
114        (collect-normal-expander ',n-value ',kind args))
115      macros))))
116    `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
117
118(provide 'collect)
Note: See TracBrowser for help on using the repository browser.