[alexandria-devel] Possible WITH-COLLECTOR/COLLECTORS macros

[Faré]

CLISP has the similar EXT:WITH-COLLECT.
ASDF 1.630 has a similar WHILE-COLLECTING (taken from FARE-UTILS)
with identical specification:

(defmacro while-collecting ((&rest collectors) &body body)
  (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
        (initial-values (mapcar (constantly nil) collectors)))
    `(let ,(mapcar #'list vars initial-values)
       (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v))) collectors vars)
         , at body
         (values ,@(mapcar #'(lambda (v) `(nreverse ,v)) vars))))))

At ITA, we use a slightly more elaborate variant
that allows to peek at the list being created
(which is admittedly seldom used).
I copied the relevant section of our quux/macros.lisp below.

[ François-René ÐVB Rideau | Reflection&Cybernethics | http://fare.tunes.org ]
Resentment is like taking poison and waiting for the other person to die.
	— Malachy McCourt

(defmacro with-collectors ((&rest collection-descriptions)
			   &body body)

  "COLLECTION-DESCRIPTIONS is a list of clauses, each of which is
   (VARIABLE FUNCTION).  The body can call FUNCTION on an argument
   to add that value to the end of a list kept in the value of VARIABLE.
   FUNCTION runs in constant time, regardless of the length of the list.
   Alternatively, a clause can be (PLACE FUNCTION :FREE T), in which
   case no variable is bound, and FUNCTION (destructively) adds the value
   to the list already stored in PLACE."

  (let ((let-bindings nil)
        (flet-bindings nil)
        (object '#:OBJECT)
        (dynamic-extent-fns nil))
    (dolist (collection-description collection-descriptions)
      (destructuring-bind (collection-place collector-name &key free elem-type)
          collection-description
        (let ((tail-name (make-symbol (format nil "~A-TAIL" collection-place))))
          (unless free
            (assert (not (listp collection-place)) ()
                    "Unless it is free, the collection name must be a
symbol, not ~A~%"
                    collection-place)
            (push collector-name dynamic-extent-fns))
          (setq let-bindings
                (nconc let-bindings
                       `(,@(unless free `((,collection-place nil)))
                           (,tail-name ,@(if free
                                           `((last ,collection-place))
                                           `(()))))))
          (setq flet-bindings
                (nconc flet-bindings
                       `((,collector-name (,object)
                           ,@(when elem-type
			       `((check-type ,object ,elem-type)))
			   (setq ,tail-name
				   (if ,tail-name
				     (setf (cdr ,tail-name)  (list ,object))
				     (setf ,collection-place (list ,object)))))))))))
    `(let (, at let-bindings)
       (flet (, at flet-bindings)
         ,@(if dynamic-extent-fns
             `((declare (dynamic-extent ,@(nreverse (loop for fn in
dynamic-extent-fns
                                                          collect `#',fn))))))
         , at body))))

(defmacro with-unique-collectors ((&key (test '#'eql)) (&rest
collection-descriptions)
				  &body body)

  "COLLECTION-DESCRIPTIONS is a list of clauses, each of which is
   (VARIABLE FUNCTION).  The body can call FUNCTION on one argument
   to add that value to the end of a list kept in the value of VARIABLE.
   FUNCTION runs in constant time, regardless of the length of the list.
   Alternatively, a clause can be (PLACE FUNCTION :FREE T), in which
   case no variable is bound, and FUNCTION adds the value to the list
   already stored in PLACE.

   This collects only a single occurrence of each object, using TEST
   to test the equality."

  (let ((let-bindings nil)
        (flet-bindings nil)
        (object '#:OBJECT)
        (dynamic-extent-fns nil))
    (dolist (collection-description collection-descriptions)
      (destructuring-bind (collection-place collector-name &key free elem-type)
          collection-description
        (let ((tail-name (make-symbol (format nil "~A-TAIL" collection-place))))
          (unless free
            (assert (not (listp collection-place)) ()
                    "Unless it is free, the collection name must be a
symbol, not ~A~%"
                    collection-place)
            (push collector-name dynamic-extent-fns))
          (setq let-bindings
                (nconc let-bindings
                       `(,@(unless free `((,collection-place nil)))
                           (,tail-name ,@(if free
                                           `((last ,collection-place))
                                           `(()))))))
          (setq flet-bindings
                (nconc flet-bindings
                       `((,collector-name (,object)
                           ,@(when elem-type `((check-type ,object ,elem-type)))
			   (unless (member ,object ,collection-place :test ,test)
			     (setq ,tail-name (if ,tail-name
						(setf (cdr ,tail-name) (list ,object))
						(setf ,collection-place (list ,object))))))))))))
    `(let (, at let-bindings)
       (flet (, at flet-bindings)
         ,@(if dynamic-extent-fns
             `((declare (dynamic-extent ,@(nreverse (loop for fn in
dynamic-extent-fns
                                                          collect `#',fn))))))
         , at body))))

;; provides the same semantics as the macro WITH-COLLECT from GNU clisp.
;; See also with-collectors above if you need more control.
(defmacro with-collected-results ((&rest collectors) &body body)
  (loop for c in collectors
        for l = (gensym "LIST")
        collect l into collections
        collect (list l c) into collection-descriptions
        finally (return `(with-collectors ,collection-descriptions
                           , at body (values , at collections)))))

(defmacro collected-values (&rest collect-descriptions)
  "Each collect-description is (a b).
   For each collect-description, if a is non-null collect b."
  (with-gensyms (coll)
    `(with-collected-results (,coll)
       ,@(mapcar #'(lambda (c)
                     `(when ,(first c)
                        (,coll ,(second c))))
                 collect-descriptions))))