(in-package :cl-smoke.qt.core)

(defvar *cxx-lisp-objects* (smoke::make-synchronized-hash-table)
  "Objects that are currently passed in a C++ class.")

(let ((id 0))
  (declare (type (smoke::c-integer :unsigned-int) id))
  (defun gen-cxx-lisp-object-id ()
    "Returns a new unique ID."
    (loop do
         (setf id
               (logand (1- (expt 2 (* 8 (foreign-type-size :unsigned-int) )))
                       (1+ id)))
       while (nth-value 1 (gethash id *cxx-lisp-objects*)))
    id))
    
(defcfun cl-smoke-setup-lisp-object :int
  (destruct :pointer))

(defcfun cl-smoke-lisp-object-id :unsigned-int
  (object :pointer))

(defcfun cl-smoke-lisp-object-is-set :int
  (object :pointer))

(defcfun cl-smoke-make-lisp-object :pointer
  (id :unsigned-int))

(defcfun cl-smoke-free-lisp-object :void
  (object :pointer))

(defcallback destruct-cxx-lisp-object :void
    ((id :unsigned-int))
  (remhash id *cxx-lisp-objects*))

(defvar *cxx-lisp-object-metatype* "Metatype ID of the C++ lisp_object.")

(eval-startup ()
  (setf *cxx-lisp-object-metatype*
        (cl-smoke-setup-lisp-object (callback destruct-cxx-lisp-object)))
  (assert (>= *cxx-lisp-object-metatype*
              (smoke::value qt:meta-type.+user+))
          (*cxx-lisp-object-metatype*)
          "setup of lisp-object failed"))

(defun make-cxx-lisp-object (object)
  "Constructs a C++ object wrapper for OBJECT."
  (let ((id (gen-cxx-lisp-object-id)))
    (setf (gethash id *cxx-lisp-objects*) object)
    (cl-smoke-make-lisp-object id)))

(defun free-cxx-lisp-object (pointer)
  "Deletes the lisp_object at POINTER."
  (cl-smoke-free-lisp-object pointer))
;;  (qmetatype.destroy *cxx-lisp-object-metatype* pointer)) ;; FIXME use this?

(defun translate-cxx-lisp-object (pointer)
  "Returns the object of the cxx-lisp-object at POINTER.

When being received as an argument by a slot,
the object must not be deallocated."
  (multiple-value-bind (value present-p)
      (gethash (cl-smoke-lisp-object-id pointer)
               *cxx-lisp-objects*)
    (assert present-p (value present-p)
            "No object for ~A in ~A" pointer *cxx-lisp-objects*)
    value))