;;; Copyright (C) 2009, 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module. An independent module is a module which is not derived from or
;;; based on this library. If you modify this library, you may extend this
;;; exception to your version of the library, but you are not obligated to
;;; do so. If you do not wish to do so, delete this exception statement
;;; from your version.

(in-package #:smoke)

(declaim (inline call-s-method))
(defun call-s-method (method object-pointer stack-pointer)
  (foreign-funcall-pointer 
   (foreign-slot-value (smoke-class-pointer (get-class method))
                       'smoke-class 'class-function)
   ()
   smoke-index (foreign-slot-value (smoke-method-pointer method)
                                   'smoke-method 'method)
   :pointer object-pointer
   smoke-stack stack-pointer
   :void))

(defun s-call (method object-pointer &optional (args nil))
  (with-stack (stack args (arguments method) )
    (call-s-method method object-pointer (call-stack-pointer stack))
    (type-to-lisp (call-stack-pointer stack) (return-type method))))

(defun pointer-call (method object-pointer &optional (args nil))
  (with-stack (stack args (arguments method) )
    (call-s-method method object-pointer (call-stack-pointer stack))
    (foreign-slot-value (call-stack-pointer stack) 'smoke-stack-item 'class)))

(defun smoke-call (class pointer method-name &optional (args nil))
  (s-call (make-smoke-method-from-name class method-name) pointer args))

(defun enum-call (method)
  "Return the enum value for METHOD."
  ;; FIXME:
  ;;
  ;; we could use static call, but QGraphicsEllipseItem::Type has
  ;; wrongly QGraphicsGridLayout as return type. Smoke ignores case
  ;; and confuses it with the member function type() ??  (27.2.09)
  ;; 
  (assert (enum-p method))
  (with-stack (stack nil nil)
    (call-s-method method (null-pointer) (call-stack-pointer stack))
    (foreign-slot-value (call-stack-pointer stack) 'smoke-stack-item 'long)))

(defun delete-pointer (pointer class)
  "Destructs the object at POINTER of type CLASS.
Calls the destructor and frees the memory."
  (declare (optimize (speed 3)))
  (let ((method-name (concatenate 'string "~" (constructor-name class))))
    (s-call (make-smoke-method-from-name class method-name) pointer)))

(defun delete-object (object)
  (delete-pointer (pointer object) (class-of object))
  (setf (slot-value object 'pointer) (null-pointer)))

(eval-startup (:load-toplevel :execute)
  (defparameter *binding* (smoke-construct-binding
                     (callback destructed)
                     (callback dispatch-method)))
  (defparameter *no-dispatch-binding* (smoke-construct-binding
                                 (callback destructed)
                                 (null-pointer))))

(defun set-binding (object)
  "Sets the Smoke binding for OBJECT, that receives its callbacks."
  (declare (optimize (speed 3)))
  (let ((class (class-of object)))
    (with-foreign-object (stack 'smoke-stack-item 2)
      (setf (foreign-slot-value (mem-aref stack 'smoke-stack-item 1)
                                'smoke-stack-item 'voidp)
            (if (typep class 'cxx:class)
                *binding*
                *no-dispatch-binding*))
      (foreign-funcall-pointer 
       (foreign-slot-value (smoke-class-pointer class)
                           'smoke-class 'class-function)
       ()
       smoke-index 0 ;; set binding method index
       :pointer (pointer object)
       smoke-stack stack
       :void))))

(defun init (smoke module)
  "Returns the a new Smoke binding for the Smoke module SMOKE."
  (use-foreign-library libclsmoke)
  (setf (smoke-module-pointer module) smoke)
  (init-smoke-module module)
  (setf (gethash (pointer-address smoke) *smoke-modules*) module)
  module)

(let ((pointer-symbol-map (make-hash-table)))
  ;; Used by make-load-form for enums to reference the smoke module.
  (defun register-smoke-module-var (symbol)
    "Registers SYMBOL of a variable containing a pointer to a Smoke module."
    (setf (gethash (pointer-address (smoke-module-pointer (eval symbol)))
                   pointer-symbol-map)
          symbol))
  (defun get-smoke-variable-for-pointer (pointer)
    "Returns the SYMBOL of the variable whose value is POINTER."
    (gethash (pointer-address pointer) pointer-symbol-map)))
  
(defun call (object method-name &rest args)
  (smoke-call (class-of object) (pointer object)
              method-name args))

(defmethod documentation ((class smoke-standard-class) (doc-type (eql 't)))
  (declare (optimize (speed 3)))
  (format nil "~@[~A~%~]C++ name: ~A" (call-next-method) (name class)))

(defmethod documentation ((gf smoke-gf) (doc-type (eql 't)))
  (declare (optimize (speed 3)))
  (let ((methods (all-methods (name gf))))
    (format nil "~@[~A~%~]~{~T~A~%~}"
            (call-next-method)
            (sort (mapcar #'method-declaration methods) #'string<=))))

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

(defun all-methods (name)
  "Returns a list of all methods named NAME."
  (declare (optimize (speed 3)))
  (with-foreign-string (name name)
  (let ((methods))
    (maphash
     #'(lambda (address module)
         (declare (ignore address))
         (map-methods #'(lambda (method)
                          (when (and (cstring= name (smoke-method-name method))
                                     (not (enum-p method)))
                            (push (make-smoke-method
                                   :id (smoke-method-id method)
                                   :smoke (smoke-method-smoke method))
                                  methods)))
                      module))
     *smoke-modules*)
    methods)))

(defun fgrep-methods (smoke str)
  (map-methods #'(lambda (method)
                   (when (search str (name method))
                     (princ (method-declaration method))
                     (terpri)))
               smoke))

(defmacro define-smoke-module (package library 
                               (variable variable-name)
                               (init-function function-name))
  "Define a Smoke module."
  (let ((smoke-module (intern "*SMOKE-MODULE*")))
    `(progn
       (eval-when (:compile-toplevel :load-toplevel :execute)
         (define-foreign-library ,library
           (:darwin ,(format nil "~(~A~).3.dylib" library))
           (:unix ,(format nil "~(~A~).so.3" library))
           (t (:default ,(format nil "~(~A~)" library)))))
       (eval-startup (:compile-toplevel :execute)
         (load-foreign-library ',library))

       (eval-startup (:compile-toplevel :execute)
         (defcvar (,variable ,variable-name :read-only t :library ,library)
             :pointer)
         (defcfun (,init-function ,function-name :library ,library)
             :void))
       (eval-when (:compile-toplevel :load-toplevel :execute)
         (defparameter ,smoke-module (make-smoke-module)))
       (eval-startup (:compile-toplevel :execute)
         (,init-function)
         (init ,variable ,smoke-module)
         (register-smoke-module-var ',smoke-module))
       (define-classes-and-gfs ,package ,smoke-module))))
         
(defun fgrep-classes (smoke str)
  (map-classes #'(lambda (class)
                   (when (search str (name class))
                     (format t "~A~%" (name class))))
               smoke))

(defmacro define-takes-ownership (method lambda-list object)
  "Declares METHOD transfers the ownership of OBJECT to the
first argument of LAMBDA-LIST."
  `(defmethod ,method :before ,lambda-list
     (declare (ignorable ,@(loop for arg in (rest lambda-list) collect
                                (if (consp arg)
                                    (first arg)
                                    arg))))
     (transfer-ownership-to ,object ,(if (consp (first lambda-list))
                                         (first (first lambda-list))
                                         (first lambda-list)))))