/[cl-utilities]/cl-utilities/collecting.lisp
ViewVC logotype

Contents of /cl-utilities/collecting.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Mon Aug 29 20:14:47 2005 UTC (8 years, 7 months ago) by pscott
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +1 -1 lines
Added split-sequence, made slight changes, updated package.sh to match my
current machine.
1 ;; Opinions differ on how a collection macro should work. There are
2 ;; two major points for discussion: multiple collection variables and
3 ;; implementation method.
4 ;;
5 ;; There are two main ways of implementing collection: sticking
6 ;; successive elements onto the end of the list with tail-collection,
7 ;; and using the PUSH/NREVERSE idiom. Tail-collection is usually
8 ;; faster, except on CLISP, where PUSH/NREVERSE is a little faster.
9 ;;
10 ;; The COLLECTING macro only allows collection into one list, and you
11 ;; can't nest them to get the same effect as multiple collection since
12 ;; it always uses the COLLECT function. If you want to collect into
13 ;; multiple lists, use the WITH-COLLECT macro.
14
15 (in-package :cl-utilities)
16
17 ;; This should only be called inside of COLLECTING macros, but we
18 ;; define it here to provide an informative error message and to make
19 ;; it easier for SLIME (et al.) to get documentation for the COLLECT
20 ;; function when it's used in the COLLECTING macro.
21 (defun collect (thing)
22 "Collect THING in the context established by the COLLECTING macro"
23 (error "Can't collect ~S outside the context of the COLLECTING macro"
24 thing))
25
26 (defmacro collecting (&body body)
27 "Collect things into a list forwards. Within the body of this macro,
28 the COLLECT function will collect its argument into the list returned
29 by COLLECTING."
30 (with-unique-names (collector tail)
31 `(let (,collector ,tail)
32 (labels ((collect (thing)
33 (if ,collector
34 (setf (cdr ,tail)
35 (setf ,tail (list thing)))
36 (setf ,collector
37 (setf ,tail (list thing))))))
38 ,@body)
39 ,collector)))
40
41 (defmacro with-collectors ((&rest collectors) &body body)
42 "Collect some things into lists forwards. The names in COLLECTORS
43 are defined as local functions which each collect into a separate
44 list. Returns as many values as there are collectors, in the order
45 they were given."
46 (%with-collectors-check-collectors collectors)
47 (let ((gensyms-alist (%with-collectors-gensyms-alist collectors)))
48 `(let ,(loop for collector in collectors
49 for tail = (cdr (assoc collector gensyms-alist))
50 nconc (list collector tail))
51 (labels ,(loop for collector in collectors
52 for tail = (cdr (assoc collector gensyms-alist))
53 collect `(,collector (thing)
54 (if ,collector
55 (setf (cdr ,tail)
56 (setf ,tail (list thing)))
57 (setf ,collector
58 (setf ,tail (list thing))))))
59 ,@body)
60 (values ,@collectors))))
61
62 (defun %with-collectors-check-collectors (collectors)
63 "Check that all of the COLLECTORS are symbols. If not, raise an error."
64 (let ((bad-collector (find-if-not #'symbolp collectors)))
65 (when bad-collector
66 (error 'type-error
67 :datum bad-collector
68 :expected-type 'symbol))))
69
70 (defun %with-collectors-gensyms-alist (collectors)
71 "Return an alist mapping the symbols in COLLECTORS to gensyms"
72 (mapcar #'cons collectors
73 (mapcar (compose #'gensym
74 #'(lambda (x)
75 (format nil "~A-TAIL-" x)))
76 collectors)))
77
78 ;; Some test code which would be too hard to move to the test suite.
79 #+nil (with-collectors (one-through-nine abc)
80 (mapcar #'abc '(a b c))
81 (dotimes (x 10)
82 (one-through-nine x)
83 (print one-through-nine))
84 (terpri) (terpri))

  ViewVC Help
Powered by ViewVC 1.1.5