(in-package #:smoke)

(declaim (inline %make-call-stack))
(defstruct (call-stack (:constructor %make-call-stack))
  (pointer (null-pointer) :type foreign-pointer)
  (top (null-pointer) :type foreign-pointer))

(defgeneric size (object))
(defmethod size ((stack call-stack))
  "Returns the size (number of arguments) of STACK."
  (/ (- (pointer-address (call-stack-top stack))
        (pointer-address (call-stack-pointer stack)))
     (foreign-type-size 'smoke-stack-item)))

(defun make-call-stack (smoke-stack)
  (declare (type foreign-pointer smoke-stack)
           (optimize (speed 3)))
  (%make-call-stack
   :pointer smoke-stack
   :top (inc-pointer smoke-stack #.(foreign-type-size 'smoke-stack-item))))

(defun push-stack (stack value type)
  (setf (foreign-slot-value (call-stack-top stack) 'smoke-stack-item type)
        value)
  (incf-pointer (call-stack-top stack) #.(foreign-type-size 'smoke-stack-item)))

(define-compiler-macro push-stack (&whole form stack value type)
  (if (constantp type)
      `(progn 
         (setf (foreign-slot-value (call-stack-top ,stack)
                                   'smoke-stack-item ,type)
               ,value)
         (incf-pointer (call-stack-top ,stack)
                       ,(foreign-type-size 'smoke-stack-item)))
      form))

(defclass smoke-standard-object ()
  ((pointer :reader pointer
            :type foreign-pointer
            :initarg :pointer
            :documentation "Pointer to the C++ object.")
   (const-p :reader const-p
            :initarg :const-p
            :initform nil
            :documentation "Returns true when the object is const and nil otherwise.")
   #+clisp (finalizer :type list :initform (list nil))
   ;; We can not have a global table of objects owned by C++,
   ;; since then they would be always reachable from Lisp and thus
   ;; cycles would never be garbage collected.
   (owned-objects :accessor owned-objects
                  :initform nil
                  :type list
                  :documentation "Objects owned by the C++ instance."))
  (:documentation "The standard superclass for Smoke classes."))
  
(defun push-smoke-stack (stack value type-id)
  (declare (type (smoke-index 0) type-id)
           (type call-stack stack)
           (optimize (speed 3)))
  (ecase type-id
    (0 (push-stack stack value 'voidp))
    (1 (push-stack stack value 'bool))
    (2 (push-stack stack (char-code value) 'char))
    (3 (push-stack stack value 'uchar))
    (4 (push-stack stack value 'short))
    (5 (push-stack stack value 'ushort))
    (6 (push-stack stack value 'int))
    (7 (push-stack stack value 'uint))
    (8 (push-stack stack value 'long))
    (9 (push-stack stack value 'ulong))
    (10 (push-stack stack value 'float))
    (11 (push-stack stack value 'double))
    (12 (push-stack stack (value value) 'enum-value))
    (13 (if (typep value 'smoke-standard-object)
            ;; FIXME call pointer in overload resolution
            (push-stack stack (pointer value) 'class)
            (push-stack stack value 'class)))))

(defun set-smoke-stack (stack args arguments)
  "Pushes the arguments ARGS onto the Smoke stack STACK."
  (when (null args)
    (assert (null arguments)
            ()
            "To few arguments supplied. Missing: ~A" arguments))
  (unless (null args)
    (assert (not (null arguments))
            ()
            "To many arguments supplied (Arguments ~A)." args)
    (if (typep (first arguments) 'smoke-type)
        (push-smoke-stack stack (first args) (type-id (first arguments)))
        (push-stack stack (first args) 'class)) ;; Used for :qt lisp-object
    (set-smoke-stack stack (rest args) (rest arguments))))

(defmacro with-stack ((stack args types) &body body)
  (let ((smoke-stack (gensym "STACK")))
    `(with-foreign-object (,smoke-stack 'smoke-stack-item (1+ (length ,args)))
       (let ((,stack (make-call-stack ,smoke-stack)))
                (set-smoke-stack ,stack ,args
                                 ,types)
                ,@body))))

(defvar *to-lisp-translations* (make-hash-table :test 'equal))

(defun enum-to-lisp (stack-item type)
  "Returns the Lisp representation for STACK-ITEM of the basic C type TYPE."
  (declare (optimize (speed 3)))
  (ecase (type-id type)
    (0 (if-let ((translation (gethash (name type) *to-lisp-translations*)))
         (let ((pointer (foreign-slot-value stack-item 'smoke-stack-item
                                            'voidp)))
           (prog1 (funcall (car translation) pointer)
             (when (stack-p type)
               (funcall (cdr translation) pointer))))
         (prog1 (foreign-slot-value stack-item 'smoke-stack-item 'voidp)
           (cerror "Return the pointer"
                   "Missing type translator to convert the type ~A to Lisp."
                   type))))
    (1 (foreign-slot-value stack-item 'smoke-stack-item 'bool))
    (2 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'char)))
    (3 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'uchar)))
    (4 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'short)))
    (5 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'ushort)))
    (6 (foreign-slot-value stack-item 'smoke-stack-item 'int))
    (7 (foreign-slot-value stack-item 'smoke-stack-item 'uint))
    (8 (foreign-slot-value stack-item 'smoke-stack-item 'long))
    (9 (foreign-slot-value stack-item 'smoke-stack-item 'ulong))
    (10 (foreign-slot-value stack-item 'smoke-stack-item 'float))
    (11 (foreign-slot-value stack-item 'smoke-stack-item 'double))
    (12 (make-instance 'enum
                       :value (foreign-slot-value stack-item 'smoke-stack-item
                                                  'enum-value)
                       :type type))))

(defgeneric instance-to-lisp (pointer class type)
  (declare (optimize (speed 3)))
  (:documentation "Returns a CLOS instance for POINTER."))

(defun object-to-lisp (object type)
  (declare (optimize (speed 3)))
  (let ((class (get-class type)))
    (if (has-pointer-p object)
        (if (derived-p (class-of (get-object object))
                       (get-class type))
            (get-object object)
            (progn
              (when (stack-p type)
                ;; The first member varible of a class can have the
                ;; same address as its object.
                ;; e.g.: QSharedData::ref
                (cerror "Remove the old object."
                        "The object at pointer ~A is ~A but should be a ~A."
                        object (get-object object) type)
                (remove-object object))
              (instance-to-lisp object (find-smoke-class class) type)))
        (instance-to-lisp object (find-smoke-class class) type))))



(defun class-to-lisp (stack-item type)
  "Returns the Lisp representation for STACK-ITEM of type C++ class."
  (object-to-lisp (foreign-slot-value stack-item 'smoke-stack-item
                                      'class)
                  type))

(defun type-to-lisp (stack-item type)
  "Returns the Lisp representation of STACK-ITEM"
  (declare (optimize (speed 3)))
  (cond
    ((void-p type) (values))
    ((class-p type) (class-to-lisp stack-item type))
    (t (enum-to-lisp stack-item type))))


(defun error-no-free (object)
  (error "Can not free object at ~A." object))

(defmacro define-to-lisp-translation (type-names &optional
                                      (conversion-function-name 'identity)
                                      (free-function-name 'error-no-free))
  `(progn ,@(loop for type-name in (ensure-list type-names)
               collect `(setf (gethash ,type-name *to-lisp-translations*)
                              (cons ',conversion-function-name
                                    ',free-function-name)))))

(defmacro define-pointer-typedef (type-names lisp-type)
  (declare (ignore lisp-type))
  `(progn 
     (define-to-lisp-translation ,type-names identity identity)))
     ;; not needed
     ;;(define-from-lisp-translation ,type-names ,lisp-type)))

(define-to-lisp-translation ("void*" "const void*" "void**"))

(define-to-lisp-translation ("char*" "const char*") foreign-string-to-lisp)