Sun Aug 2 13:15:21 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Support ownership transfer to non smoke wrapped QObjects & cleanup C++ to Lisp translation.

--- old-qt.gui/src/object.lisp 2014-10-30 07:44:40.000000000 +0100

+++ new-qt.gui/src/object.lisp 2014-10-30 07:44:40.000000000 +0100

@@ -1,6 +1,17 @@

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

-(smoke:eval-startup (:load-toplevel :compile-toplevel :execute)

+;; Smoke always calls the method of the class the object is assumed to

+;; be and not the most specific method like required for virtual

+;; methods. Thus we implement a virtual metaObject() method to

+;; determine the actual class. This is only needed for objects not

+;; constructed by Smoke, since otherwise we would know the most

+;; specific class.

+(defcfun qt-smoke-meta-object :pointer (object :pointer))

+(defun meta-object (object)

+ (make-instance 'qt:meta-object

+ :pointer (qt-smoke-meta-object (pointer object))))

+

+(eval-startup (:load-toplevel :compile-toplevel :execute)

(let ((object (make-instance 'qt:object)))

(defmethod cxx:static-meta-object ((class (eql (find-class 'qt:object))))

"No OBJECT.STATIC-META-OBJECT (r558420)."

@@ -57,22 +68,47 @@

(meta-object-slots (cxx:static-meta-object class) :all all))

(defun parent-p (object)

- (not (null-pointer-p (smoke::pointer-call (smoke::make-smoke-method-from-name (find-class 'qt:object)

- "parent")

- (smoke::pointer object)))))

-

-(defun find-smoke-parent (object)

- "Returns the first parent of OBJECT or OBJECT that is a Smoke class.

- (the destructed callback is called when the object is freed.)"

- ;; FIXME allow usage of non smoke objects by connecting to the

- ;; destroyed() signal.

+ (not (null-pointer-p (smoke::pointer-call

+ (smoke::make-smoke-method-from-name

+ (find-class 'qt:object)

+ "parent")

+ (smoke::pointer object)))))

+

+

+;; FIXME this might not be that smart.

+(eval-startup ()

+ (defparameter *destroyed-slot* (qt:make-slot

+ #'(lambda (object)

+ (foreign-funcall-pointer

+ (get-callback 'smoke::destructed)

+ () :pointer (smoke:pointer object))))))

+

+(defun ensure-smoke-parent (object)

(declare (optimize (speed 3)))

(let ((parent (cxx:parent object)))

- (if (not (null-pointer-p (smoke::pointer parent)))

- (if (smoke::has-pointer-p (smoke::pointer parent))

- parent

- (find-smoke-parent parent))

- (error "No smoke parent found for ~A." object))))

+ (assert (not (null-pointer-p (smoke:pointer parent)))

+ ()

+ "The object ~A has not parent." object)

+ (unless (smoke::has-pointer-p (smoke:pointer parent))

+ ;; Before we ADD-OBJECT PARENT it must know its real class to

+ ;; prevent a clash when the same pointer is returned by a

+ ;; function with a more specific type.

+ (change-class parent

+ ;; Note: there can be classes that are not known

+ ;; to Smoke, like KDE's OxygenStyle that might

+ ;; be seen by the event-notify callback. But

+ ;; it's probably save to assume the user will

+ ;; never use those.

+ (let ((class-name (cxx:class-name (meta-object parent))))

+ (smoke::lispify class-name (ecase (char class-name 0)

+ (#\Q :qt)

+ (#\K :kde)))))

+ (smoke::add-object parent)

+ (qt:connect (qt:get-signal parent "destroyed(QObject*)")

+ *destroyed-slot* qt:+direct-connection+)

+ (tg:cancel-finalization parent)

+ (smoke::transfer-ownership-to parent (ensure-smoke-parent parent)))

+ parent))

(defmethod initialize-instance :after ((object qt:object)

&key (pointer nil pointer-p) &allow-other-keys)

@@ -86,19 +122,19 @@

(not (null-pointer-p (smoke::pointer object)))

(parent-p object))

(smoke::transfer-ownership-to object

- (find-smoke-parent object))))

+ (ensure-smoke-parent object))))

(define-condition wrapper-gc (storage-condition)

- ((class-name :initarg :class-name

- :documentation "The class name of the gc'ed object.")

+ ((object-class :initarg :object-class

+ :documentation "The class of the gc'ed object.")

(pointer :initarg :pointer))

(:report (lambda (condition stream)

- (format stream "The object ~A ~A of type cxx:class

-has a parent but got garbage collected."

- (slot-value condition 'class-name)

- (slot-value condition 'pointer)))))

+ (format stream "The object ~A ~A of type cxx:class

+has the parent but got garbage collected."

+ (slot-value condition 'object-class)

+ (slot-value condition 'pointer)))))

-(smoke:eval-startup (:compile-toplevel :execute)

+(eval-startup (:compile-toplevel :execute)

(defparameter *get-parent*

(smoke::make-smoke-method-from-name (find-class 'qt:object) "parent"))

@@ -121,7 +157,7 @@

(if (null-pointer-p (smoke::pointer-call *get-parent* pointer))

(smoke::pointer-call *delete-later* pointer)

(error (make-condition 'wrapper-gc

- :class-name (name class)

+ :object-class class

:pointer pointer)))

(error (condition)

(smoke::report-finalize-error condition "qt:object wrap"

@@ -169,7 +205,7 @@

(tg:cancel-finalization (cxx:child child-event))

(when (smoke::has-pointer-p (smoke::pointer (cxx:child child-event)))

(unless receiver

- (setf receiver (find-smoke-parent (cxx:child child-event))))

+ (setf receiver (ensure-smoke-parent (cxx:child child-event))))

(smoke::transfer-ownership-to (cxx:child child-event) receiver))))

(qt:event.+child-removed+

(let* ((child-event (make-instance 'qt:child-event

@@ -190,7 +226,16 @@

(defun register-event-notify ()

(let ((ret (qt-smoke-register-event-notify (cffi:callback event-notify))))

(unless ret

- (error "The Qt event-notify callback table is full."))))

+ (error "Registering event-notify callback failed."))))

+

+(defun check-child-parent-ownership ()

+ (loop for parent being the hash-values of smoke::*object-map* do

+ (loop for child in (smoke::owned-objects parent) do

+ (when (typep child 'qt:object)

+ (assert (eql (cxx:parent child) parent)

+ (child parent)

+ "cl-smoke thinks ~A has the parent ~A, but ~A is its parent."

+ child parent (cxx:parent child))))))

-(smoke:eval-startup ()

+(eval-startup ()

(register-event-notify))