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 #:collect
  27   (:use #:common-lisp #:mdw.base)
  28   (:export #:collecting #:with-collection #:collect #:collect-tail))
  29 (in-package 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 ((head (cons nil nil)))
  36       (setf (car head) head))))
  37
  38 (defmacro collecting (vars &body body)
  39   "Collect items into lists.  The VARS are a list of collection variables --
  40    their values are unspecified, except that they may be passed to `collect'
  41    and `collect-tail' If VARS is empty then *collecting-anon-list-name* is
  42    used.  VARS may be an atom instead of a singleton list.  The form produces
  43    multiple values, one for each list constructed."
  44   (cond ((null vars) (setf vars (list *collecting-anon-list-name*)))
  45         ((atom vars) (setf vars (list vars))))
  46   `(let ,(mapcar (lambda (v) `(,v (make-collector))) vars)
  47      ,@body
  48      (values ,@(mapcar (lambda (v) `(the list (cdr ,v))) vars))))
  49
  50 (defmacro with-collection (vars collection &body body)
  51   "Collect items into lists VARS according to the form COLLECTION; then
  52    evaluate BODY with VARS bound to those lists."
  53   `(multiple-value-bind
  54    ,(listify vars)
  55        (collecting ,vars ,collection)
  56      ,@body))
  57
  58 (defmacro collect (x &optional (name *collecting-anon-list-name*))
  59   "Add item X to the `collecting' list NAME (or *collecting-anon-list-name*
  60    by default)."
  61   (with-gensyms new
  62     `(let ((,new (cons ,x nil)))
  63        (setf (cdar ,name) ,new)
  64        (setf (car ,name) ,new))))
  65
  66 (defmacro collect-tail (x &optional (name *collecting-anon-list-name*))
  67   "Make item X be the tail of `collecting' list NAME (or
  68    *collecting-anon-list-name* by default).  It is an error to continue
  69    trying to add stuff to the list."
  70   `(progn
  71      (setf (cdar ,name) ,x)
  72      (setf (car ,name) nil)))
  73
  74 ;;;----- That's all, folks --------------------------------------------------