Common lisp list comprehension (just for lulz) №2

(require 'asdf)
(asdf:load-system :split-sequence)

(defpackage list-comprehension (:use :cl :split-sequence))
(in-package :list-comprehension)

(defun subseq-position (subseq sequence &key (test #'eql))
  (labels ((subseq-position% (subseq)
             (if (> (length subseq) 0)
                 (let ((first-elem-pos (position (elt subseq 0) sequence :test test)))
                   (if first-elem-pos
                       (multiple-value-bind (pos found)
                           (subseq-position% (subseq subseq 1))
                         (declare (ignore pos))
                         (if found (values first-elem-pos t)))))
                 (values nil t))))
    (values (subseq-position% subseq))))

(defun reader-macro-[ (stream char)
  (declare (ignore char))
  (let* ((expr (coerce (loop for char = (read-char stream)
                             while (char/= char #\]) collect char)
                       'string))
         (clauses (split-sequence #\, expr))
         (gen-name (gensym))
         bindings aux-bindings conditions side-effects)
    ;; First clause is a 'collect' clause
    (destructuring-bind (collect-form . rest) clauses
      (when rest
        (loop for clause in rest do
             (cond
               ;; Binding
               ((subseq-position "<-" clause)
                (let* ((position (subseq-position "<-" clause))
                       (var   (subseq clause 0 position))
                       (value (subseq clause (+ 2 position))))
                  (push (list (gensym)
                              (read-from-string var)
                              (read-from-string value)) bindings)))
               ;; Side effects
               ((find #\^ clause)
                (push (read-from-string (remove #\^ clause)) side-effects))
               ;; Aux bindings
               ((subseq-position "==" clause)
                (let* ((position (subseq-position "==" clause))
                       (var   (subseq clause 0 position))
                       (value (subseq clause (+ 2 position))))
                  (push (cons (read-from-string var)
                              (read-from-string value))
                        aux-bindings)))
               ;; Condition
               (t
                (push (read-from-string clause) conditions))))

        `(let
             ;; Set environment
             ,(loop for binding in bindings collect
                   (destructuring-bind (sym var value) binding
                     (declare (ignore var))
                     `(,sym ,value)))

           (labels ((,gen-name ()
             (when (or ,@(loop for binding in bindings
                            for sym = (first binding) collect sym))
               ;; Set bindings
               (let*
                   (,@(loop for binding in bindings collect
                           (destructuring-bind (sym var value) binding
                             (declare (ignore value))
                             `(,var (first ,sym))))
                    ,@(loop for binding in aux-bindings collect
                           (destructuring-bind (var . value) binding
                             `(,var ,value))))

                 ;; Modify lists
                 ,@(loop for binding in bindings collect
                        `(setq ,(car binding) (cdr ,(car binding))))

                 (if ,(if conditions `(and ,@conditions) t)
                     (progn
                       ;; Run side effects first
                       ,@side-effects
                       ,(read-from-string collect-form))
                     (,gen-name))))))
             #',gen-name))))))

(set-macro-character #\[ #'reader-macro-[)
(set-macro-character #\] (get-macro-character #\)))

(defun all (gen)
  (loop for val = (funcall gen)
        while val collect val))

(defmacro test (bool)
  `(if (not ,bool)
       (format *error-output* "~a is not t~%" ',bool)))

(defun run-tests ()
  (test (equal (all [(* x y), x <- '(0 1 1), y <- '(2 1 4)]) '(0 1 4)))
  (test (equal (all [x, x <- (loop for i below 6 collect i), (oddp x)]) '(1 3 5)))
  (test (equal (all [y, x <- (loop for i below 3 collect i), y == (* 2 x)]) '(0 2 4)))
  (test
   (string= "hihihi"
            (with-output-to-string (out)
              (all
               [x, x <- (loop repeat 3 collect t), ^ (format out "hi")])))))
(run-tests)