(in-package #:ocl)

(defmacro define-get-info ())

(define-condition opencl-error ()
  ((code :initarg :code
          :reader opencl-error-code))
  (:report (lambda (condition stream)
             (format stream "OPENCL-ERROR: ~A~%" (opencl-error-code condition)))))

(defmacro check-error (error-code)
  (alexandria:once-only (error-code)
    `(unless (eq ,error-code :success)
       (error 'opencl-error :code ,error-code))))

;; TODO: Finish me
(defun array-foreign-type (array)
  "Returns the most appropiate foreign type to store ARRAY"
  (case (array-element-type array)
    (single-float :float)
    (double-float :double)
    (t nil)))

(defun array-foreign-size (array)
  "Returns the size in bytes required to store a foreign version of ARRAY"
  (reduce #'* (array-dimensions array)
          :initial-value (cffi:foreign-type-size (array-foreign-type array))))

(defmacro check-error-arg (form)
  (let ((value (gensym "VALUE"))
        (error-code (gensym "ERROR-CODE"))
        (c-error-code (gensym "C-ERROR-CODE")))
    `(cffi:with-foreign-object (,c-error-code 'cl-error-code)
       (let* ((,value (,@form ,c-error-code))
              (,error-code (cffi:mem-ref ,c-error-code 'cl-error-code)))
         (if (eq ,error-code :success)
             ,value
             (error 'opencl-error :code ,error-code))))))

(defmacro with-foreign-arrays (bindings &body body)
  (if (null bindings)
      `(progn ,@body)
      `(cffi:with-foreign-array ,(first bindings)
         (with-foreign-arrays ,(rest bindings)
           ,@body))))

(defmacro with-foreign-sequence ((var lisp-sequence type &optional length) &body body)
  "Like CFFI:WITH-FOREIGN-ARRAY but works also for lists"
  (unless length (setf length (gensym "LENGTH")))
  (alexandria:once-only (lisp-sequence type)
    `(let ((,length (length ,lisp-sequence)))
       (cffi:with-foreign-object (,var ,type ,length)
         (dotimes (i ,length)
           (setf (cffi:mem-aref ,var ,type i) (elt ,lisp-sequence i)))
         ,@body))))

(defmacro with-foreign-sequences (bindings &body body)
  (if bindings
      `(with-foreign-sequence ,(first bindings)
         (with-foreign-sequences ,(rest bindings)
           ,@body))
      `(progn ,@body)))

(defun vector-type-p (type)
  (and (consp type) (eq (car type) :pointer)))

(defun string-type-p (type)
  (eq type :string))

(defmacro wrap-get-info-function (name low-level-name type-alist)
  ""
  ;; FIXME? This is a top level form, no call to GENSYM is needed, right?
  `(defun ,name (object param-name)
     (let ((type (assoc-value ,type-alist param-name))
           (return-size nil)
           (error-code nil)
           (return-value nil))
       (cffi:with-foreign-object (c-return-size :size)
         (setf error-code (,low-level-name object param-name 0 (cffi:null-pointer) c-return-size))
         (check-error error-code)
         (setf return-size (cffi:mem-ref c-return-size :size)))
       (cond ((vector-type-p type)
              (let ((count (/ return-size (cffi:foreign-type-size (second type)))))
                (cffi:with-foreign-object (c-value type count)
                  (setf error-code (,low-level-name object param-name return-size c-value (cffi:null-pointer)))
                  (setf return-value (loop :for i :below count :collect (cffi:mem-aref c-value type i))))))
             ((string-type-p type)
              (setf return-value
                    (cffi:with-foreign-pointer-as-string (c-string return-size)
                      (setf error-code (,low-level-name object param-name return-size c-string (cffi:null-pointer))))))
             (t
              (cffi:with-foreign-object (c-value type)
                (setf error-code (,low-level-name object param-name (cffi:foreign-type-size type)
                                                  c-value (cffi:null-pointer)))
                (setf return-value (cffi:mem-ref c-value type)))))
       (check-error error-code)
       return-value)))

(defmacro get-cl-objects (name (&rest args) low-level-name type)
  (assert (every #'symbolp args) nil "ARGS must be a list of only symbols")
  `(defun ,name (,@args)
     (let (n)
       (cffi:with-foreign-object (cn 'cl-uint)
         (check-error (,low-level-name ,@args 0 (cffi:null-pointer) cn))
         (setf n (cffi:mem-ref cn 'cl-uint)))
       (cffi:with-foreign-object (c-objects ,type n)
         (check-error (,low-level-name ,@args n c-objects (cffi:null-pointer)))
         (loop :for i :below n
               :collect (cffi:mem-aref c-objects ,type i))))))