Commit | Line | Data |
---|---|---|
861345b4 | 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. | |
b2c12b4e | 16 | ;;; |
861345b4 | 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. | |
b2c12b4e | 21 | ;;; |
861345b4 | 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 | ||
bf0a8c39 | 26 | (defpackage #:collect |
861345b4 | 27 | (:use #:common-lisp #:mdw.base) |
28a5e531 MW |
28 | (:export #:make-collector #:collected |
29 | #:collecting #:with-collection | |
30 | #:collect #:collect-tail | |
31 | #:collect-append #:collect-nconc)) | |
bf0a8c39 | 32 | (in-package collect) |
861345b4 | 33 | |
34 | (eval-when (:compile-toplevel :load-toplevel) | |
35 | (defvar *collecting-anon-list-name* (gensym) | |
28a5e531 MW |
36 | "The default name for anonymous `collecting' lists.")) |
37 | ||
38 | (defun make-collector (&optional list) | |
39 | "Return a new collector object whose initial contents is LIST. Note that | |
40 | LIST will be destroyed if anything else is collected." | |
41 | (let ((head (cons nil list))) | |
42 | (setf (car head) (if list (last list) head)))) | |
43 | ||
44 | (defmacro collected (&optional (name *collecting-anon-list-name*)) | |
45 | "Return the current list collected into the collector NAME (or | |
46 | *collecting-anon-list-name* by default)." | |
47 | `(the list (cdr ,name))) | |
288343df | 48 | |
861345b4 | 49 | (defmacro collecting (vars &body body) |
50 | "Collect items into lists. The VARS are a list of collection variables -- | |
0ff9df03 MW |
51 | their values are unspecified, except that they may be passed to `collect' |
52 | and `collect-tail' If VARS is empty then *collecting-anon-list-name* is | |
53 | used. VARS may be an atom instead of a singleton list. The form produces | |
54 | multiple values, one for each list constructed." | |
861345b4 | 55 | (cond ((null vars) (setf vars (list *collecting-anon-list-name*))) |
56 | ((atom vars) (setf vars (list vars)))) | |
57 | `(let ,(mapcar (lambda (v) `(,v (make-collector))) vars) | |
58 | ,@body | |
28a5e531 | 59 | (values ,@(mapcar (lambda (v) `(collected ,v)) vars)))) |
288343df | 60 | |
861345b4 | 61 | (defmacro with-collection (vars collection &body body) |
62 | "Collect items into lists VARS according to the form COLLECTION; then | |
0ff9df03 | 63 | evaluate BODY with VARS bound to those lists." |
861345b4 | 64 | `(multiple-value-bind |
0ff9df03 | 65 | ,(listify vars) |
861345b4 | 66 | (collecting ,vars ,collection) |
67 | ,@body)) | |
288343df | 68 | |
861345b4 | 69 | (defmacro collect (x &optional (name *collecting-anon-list-name*)) |
70 | "Add item X to the `collecting' list NAME (or *collecting-anon-list-name* | |
0ff9df03 | 71 | by default)." |
a721f2f2 MW |
72 | (with-gensyms new |
73 | `(let ((,new (cons ,x nil))) | |
74 | (setf (cdar ,name) ,new) | |
75 | (setf (car ,name) ,new)))) | |
288343df | 76 | |
861345b4 | 77 | (defmacro collect-tail (x &optional (name *collecting-anon-list-name*)) |
78 | "Make item X be the tail of `collecting' list NAME (or | |
0ff9df03 MW |
79 | *collecting-anon-list-name* by default). It is an error to continue |
80 | trying to add stuff to the list." | |
861345b4 | 81 | `(progn |
a721f2f2 MW |
82 | (setf (cdar ,name) ,x) |
83 | (setf (car ,name) nil))) | |
861345b4 | 84 | |
9013ada7 MW |
85 | (defmacro collect-append (list &optional (name *collecting-anon-list-name*)) |
86 | "Append LIST to the tail of `collecting' list NAME. This obviously | |
87 | involves copying LIST." | |
88 | (with-gensyms item | |
89 | `(dolist (,item ,list) | |
90 | (collect ,item ,name)))) | |
91 | ||
92 | (defmacro collect-nconc (list &optional (name *collecting-anon-list-name*)) | |
93 | "Attach LIST to the tail of `collecting' list NAME. This will involve | |
94 | destroying LIST if anything else gets collected afterwards." | |
95 | (let*/gensyms list | |
96 | `(when ,list | |
97 | (setf (cdar ,name) ,list) | |
98 | (setf (car ,name) (last ,list))))) | |
99 | ||
861345b4 | 100 | ;;;----- That's all, folks -------------------------------------------------- |