Simplify with-collectors macro

utils.lisp

@@ -64,45 +64,37 @@
   ``(progn ,@(loop for ,element in ,list collect (progn ,@body))))
 
 
-;;; TODO: Document me!
-(defmacro with-collectors ((&rest names) &body code)
-  (let ((names (mapcar #'mklist names))
-        ;; A list of lists of the form (NAME INITFORM BEGIN END
-        ;; FNAME), where BEGIN and END are the gensymed symbols of the
-        ;; first and the last cons of the collector. Note we use a
-        ;; special header cons.
-        (table nil))
-    ;; Fill the table
-    (dolist (collector names)
-      (destructuring-bind (name &optional initform fname) collector
-        (push (list name
-                    initform
-                    (gensym)
-                    (gensym)
-                    (or fname (symbolize 'collect- name)))
-              table)))
-    (macrolet (;; Map through collectors binding NAME INITFORM BEGIN
-               ;; and END variables, collecting the results in a list.
-               (map* (form)
-                 `(loop for (name initform begin end fname)
-                        in table
-                        collect ,form)))
-      ;; Macroexpansion
-      `(let ,(map* `(,begin (cons :collector ,initform)))
-         (let ,(map* `(,end (last ,begin)))
-           (symbol-macrolet ,(map* `(,name (cdr ,begin)))
-             (flet ,(map* `(,fname (value)
-                                   (setf (cdr ,end) (list value))
-                                   (setf ,end (cdr ,end))
-                                   (cdr ,begin)))
-               ,@code)))))))
-
-;;; TODO: Document me!
-(defmacro with-collect (&body code)
-  (with-gensyms (name)
-    `(with-collectors ((,name nil collect))
-       ,@code
-       ,name)))
+(defmacro with-named-collector% ((accumulator initial collector) &body body)
+  (check-type accumulator symbol)
+  (check-type collector symbol)
+  (let ((head (gensym))
+        (tail (gensym)))
+    `(let* ((,head (cons :accumulator ,initial))
+            (,tail ,head))
+       (flet ((,collector (item)
+                (let ((c (list item)))
+                  (setf (cdr ,tail) c)
+                  (setf ,tail c))))
+         (symbol-macrolet ((,accumulator (cdr ,head)))
+           ,@body)))))
+
+(defmacro with-collect (&body body)
+  (let ((accumulator (gensym)))
+    `(with-named-collector% (,accumulator nil collect)
+       ,@body
+       ,accumulator)))
+
+(defmacro with-collectors (names &body body)
+  (if (null names)
+      `(progn ,@body)
+      (destructuring-bind (name
+                           &optional
+                           initial
+                           (collector (intern (format nil "COLLECT-~a" (string name)))))
+          (mklist (car names))
+        `(with-named-collector% (,name ,initial ,collector)
+           (with-collectors ,(cdr names)
+             ,@body)))))
 
 
 ;;;; Declarations and definitions facilities