(in-package "NAPA-FFT")

(defmacro unrolled-for (((var count &key (offset 0) (stride 1) (type t)) &rest var-data)
                        &body body)
  (assert (numberp count))
  (let ((var-data (cons `(,var :offset ,offset :stride ,stride :type ,type)
                        var-data))
        (var-names   '())
        (var-offsets '())
        (var-strides '())
        (var-types   '()))
    (dolist (data var-data)
      (destructuring-bind (var &key (offset 0) (stride 1) (type t)) data
        (push var var-names)
        (push offset var-offsets)
        (push stride var-strides)
        (push type var-types)))
    (setf var-names (nreverse var-names)
          var-offsets (nreverse var-offsets)
          var-strides (nreverse var-strides)
          var-types   (nreverse var-types))
    (labels ((rec (count initials)
               (and (plusp count)
                    `(let ,(mapcar (lambda (name initial type)
                                     `(,name (the ,type ,initial)))
                            var-names initials var-types)
                       (declare (ignorable ,var))
                       ,@body
                       ,(rec (1- count)
                             (mapcar (lambda (stride name)
                                       `(+ ,stride ,name))
                                     var-strides var-names))))))
      (rec count var-offsets))))

(defvar *function-bodies*)
(defvar *generated-bodies*)
(defvar *declarations*)

(defmacro with-function-bodies (&body body)
  `(let ((*function-bodies* nil)
         (*declarations*    nil)
         (*generated-bodies* (make-hash-table :test #'equal)))
     ,@body
     (values (reverse *function-bodies*)
             (reverse *declarations*))))

(defun symbolicate (root value &rest values)
  (intern (format nil "~A[~{~A~^/~}]" root (cons value values))))

(defmacro ensure-body ((root value &rest values) (&rest arg-list) &body body)
  (let ((_key  (gensym "KEY"))
        (_name (gensym "NAME")))
    `(let ((,_key (list ',root ,value ,@values)))
       (cond ((gethash ,_key *generated-bodies*))
             (t
              (let ((,_name (apply 'symbolicate ,_key)))
                (setf (gethash ,_key *generated-bodies*) ,_name)
                (multiple-value-bind (body declarations)
                    (locally ,@body)
                  (push (list* ,_name ',arg-list body)
                        *function-bodies*)
                  (setf *declarations* (nconc (reverse (subst ,_name '.self. declarations))
                                              *declarations*)))
                ,_name))))))

(defmacro named-lambda (name lambda-list &body body)
  #+sbcl `(sb-int:named-lambda ,name ,lambda-list ,@body)
  `(flet ((,name ,lambda-list
            ,@body))
     #',name))

(in-package "NAPA-FFT")

(defmacro unrolled-for (((var count &key (offset 0) (stride 1) (type t)) &rest var-data)
                        &body body)
  (assert (numberp count))
  (let ((var-data (cons `(,var :offset ,offset :stride ,stride :type ,type)
                        var-data))
        (var-names   '())
        (var-offsets '())
        (var-strides '())
        (var-types   '()))
    (dolist (data var-data)
      (destructuring-bind (var &key (offset 0) (stride 1) (type t)) data
        (push var var-names)
        (push offset var-offsets)
        (push stride var-strides)
        (push type var-types)))
    (setf var-names (nreverse var-names)
          var-offsets (nreverse var-offsets)
          var-strides (nreverse var-strides)
          var-types   (nreverse var-types))
    (labels ((rec (count initials)
               (and (plusp count)
                    `(let ,(mapcar (lambda (name initial type)
                                     `(,name (the ,type ,initial)))
                            var-names initials var-types)
                       (declare (ignorable ,var))
                       ,@body
                       ,(rec (1- count)
                             (mapcar (lambda (stride name)
                                       `(+ ,stride ,name))
                                     var-strides var-names))))))
      (rec count var-offsets))))

(defvar *function-bodies*)
(defvar *generated-bodies*)
(defvar *declarations*)

(defmacro with-function-bodies (&body body)
  `(let ((*function-bodies* nil)
         (*declarations*    nil)
         (*generated-bodies* (make-hash-table :test #'equal)))
     ,@body
     (values (reverse *function-bodies*)
             (reverse *declarations*))))

(defun symbolicate (root value &rest values)
  (intern (format nil "~A[~{~A~^/~}]" root (cons value values))))

(defmacro ensure-body ((root value &rest values) (&rest arg-list) &body body)
  (let ((_key  (gensym "KEY"))
        (_name (gensym "NAME")))
    `(let ((,_key (list ',root ,value ,@values)))
       (cond ((gethash ,_key *generated-bodies*))
             (t
              (let ((,_name (apply 'symbolicate ,_key)))
                (setf (gethash ,_key *generated-bodies*) ,_name)
                (multiple-value-bind (body declarations)
                    (locally ,@body)
                  (push (list* ,_name ',arg-list body)
                        *function-bodies*)
                  (setf *declarations* (nconc (reverse (subst ,_name '.self. declarations))
                                              *declarations*)))
                ,_name))))))

(defmacro named-lambda (name lambda-list &body body)
  #+sbcl `(sb-int:named-lambda ,name ,lambda-list ,@body)
  `(flet ((,name ,lambda-list
            ,@body))
     #',name))
