source: trunk/j/src/org/armedbear/lisp/collect.lisp @ 9266

Last change on this file since 9266 was 6167, checked in by piso, 17 years ago

(provide :collect) => (provide 'collect)

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