collect.lisp

;; See https://tailrecursion.com/jlt/posts/collecting-macro-edition.html

;; Shared implementation of collector, providing a standalone collector
;; via MAKE-COLLECTOR and an flet-scoped collector via WITH-COLLECTOR

(defun %collector-impl (head tail)
  (let* ((item (gensym "ITEM"))
         (item-passed (gensym "ITEM-PASSED"))
         (new-tail (gensym "NEW-TAIL")))
    `((&optional (,item nil ,item-passed))
      (cond
        (,item-passed
         (cond
           ((null ,tail)
            (setq ,tail (cons ,item nil)
                  ,head ,tail))
           (t (let ((,new-tail (cons ,item nil)))
                (setf (cdr ,tail) ,new-tail
                      ,tail ,new-tail))))
         ,head)
        (t
         (values ,head ,tail))))))

(defmacro %lambda-collector (head tail)
  (assert (and (symbolp head) (not (keywordp head)))
          (head) "HEAD must be a non-keyword symbol")
  (assert (and (symbolp tail) (not (keywordp tail)))
          (tail) "TAIL must be a non-keyword symbol")
  `(lambda ,@(%collector-impl head tail)))

(defun make-collector ()
  (let (head tail)
    (%lambda-collector head tail)))

(defmacro with-collector ((&key collect head tail) &body body)
  (assert (and (symbolp collect) (not (keywordp collect)))
          (collect) "COLLECT must be a non-keyword symbol")
  (let ((collect (or collect 'collect))
        (head (or head (gensym "HEAD")))
        (tail (or tail (gensym "TAIL"))))
    `(let (,head ,tail)
       (flet ((,collect ,@(%collector-impl head tail)))
         (declare (inline ,collect))
         ,@body
         (values ,head ,tail)))))

;; CL-USER> (let ((c (make-collector)))
;;            (funcall c 1)
;;            (funcall c 2)
;;            (funcall c))
;; (1 2)
;; (2)

;; CL-USER> (with-collector ()
;;            (map nil #'collect '(1 2 3 4 5 6)))
;; (1 2 3 4 5 6)
;; (6)

;; CL-USER> (with-collector (:head head)
;;            (map nil (lambda (x) (if (oddp x) (collect x) (push x head))) '(1 2 3 4 5 6)))
;; (6 4 2 1 3 5)
;; (5)