collect.el

; emacs lisp version

(cl-defmacro collect (val (&rest seqs) &rest tests)
  (unless (cl-every
            (lambda (x)
              (and (listp x)
                   (= (length x) 2)
                   (symbolp (car x))))
            seqs)
    (error "Bad collect form ~A" (list* 'collect val seqs tests)))
  (let ((res (gensym)))
    (cl-labels
        ((test (tests)
           (if (null tests)
             `(setf ,res (cons ,val ,res))
             `(if ,(car tests)
                  ,(test (cdr tests)))))
         (iter (seqs)
           (if (null seqs)
             (test tests)
             `(seq-doseq (,(caar seqs) ,(cadar seqs))
                ,(iter (cdr seqs))))))
      `(let* ((,res nil))
         ,(iter seqs)
         (nreverse ,res)))))

collect.lisp

; comprehensive in today words

(defmacro collect (&whole whole val (&rest seqs) &rest tests)
  (unless (every
            (lambda (x)
              (and (listp x)
                   (= (length x) 2)
                   (symbolp (car x))))
            seqs)
    (error "Bad collect form ~A" whole))
  (let ((acc (gensym)) (res (gensym)))
    (labels ((test (tests)
               (if (null tests)
                 `(setf (cdr ,acc) (cons ,val nil)
                        ,acc (cdr ,acc))
                 `(if ,(car tests)
                    ,(test (cdr tests)))))
             (iter (seqs)
               (if (null seqs)
                 (test tests)
                 `(map nil
                   (lambda (,(caar seqs))
                     (declare (ignorable ,(caar seqs)))
                     ,(iter (cdr seqs)))
                   ,(cadar seqs)))))
      `(locally
         (declare (inline map))
         (let* ((,res (cons nil nil))
               (,acc ,res))
          ,(iter seqs)
          (cdr ,res))))))

(let ((bad (cons nil nil)))
  (set-dispatch-macro-character #\# #\l
   (lambda (stream char n)
     (declare (ignore n char))
     (let ((lst (read stream nil bad t)))
       (if (or (eq lst bad) (not (listp lst)))
         (error "No List after #L (COLLECT)"))
       (cons 'collect lst)))))

#|
test

(declaim (optimize (speed 3))
         (inline iota))
(defun iota (n)
  (loop for i from 0 to n collect i))

(defun primep (n)
  (labels ((primep (x f)
             (cond ((= x n) (funcall f x))
                   ((> x n) nil)
                   ((funcall f x)
                    (primep
                     (1+ x)
                     (lambda (y) (and (funcall f y) (/= 0 (mod y x))))))
                   (t (primep (1+ x) f)))))
    (primep 2 (lambda (x) (/= 0 (mod x 2))))))

(disassemble
  '(lambda ()
     #c((list i j) ((i (iota 1000)) (j (iota i))) (primep (+ i j)))))
(print
  (macroexpand-1 '#c((list i j) ((i (iota 1000)) (j (iota i))) (primep (+ i j)))))
(print #c(i ((i (iota 1000))) (primep i)))
|#