;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; Collecting things into lists
;;;
;;; (c) 2005 Straylight/Edgeware
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
-;;;
+;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
-;;;
+;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
(defpackage #:collect
- (:use #:common-lisp #:mdw.base)
- (:export #:collecting #:with-collection #:collect))
+ (:use #:common-lisp #:mdw.base))
(in-package collect)
(eval-when (:compile-toplevel :load-toplevel)
(defvar *collecting-anon-list-name* (gensym)
- "The default name for anonymous `collecting' lists.")
- (defun make-collector ()
- (let ((c (cons nil nil)))
- (cons c c))))
+ "The default name for anonymous `collecting' lists."))
+
+(export 'make-collector)
+(defun make-collector (&optional list)
+ "Return a new collector object whose initial contents is LIST. Note that
+ LIST will be destroyed if anything else is collected."
+ (let ((head (cons nil list)))
+ (setf (car head) (if list (last list) head))))
+(export 'collected)
+(defmacro collected (&optional (name *collecting-anon-list-name*))
+ "Return the current list collected into the collector NAME (or
+ *collecting-anon-list-name* by default)."
+ `(the list (cdr ,name)))
+
+(export 'collecting)
(defmacro collecting (vars &body body)
"Collect items into lists. The VARS are a list of collection variables --
-their values are unspecified, except that they may be passed to `collect' and
-`collect-tail' If VARS is empty then *collecting-anon-list-name* is used.
-VARS may be an atom instead of a singleton list. The form produces multiple
-values, one for each list constructed."
+ their values are unspecified, except that they may be passed to `collect'
+ and `collect-tail'. If VARS is empty then *collecting-anon-list-name* is
+ used. VARS may be an atom instead of a singleton list. The form produces
+ multiple values, one for each list constructed."
(cond ((null vars) (setf vars (list *collecting-anon-list-name*)))
((atom vars) (setf vars (list vars))))
`(let ,(mapcar (lambda (v) `(,v (make-collector))) vars)
,@body
- (values ,@(mapcar (lambda (v) `(cdar ,v)) vars))))
+ (values ,@(mapcar (lambda (v) `(collected ,v)) vars))))
+(export 'with-collection)
(defmacro with-collection (vars collection &body body)
"Collect items into lists VARS according to the form COLLECTION; then
-evaluate BODY with VARS bound to those lists."
+ evaluate BODY with VARS bound to those lists."
`(multiple-value-bind
,(listify vars)
(collecting ,vars ,collection)
,@body))
+(export 'collect)
(defmacro collect (x &optional (name *collecting-anon-list-name*))
"Add item X to the `collecting' list NAME (or *collecting-anon-list-name*
-by default)."
- (with-gensyms tmp
- `(let ((,tmp (cons ,x nil)))
- (setf (cddr ,name) ,tmp)
- (setf (cdr ,name) ,tmp))))
+ by default)."
+ (with-gensyms new
+ `(let ((,new (cons ,x nil)))
+ (setf (cdar ,name) ,new)
+ (setf (car ,name) ,new))))
+(export 'collect-tail)
(defmacro collect-tail (x &optional (name *collecting-anon-list-name*))
"Make item X be the tail of `collecting' list NAME (or
-*collecting-anon-list-name* by default). It is an error to continue trying
-to add stuff to the list."
+ *collecting-anon-list-name* by default). It is an error to continue
+ trying to add stuff to the list."
`(progn
- (setf (cddr ,name) ,x)
- (setf (cdr ,name) nil)))
+ (setf (cdar ,name) ,x)
+ (setf (car ,name) nil)))
+
+(export 'collect-append)
+(defmacro collect-append (list &optional (name *collecting-anon-list-name*))
+ "Append LIST to the tail of `collecting' list NAME. This obviously
+ involves copying LIST."
+ (with-gensyms item
+ `(dolist (,item ,list)
+ (collect ,item ,name))))
+
+(export 'collect-nconc)
+(defmacro collect-nconc (list &optional (name *collecting-anon-list-name*))
+ "Attach LIST to the tail of `collecting' list NAME. This will involve
+ destroying LIST if anything else gets collected afterwards."
+ (let*/gensyms list
+ `(when ,list
+ (setf (cdar ,name) ,list)
+ (setf (car ,name) (last ,list)))))
;;;----- That's all, folks --------------------------------------------------
~mdw / lisp / blobdiff