base, optparse: Introduce `case2' macros.

[lisp] / collect.lisp

;;; -*-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 #:mdw.collect
  (:use #:common-lisp #:mdw.base)
  (:export #:collecting #:with-collection #:collect))
(in-package mdw.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))))
(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) `(cdar ,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 tmp
    `(let ((,tmp (cons ,x nil)))
       (setf (cddr ,name) ,tmp)
       (setf (cdr ,name) ,tmp))))
(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 (cddr ,name) ,x)
     (setf (cdr ,name) nil)))

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