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

(defun find-type (smoke-module name &optional start end)
  (let ((type (make-smoke-type smoke-module (subseq name start end))))
    (assert (not (zerop (id type)))
            ()
            "No type named ~S found in ~A."
            (subseq name start end) smoke-module)
    type))

(defun method-arguments-type (object index)
  "Returns a type name list for the arguments of method INDEX of OBJECTs metaobject."
  (let* ((metaobject (cxx:meta-object object))
         (signature (cxx:signature (cxx:method metaobject index)))
         (arguments (subseq signature (1+ (position #\( signature))
                            (position #\) signature :from-end t)))
         (argument-types ())
         (last-pos (length arguments))
         (smoke-module (smoke (class-of object))))
    (loop as pos = (position #\, arguments :from-end t :end last-pos)
       while pos
       do
         (push (find-type smoke-module arguments (1+ pos) last-pos) argument-types)
         (setf last-pos pos))
    (when (> last-pos 0)
      (push (find-type smoke-module arguments 0 last-pos) argument-types))))


(defun arguments-to-lisp2 (argument types values)
  (if (null types)
      values
      (arguments-to-lisp2 (inc-pointer argument (foreign-type-size :pointer))
                          (rest types)
                          (nconc values
                                 (list 
                                  (typecase (first types)
                                    (smoke-type
                                     (pointer-to-lisp (mem-ref argument :pointer)
                                                      (first types)))
                                     
                                    (t
                                     (translate-cxx-lisp-object
                                      (mem-ref argument :pointer)))))))))

(defun disown-object (object)
  (tg:cancel-finalization object)
  (unless (virtual-destructor-p (class-of object))
    (remove-object (pointer object)))
  object)

(defun pointer-to-lisp (pointer type)
  "Returns the lisp value or object at POINTER of type TYPE."
  (if (class-p type)
      (if (pointer-p type)
          (object-to-lisp (mem-ref pointer :pointer) type)
          ;; By-value means that the object at POINTER is allocated by
          ;; the C++ signal code and has dynamic extend in the
          ;; slot. The C++ signal code frees the object when the slot
          ;; returns.
          (disown-object (object-to-lisp pointer type)))
      (ecase (type-id type)
        (0 (if-let ((translation (gethash (name type) *to-lisp-translations*)))
             ;; Do not free stack allocated stuff (e.g.: QString); that is the callers
             ;; responisbility.
             (funcall (car translation) pointer)
             (error "Do not know how to convert the type ~A to Lisp." type)))
        (1 (mem-ref pointer 'cxx-bool))
        (2 (code-char (mem-ref pointer :char)))
        (3 (code-char (mem-ref pointer :unsigned-char)))
        (4 (code-char (mem-ref pointer :short)))
        (5 (code-char (mem-ref pointer :unsigned-short)))
        (6 (mem-ref pointer :int))
        (7 (mem-ref pointer :unsigned-int))
        (8 (mem-ref pointer :long))
        (9 (mem-ref pointer :unsigned-long))
        (10 (mem-ref pointer :float))
        (11 (mem-ref pointer :double))
        (12 (make-instance 'enum
                           :value (mem-ref pointer :long)
                           :type type)))))
     
       
(defun arguments-to-lisp (arguments types)
  "Returns ARGUMENTS for a slot invocation as lisp objects."
  (arguments-to-lisp2
   (inc-pointer arguments ;; index 0 is for the return value
                (foreign-type-size :pointer))
   types ()))


(defun get-type (smoke-type)
  "Returns the QMetaType ID for SMOKE-TYPE."
  (typecase smoke-type
    (smoke-standard-object
     (if (pointer-p smoke-type)
         (error "Not implemented: pointer type.") ;;qmetatype.+voidstar+
         (let ((type (qt:meta-type.type (name smoke-type))))
           (assert (/= 0 type)
                   (type)
                   "The type ~S has no QMetaType."
                   (name smoke-type))
           type)))
    (t
     *cxx-lisp-object-metatype*)))
     

(defun types (smoke-types)
  "Returns a newly allocated array of QMetaType IDs of SMOKE-TYPES."
  ;; FIXME free TYPES on error.
  (let ((types (cffi:foreign-alloc :int :count (1+ (length smoke-types))))
        (index 0))
    (dolist (type smoke-types)
      (setf (cffi:mem-aref types :int index)
            (get-type type))
      (incf index))
    (setf (cffi:mem-aref types :int index)
          0)
    types))