;;; -*-lisp-*-
;;;
;;; $Id$
;;;
;;; Collecting things into lists
;;;
;;; (c) 2005 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; 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 #:collect-tail))
(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 ((head (cons nil nil)))
      (setf (car head) head))))

(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."
  (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) `(the list (cdr ,v))) vars))))

(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."
  `(multiple-value-bind
   ,(listify vars)
       (collecting ,vars ,collection)
     ,@body))

(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 new
    `(let ((,new (cons ,x nil)))
       (setf (cdar ,name) ,new)
       (setf (car ,name) ,new))))

(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."
  `(progn
     (setf (cdar ,name) ,x)
     (setf (car ,name) nil)))

;;;----- That's all, folks --------------------------------------------------