mdw@git.distorted.org.uk Git - lisp/blob - collect.lisp

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