Sun Jun 21 11:29:25 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* *SMOKE-MODULE* must be passed instead of *QT-SMOKE*.

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

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

@@ -55,15 +55,16 @@

(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 (find-class 'qt: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.)"

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

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

;; destroyed() signal.

+ (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))

@@ -75,6 +76,7 @@

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

"Registers the object to the parent when a parent was set in the constructor

and the objects metaclass is SMOKE-WRAPPER-CLASS."

+ (declare (optimize (speed 3)))

(when (and (not pointer-p)

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

(error "Object ~A has not been constructed" object))

@@ -96,46 +98,40 @@

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

(defparameter *get-parent*

- (smoke::make-smoke-method (smoke::make-smoke-class

- *qt-smoke*

- "QObject")

- "parent"))

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

;; FIXME this leaks memory when QCoreApplication::exec is never called,

;; beause then, deleteLater has no effect.

(defparameter *delete-later*

- (smoke::make-smoke-method (smoke::make-smoke-class

- *qt-smoke*

- "QObject")

- "deleteLater")))

-(defun print-object-to-string (object)

- (with-output-to-string (stream)

- (print-object object stream)))

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

(defmethod smoke::make-finalize ((object qt:object))

- "Delete the qt:object OBJECT,

+ "Delete the qt:object OBJECT,

by calling cxx:delete-later iff it has no parent."

- (let ((pointer (pointer object))

- (class (class-of object))

- (next (call-next-method)))

- (if (typep (class-of object) 'cxx:class)

- #'(lambda ()

- (handler-case

- (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)

- :pointer pointer)))

- (error (condition)

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

- (name class) pointer))))

- #'(lambda ()

- (handler-case

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

+ (let ((pointer (pointer object))

+ (class (class-of object))

+ (next (call-next-method)))

+ (declare (function next))

+ (if (typep (class-of object) 'cxx:class)

+ #'(lambda ()

+ (declare (optimize (speed 3)))

+ (handler-case

+ (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)

+ :pointer pointer)))

+ (error (condition)

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

+ (name class) pointer))))

+ #'(lambda ()

+ (declare (optimize (speed 3)))

+ (handler-case

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

(funcall next)

(cerror "Ignore" "Finalizer for object with a parent called."))

- (error (condition)

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

- (name class) pointer)))))))

+ (error (condition)

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

+ (name class) pointer)))))))

;;;

@@ -188,7 +184,7 @@

(defun register-event-notify ()

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

(unless ret

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

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

(smoke:eval-startup ()

(register-event-notify))