chiark - git - mdw - lisp/blob - collect.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; $Id$
   4 ;;;
   5 ;;; Collecting things into lists
   6 ;;;
   7 ;;; (c) 2005 Straylight/Edgeware
   8 ;;;
   9
  10 ;;;----- Licensing notice ---------------------------------------------------
  11 ;;;
  12 ;;; This program is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; This program is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with this program; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (defpackage #:mdw.collect
  27   (:use #:common-lisp #:mdw.base)
  28   (:export #:collecting #:with-collection #:collect))
  29 (in-package mdw.collect)
  30
  31 (eval-when (:compile-toplevel :load-toplevel)
  32   (defvar *collecting-anon-list-name* (gensym)
  33     "The default name for anonymous `collecting' lists.")
  34   (defun make-collector ()
  35     (let ((c (cons nil nil)))
  36       (cons c c))))
  37 (defmacro collecting (vars &body body)
  38   "Collect items into lists.  The VARS are a list of collection variables --
  39 their values are unspecified, except that they may be passed to `collect' and
  40 `collect-tail'  If VARS is empty then *collecting-anon-list-name* is used.
  41 VARS may be an atom instead of a singleton list.  The form produces multiple
  42 values, one for each list constructed."
  43   (cond ((null vars) (setf vars (list *collecting-anon-list-name*)))
  44         ((atom vars) (setf vars (list vars))))
  45   `(let ,(mapcar (lambda (v) `(,v (make-collector))) vars)
  46      ,@body
  47      (values ,@(mapcar (lambda (v) `(cdar ,v)) vars))))
  48 (defmacro with-collection (vars collection &body body)
  49   "Collect items into lists VARS according to the form COLLECTION; then
  50 evaluate BODY with VARS bound to those lists."
  51   `(multiple-value-bind
  52        ,(listify vars)
  53        (collecting ,vars ,collection)
  54      ,@body))
  55 (defmacro collect (x &optional (name *collecting-anon-list-name*))
  56   "Add item X to the `collecting' list NAME (or *collecting-anon-list-name*
  57 by default)."
  58   (with-gensyms tmp
  59     `(let ((,tmp (cons ,x nil)))
  60        (setf (cddr ,name) ,tmp)
  61        (setf (cdr ,name) ,tmp))))
  62 (defmacro collect-tail (x &optional (name *collecting-anon-list-name*))
  63   "Make item X be the tail of `collecting' list NAME (or
  64 *collecting-anon-list-name* by default).  It is an error to continue trying
  65 to add stuff to the list."
  66   `(progn
  67      (setf (cddr ,name) ,x)
  68      (setf (cdr ,name) nil)))
  69
  70 ;;;----- That's all, folks --------------------------------------------------