Loop fusion for more confusion

fusion-sketch.lisp

(defclass fusion-info ()
  ((names :initarg :names
          :initform nil
          :accessor names)
   (fields :initarg :fields
           :initform nil
           :accessor fields)
   (returns :initarg :returns
            :initform nil
            :accessor returns)
   (stop-cond :initarg :stops
              :initform nil
              :accessor stops)
   (filters :initarg :filters
            :initform nil
            :accessor filters)
   (nexts :initarg :nexts
          :initform nil
          :accessor nexts)))



                              ;; Suppose this is 
(collect (iter v) 'vector)    ;; our iterator chain which we want to
                              ;; loop fuse

(defpolymorph expand ((type (eql collect)) form &optional env) list
  (destructuring-bind (collect form into-type) form
    (declare (ignore collect))
    (let ((my-class (let ((i (gensym "I"))           ;; This is the place where we would
                          (v (gensym "V")))          ;; "get-setf-expansion" of sorts
                     (make-instance 'fusion-info     ;; I didn't come up with the interface yet
                                    :names (list i v);; but I will. For now I ll just put
                                    :fields '(0 v)   ;; this class here as is
                                    :stops `(>= ,i (length ,v))
                                    :returns `(aref ,v ,i)
                                    :nexts `((incf ,i))))))
      (when  (equal into-type ''vector)               ;; Here the dispatch would be better than stupid when
                                                      ;; but I put it here to make it more clear
         `(let* ((res (make-array 0)))                ;; where I dispatch what
             (let* (,@(mapcar #'list (names my-class) (fields my-class)))
               (loop (if ,(stops my-class)
                         (return res)
                         (progn (vector-push-extend ,(returns my-class) res)
                                ,@(nexts my-class))))))))))
                                                      ;; there should be dispatch for collecting into list
                                                      ;; hash-table/rb-tree etc, but we can think of the design later

;; call it like this
DATA-STRUCTURES> (expand 'collect '(collect (iter v) 'vector))
(LET* ((RES (MAKE-ARRAY 0)))
  (LET* ((#:I742 0) (#:V743 V))
    (LOOP
     (IF (>= #:I742 (LENGTH #:V743))
         (RETURN RES)
         (PROGN (VECTOR-PUSH-EXTEND (AREF #:V743 #:I742) RES) (INCF #:I742))))))