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) ,@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 (,@let-bindings) (flet (,@flet-bindings) ,@(if dynamic-extent-fns `((declare (dynamic-extent ,@(nreverse (loop for fn in dynamic-extent-fns collect `#',fn)))))) ,@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 (,@let-bindings) (flet (,@flet-bindings) ,@(if dynamic-extent-fns `((declare (dynamic-extent ,@(nreverse (loop for fn in dynamic-extent-fns collect `#',fn)))))) ,@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 ,@body (values ,@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))))