;;; C++ overload resolution
;;; See: http://www.open-std.org/jtc1/sc22/wg21/docs/papers/2008/n2800.pdf
;;;
;;; We handle only the most common cases. Stuff like virtual inheritance
;;; that is not needed is not implemented.

(in-package :smoke)

(declaim (inline cmp))
(defun cmp (a b)
  (- a b))

(declaim (inline strcmp))
(defcfun strcmp :int (s1 :pointer) (s2 :pointer))

(declaim (inline cstring/=))
(defun cstring/= (string1 string2)
  "Returns T when the C strings STRING1 and STRING2 are not equal
 and NIL otherwise."
  (not (zerop (strcmp string1 string2))))

(defun method-cmp (method class-id name)
  "Compares METHOD to the method with NAME of class CLASS-ID."
  (declare (foreign-pointer name)
           (type (smoke-index 0) class-id)
           (smoke-method method)
           (optimize (speed 3) (debug 0) (safety 0)))
  (let ((id-cmp (cmp (the (smoke-index 0) (method-slot-value method 'class))
                     (the (smoke-index 0) class-id))))
    (declare (type smoke-index id-cmp))
    (if (/= 0 id-cmp)
        id-cmp
        (strcmp (smoke-method-name method)
                     name))))
             
(declaim (inline first-unabigious-index))
(defun first-unabigious-index (smoke index)
  (declare (type smoke-index index)
           (optimize (speed 3)))
  (if (>= index 0)
      index
      (mem-aref (smoke-module-ambiguous-method-list smoke)
                'smoke-index
                (- index))))

(defun find-method-for-class (name class)
  "Returns the index of a method with name NAME for class CLASS."
  (declare (type foreign-pointer name)
           (type smoke-class class)
           (optimize (speed 3)))
  (let* ((start 1) ;; 0 is "no method"
         (class-id (id class))
         (smoke (smoke class))
         (end (1+ (smoke-array-length (smoke-module-method-maps smoke)))))
    (declare (type (smoke-index 0) start end)
             (dynamic-extent start))
    (loop until (> start end) do
         (let* ((index (the smoke-index (floor (+ end start) 2)))
                (method (make-smoke-method 
                         :smoke smoke 
                         :id (the (smoke-index 0)
                               (first-unabigious-index
                                smoke
                                (foreign-slot-value
                                 (mem-aref (smoke-array-pointer
                                            (smoke-module-method-maps
                                             smoke))
                                           'smoke-method-map index)
                                 'smoke-method-map
                                 'method)))))
                (cmp (the smoke-index (method-cmp method class-id name))))
           (declare (type smoke-index cmp)
                    (dynamic-extent method))
           (if (< cmp 0)
               (setf start (1+ index))
               (if (> cmp 0)
                   (setf end (1- index))
                   (return-from find-method-for-class index))))))
  -1)

(defmacro push-candidate-method (index name argument-count class methods
                                 const-p)
  (with-gensyms (method-map method-index method ambig-index i smoke)
    `(let* ((,smoke (smoke ,class))
            (,method-map (mem-aref
                          (smoke-array-pointer
                           (smoke-module-method-maps ,smoke))
                          'smoke-method-map
                          (the smoke-index ,index)))
            (,method-index (foreign-slot-value ,method-map 'smoke-method-map 'method))
            (,method (make-smoke-method
                      :smoke ,smoke
                      :id (first-unabigious-index
                           ,smoke
                           ,method-index))))
       (declare (type smoke-index ,method-index))
       (if (cstring/= ,name
                      (smoke-method-name ,method))
           nil
           (progn
             (when (= (the smoke-index ,argument-count)
                      (the smoke-index (get-arguments-length ,method)))
               (if (< ,method-index 0)
                   (let ((,ambig-index (- ,method-index)))
                     (declare (type smoke-index ,ambig-index))
                     (loop as ,i = (the smoke-index
                                     (mem-aref (smoke-module-ambiguous-method-list
                                                ,smoke)
                                               'smoke-index
                                               ,ambig-index))
                        while (> (the smoke-index ,i) 0) do
                          (incf ,ambig-index)
                          (let ((,method (make-smoke-method :smoke ,smoke
                                                            :id ,i)))
                            (unless (and ,const-p (not (const-p ,method)))
                              (push ,method ,methods)))))
                   (unless (and ,const-p (not (const-p ,method)))
                     (push ,method ,methods))))
             t)))))

(defun viable-functions (name argument-count class &optional const-p)
  (declare (optimize (speed 3)))
  (with-foreign-string (name name)
    (let ((methods))
      (let ((smoke (smoke class)))
        (let ((start-index (find-method-for-class name class)))
          (declare (type smoke-index start-index))
          (when (>= start-index 0)
            (loop for index from start-index downto 1
               while (push-candidate-method index name argument-count class
                                            methods const-p))
            (loop for index from (1+ start-index)
               to (the smoke-index (smoke-array-length
                                    (smoke-module-method-maps smoke)))
               while (push-candidate-method index name argument-count class
                                            methods const-p)))))
      methods)))
         
(declaim (inline make-conversion make-exact-match make-promotion
                 make-number-conversion make-pointer-conversion
                 make-boolean-conversion make-user-conversion))
(defstruct conversion
  (function-name nil :type (or symbol list function) :read-only t)
  (rank -1 :type fixnum :read-only t))

(defstruct (exact-match (:include conversion (rank 0))))

(defstruct (promotion (:include conversion (rank 1))))

(defstruct (number-conversion (:include conversion (rank 2))))

(defstruct (pointer-conversion (:include conversion (rank 3)))
   (from (find-class t) :type class :read-only t)
   (to (find-class t) :type class :read-only t))

(defstruct (boolean-conversion (:include conversion (rank 4))))

(defstruct (user-conversion (:include conversion (rank 5))))

(defgeneric conversion<= (conversion1 conversion2)
  ;; 13.3.3.2 Ranking implicit conversion sequences
  ;; 4
  (:method (conversion1 conversion2)
    (declare (optimize (speed 3)))
    (and (not (null conversion1))
         (or (null conversion2)
             (<= (the fixnum (conversion-rank conversion1))
                 (the fixnum (conversion-rank conversion2))))))
  (:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion))
    (declare (optimize (speed 3)))
    (if (eq (pointer-conversion-from conversion1)
            (pointer-conversion-from conversion2))
        ;; A->B < A->C <=> B subclass of C
        (subtypep (pointer-conversion-to conversion1)
                  (pointer-conversion-to conversion2))
        (if (eq (pointer-conversion-to conversion1)
                (pointer-conversion-to conversion2))
            ;; B->A < C->A <=> B subclass of C
            (subtypep (pointer-conversion-from conversion1)
                      (pointer-conversion-from conversion2))
            nil))))

(defgeneric conversion= (conversion1 conversion2)
  (:method (conversion1 conversion2)
    (and (conversion<= conversion1 conversion2)
         (conversion<= conversion2 conversion1)))
  (:method ((conversion1 (eql nil)) (conversion2 (eql nil)))
    t))

(defun max-conversion (conversion1 conversion2)
  "Returns the greater conversion of CONVERSION1 and CONVERSION2."
  (if (null conversion2)
      conversion1
      (if (conversion<= conversion1 conversion2)
          conversion2
          conversion1)))

(defmacro make-match (type &optional (name ''identity) (argument nil)
                      &rest args)
  (flet ((conversion-function (name &optional arg)
           (if arg
               `(if (using-typep)
                    `(,,name
                      ,(if (typep ,arg 'class)
                           `(find-class ',(class-name ,arg))
                           `(find-smoke-method (find-class ,(class-name
                                                             (find-smoke-class
                                                              (get-class ,arg))))
                                               ,(name ,arg))))
                    #'(lambda (object)
                        (funcall (fdefinition ,name)
                                 object ,arg)))
               `(if (using-typep)
                    ,name
                    (fdefinition ,name)))))
    `(,(symbolicate  'make- (eval type))
       :function-name ,(conversion-function name argument)
       ,@args)))
      
(defun+using-type get-conversion-sequence object (object type &optional user)
  "Retrains a conversion sequence to convert a instance of type CLASS
to an instance of type TYPE. When USER is true user conversions are considered."
  (if-let (match (call-using-type exact-match object type))
    (if (eql t match)
        (make-match 'exact-match)
        (make-match 'exact-match match))
    (or (call-using-type promotion object type)
        (call-using-type conversion object type)
        (and user
             (call-using-type user-conversion object type)))))

(defun+using-types standard-conversion-sequence (method classes &optional user)
  "Returns the conversion sequences to convert the arguments of types CLASSES
to the types required by METHOD."
  (if (null classes)
      (values (make-match 'exact-match) nil)
      (let ((max-rank)
            (conversions))
        (loop for type in (arguments method)
           for class in classes do
             (let ((rank (call-using-type get-conversion-sequence class type user)))
               (when (null rank)
                 (setf max-rank nil)
                 (return nil))
               (setf max-rank (max-conversion rank max-rank))
               (push (conversion-function-name rank) conversions)))
        (values max-rank (reverse conversions)))))

(defun+using-types conversion-sequence (method classes)
  (call-using-types standard-conversion-sequence method classes t))

(defun+using-types find-best-viable-function (name arguments class
                                                   &optional const-p)
  "Returns the method named NAME of class CLASS that can be called
using arguments of types TYPES with the lowest conversion sequence."
  (call-using-types find-best-viable-function2
                    (function-using-types conversion-sequence)
                    name arguments class const-p))

(defun+using-types find-best-viable-function2 (get-sequence name objects class
                                   &optional const-p)
  (when (and (using-typep)
             (not (typep class 'smoke-standard-class)))
    (throw 'unspecific-type class))
  (let ((viable-functions (viable-functions name (length objects)
                                            class const-p))
        (best-rank)
        (best-method)
        (conversions))
    (if (null viable-functions)
        (dolist (class (closer-mop:class-direct-superclasses class)
                 (values best-method nil))
          (when (typep class 'smoke-standard-class)
            (multiple-value-bind (method conversions)
                (call-using-types find-best-viable-function2 get-sequence name objects class const-p)
              (when method
                (return (values method conversions))))))
        (loop for method in viable-functions
             finally (return (values best-method conversions)) do
             (block next
               (multiple-value-bind (rank method-conversions)
                   (funcall get-sequence method objects)
                 (when (and rank (conversion<= rank best-rank))
                   (when (conversion= rank best-rank)
                     ;; FIXME catch all ambigious overloads
                     (if const-p
                         (error "Ambigious overload ~A." method)
                         (when (const-p method)
                           ;; assume that the previous method is a non
                           ;; const one and thus more specific.
                           (return-from next))))
                   (setf best-rank rank)
                   (setf best-method method)
                   (setf conversions method-conversions)
                   (when (and (conversion= rank (make-match 'exact-match))
                              (not (xor const-p (const-p method))))
                     (return (values method conversions))))))))))

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

(defmacro define-from-lisp-translation (type-names lisp-type
                                        &optional
                                        (conversion-function-name 'identity))
  "Defines a translation from LISP-TYPE to the C++ types TYPE-NAMES using
the function CONVERSION-FUNCTION-NAME."
  `(progn ,@(loop for type-name in (ensure-list type-names)
               collect `(setf (gethash ,type-name *from-lisp-translations*)
                              #'(lambda (type type-p)
                                  (and (if type-p
                                           (multiple-value-bind (value valid-p)
                                               (subtypep type ',lisp-type)
                                             (unless valid-p
                                               (throw 'unspecific-type type))
                                             value)
                                           (typep type ',lisp-type))
                                       ',conversion-function-name))))))

(define-from-lisp-translation ("void*" "const void*" "void**" "const void**")
    foreign-pointer)

;; FIXME grovel this?
(deftype c-integer (ctype)
  (let ((bits (* 8 (foreign-type-size ctype))))
    (if (starts-with-subseq
         (symbol-name :unsigned)
         (symbol-name ctype))
        `(unsigned-byte ,bits)
        `(signed-byte ,bits))))
               
               
(defun+using-type exact-match object  (object type)
  "Test for an exact match."
  (case (type-id type)
    (0 (when-let (test (gethash (name type) *from-lisp-translations*))
         (funcall test object (using-typep))))
    (1 (object.typep 'boolean))
    (2 (object.typep 'standard-char))
    (3 (object.typep '(c-integer :unsigned-char)))
    (4 (object.typep '(c-integer :short)))
    (5 (object.typep '(c-integer :unsigned-short)))
    (6 (object.typep '(c-integer :int)))
    (7 (object.typep '(c-integer :unsigned-int)))
    (8 (object.typep '(and (c-integer :long)
                       (not (c-integer :int)))))
    (9 (object.typep '(and (c-integer :unsigned-long)
                       (not (c-integer :unsigned-int)))))
    (10 (object.typep 'single-float))
    (11 (object.typep 'double-float))
    (12 (when (object.typep 'enum)
          (when (using-typep)
            (throw 'unspecific-type object))
          (smoke-type= type (enum-type object))))
    (13 (and (object.typep 'smoke-standard-object)
             (smoke-type= (get-class type) (object.type-of))))))


(defun make-cleanup-pointer (pointer cleanup-function)
  "Returns a pointer that calls CLEANUP-FUNCTION with pointer as argument
when it is finalized."
  (let ((address (pointer-address pointer)))
    (tg:finalize pointer #'(lambda ()
                             (funcall cleanup-function
                                      (make-pointer address))))))

(defun make-auto-pointer (pointer)
  "Returns a pointer that frees the memory at POINTER when it is finalized."
  (make-cleanup-pointer pointer #'foreign-free))

(defun coerce-c-string (string)
  (make-auto-pointer (foreign-string-alloc string)))

(defun coerce-from-enum (enum)
  (cxx-support:value enum))

(defun coerce-double-float (number)
  (float number 0d0))

(defun coerce-single-float (number)
  (float number 0f0))

(defun coerce-to-enum (number)
  ;; we can skip the enum type because it is not checked at this
  ;; point.
  (make-instance 'enum :value number))

;; FIXME incomplete
(defun+using-type promotion object (object type)
  (declare (smoke-type type))
  (case (type-id type)
    (0 (when (and (string= (name type) "const char*")
                  (object.typep 'string))
         (make-match 'promotion 'coerce-c-string)))
    (6 (when (object.typep 'enum)
         (make-match 'promotion 'coerce-from-enum)))
    (7 (when (object.typep 'enum)
         (make-match 'promotion 'coerce-from-enum)))
    (10 (when (object.typep 'real)
          (make-match 'promotion 'coerce-single-float)))
    (11 (when (object.typep 'real)
          (make-match 'promotion 'coerce-double-float)))
    (12 (when (object.typep '(integer 0))
          (make-match 'promotion 'coerce-to-enum)))))
       
(declaim (inline coerce-to-class))
(defun coerce-cast (object to-class)
  (cast object to-class))

(defun coerce-to-void (object)
  object)

(defun+using-type conversion-cast object (object type)
  (when (and (class-p type)
             (object.typep 'smoke-standard-object)
             (derived-p (object.type-of) (get-class type))
             (find-smoke-class (get-class type)))
    (make-match 'pointer-conversion
                'coerce-cast 
                (find-smoke-class (get-class type))
                :from (object.type-of)
                :to (find-smoke-class (get-class type)))))

(defun+using-type conversion-void object (object type)
  (when (and (string= (name type) "void*")
             (object.typep 'smoke-standard-object))
    (make-match 'pointer-conversion
                'coerce-void
                nil
                :from (object.type-of)
                :to (find-class 't))))

(defun+using-type conversion-pointer object (object type)
  ;; Not using pointer-p to allow passing a raw pointer for objects on
  ;; the stack and references.
  ;; (e.g.: for qInstallMsgHandler(QtMsgHandler) )
  ;;
  ;; FIXME this breaks passing pointers to references.
  ;; 
  ;; e.g.: calling the function foo(QByteArray& foo) with
  ;;   (foo pointer) assumes pointer to point to a QByteArray, but
  ;;   actually the conversion sequence QByteArray(pointer) should be
  ;;   used.  When pointer is a null pointer it fails horribly!.
  ;;
  ;; But it is needed for passing the int pointer in QApplication(int&, char**).
  (when (and (or (= 0 (type-id type)) ; voidp
                 (= 13 (type-id type))) ; class
             (object.typep 'foreign-pointer))
    (make-match 'pointer-conversion 'identity nil
                :from (find-class 't)
                :to (find-class 't)))) ;; FIXME get the class when applicable
                

(defun+using-type conversion object (object type)
  (or (call-using-type conversion-cast object type)
      (call-using-type conversion-void object type)
      (call-using-type conversion-pointer object type)))

(defun+using-type user-conversion object (object type)
  (or (call-using-type operator-conversion object type)
      (call-using-type constructor-conversion object type)))

(defun conversion-operator-name (to-type)
  (concatenate 'string
               "operator "
               (if (class-p to-type)
                   (name (get-class to-type))
                   (name to-type))))

(defun coerce-to-type (object method)
  (pointer-call method (pointer object)))
      
(defun+using-type operator-conversion object (object type)
  (when (object.typep 'smoke-standard-object)
    (let ((method (find-smoke-method (object.type-of)
                                     (conversion-operator-name type))))
      (when (valid-p method)
        (if (pointer-p type)
            (make-match 'user-conversion
                        'coerce-to-type
                        method)
            (make-match 'user-conversion
                        (lispify (name method) :cxx)))))))

(declaim (inline coerce-to-class))
(defun coerce-to-class (object to-class)
  (make-instance to-class
                 :args (list object)))

(defun+using-type constructor-conversion object (object type)
  (when (class-p type)
    (handler-case
        (let ((to-class (find-smoke-class (get-class type) nil)))
          (when (and to-class
                     (call-using-types find-best-viable-function2
                                       (if (using-typep)
                                           #'standard-conversion-sequence-using-types
                                           #'standard-conversion-sequence)
                                       (constructor-name (get-class type))
                                       (list object) to-class))
            (make-match 'user-conversion
                        'coerce-to-class
                        to-class)))
      ;; When the correspoinding Lisp module is not loaded, we ignore
      ;; the overload.
      (lisp-module-not-loaded ()))))

(defun call-sequence (method object sequence &rest args)
  (s-call method object
          (mapcar #'(lambda (conversion argument)
                      (funcall conversion argument))
                  sequence args)))

(defun format-no-applicable-cxx-method (stream name class arguments)
  (format stream
          "No applicable method ~S of ~A for ~S.
Candidates are:~{~T~A~%~}."
          name class arguments
          (mapcar #'signature
                  (viable-functions name
                                    (length arguments)
                                    (smoke-class-of class)))))

(define-condition no-applicable-cxx-method (error)
  ((method :initarg :method :reader condition-method)
   (class :initarg :class :reader condition-class)
   (arguments :initarg :arguments :reader condition-arguments))
  (:report (lambda (condition stream)
             (format-no-applicable-cxx-method stream
                                              (condition-method condition)
                                              (condition-class condition)
                                              (condition-arguments condition)))))

(defun call-using-args (object-or-class name arguments)
  "Calls the method NAME of OBJECT-OR-CLASS with ARGUMENTS."
  (declare (optimize (speed 3))
           (type (or smoke-standard-class smoke-standard-object)
                 object-or-class))
  (multiple-value-bind (method sequence)
      (#-sbcl find-best-viable-function
       #+sbcl find-best-viable-function-cached
              name
              arguments
              (smoke-class-of object-or-class)
              (when (typep object-or-class
                           'smoke-standard-object)
                (const-p object-or-class)))
    (when (null method)
      (error (make-condition 'no-applicable-cxx-method
                             :method name
                             :class object-or-class
                             :arguments arguments)))
    (apply #'call-sequence method
           (if (static-p method)
               (null-pointer)
               (cast object-or-class (get-class method)))
           sequence arguments)))

(defmethod slot-missing (meta-class (class smoke-standard-class) slot-name operation &optional new-value)
  (let ((method (find-smoke-method class (lisp-to-cxx (string slot-name)))))
    (if (or (not (valid-p method)) (not (static-p method)))
        (call-next-method)
        (ecase operation
          (setf 
           (handler-case (funcall (fdefinition
                                   (intern
                                    (concatenate 'string "SET-"
                                                 (string-upcase
                                                  (string slot-name)))
                                    :cxx))
                                  class new-value)
             (undefined-function ()
               (error "The C++ attribute ~A of ~A is read only." slot-name class))
             (no-applicable-cxx-method (condition)
               (if (null (viable-functions (condition-method condition)
                                           (length (condition-arguments condition))
                                           (condition-class condition)))
                   (error "The C++ attribute ~A of ~A is read only." slot-name class)
                   (error condition)))))
          (slot-boundp t)
          (slot-makunbound (error "Can not unbind the C++ attribute ~A of ~A." slot-name class))
          (slot-value (s-call method (null-pointer)))))))

(defmethod slot-missing ((class smoke-standard-class) object slot-name operation &optional new-value)
  (let ((method (find-smoke-method class (lisp-to-cxx (string slot-name)))))
    (if (not (valid-p method))
        (call-next-method)
        (ecase operation
          (setf 
           (handler-case (funcall (fdefinition
                                   (intern
                                    (concatenate 'string "SET-"
                                                 (string-upcase
                                                 (string slot-name)))
                                    :cxx))
                                  object new-value)
             (undefined-function ()
               (error "The C++ attribute ~A of ~A is read only." slot-name object))
             (no-applicable-cxx-method (condition)
               (if (null (viable-functions (condition-method condition)
                                           (length (condition-arguments condition))
                                           (condition-class condition)))
                   (error "The C++ attribute ~A of ~A is read only." slot-name object)
                   (error condition)))))
          (slot-boundp t)
          (slot-makunbound (error "Can not unbind the C++ attribute ~A of ~A." slot-name object))
          (slot-value (s-call method (cast object (get-class method))))))))