Sun May 31 19:33:32 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Rework QObject parent ownership transfer
diff -rN -u old-qt.gui/src/application.lisp new-qt.gui/src/application.lisp
--- old-qt.gui/src/application.lisp 2014-10-30 07:01:10.000000000 +0100
+++ new-qt.gui/src/application.lisp 2014-10-30 07:01:10.000000000 +0100
@@ -100,5 +100,9 @@
(invoke-restart (find-restart 'continue)))
:report-function
#'(lambda (stream)
- (format stream "Return from the application event loop."))))
+ (format stream "Return from the application event loop."))
+ :test-function
+ #'(lambda (condition)
+ (declare (ignore condition))
+ (find-restart 'continue))))
(cxx:exec (app)))))
diff -rN -u old-qt.gui/src/lisp-object.lisp new-qt.gui/src/lisp-object.lisp
--- old-qt.gui/src/lisp-object.lisp 2014-10-30 07:01:10.000000000 +0100
+++ new-qt.gui/src/lisp-object.lisp 2014-10-30 07:01:10.000000000 +0100
@@ -1,7 +1,6 @@
(in-package :qt)
-(declaim (optimize (debug 3)))
-(defvar *cxx-lisp-objects* (make-hash-table)
+(defvar *cxx-lisp-objects* (smoke::make-synchronized-hash-table)
"Objects that are currently passed in a C++ class.")
(let ((id 0))
@@ -28,7 +27,7 @@
((id :int))
(remhash id *cxx-lisp-objects*))
-(defvar *cxx-lisp-object-metatype*)
+(defvar *cxx-lisp-object-metatype* "Metatype ID of the C++ lisp_object.")
(eval-startup ()
(setf *cxx-lisp-object-metatype*
diff -rN -u old-qt.gui/src/object.lisp new-qt.gui/src/object.lisp
--- old-qt.gui/src/object.lisp 2014-10-30 07:01:10.000000000 +0100
+++ new-qt.gui/src/object.lisp 2014-10-30 07:01:10.000000000 +0100
@@ -1,17 +1,16 @@
(in-package :qt)
-(declaim (optimize (debug 3)))
(let ((object (make-instance 'object)))
(defmethod cxx:static-meta-object ((class (eql (find-class 'object))))
"No OBJECT.STATIC-META-OBJECT (r558420)."
(cxx:meta-object object))
- (defmethod cxx:static-meta-object ((class smoke::smoke-wrapper-class))
+ (defmethod cxx:static-meta-object ((class cxx:class))
(cxx:static-meta-object (smoke::find-smoke-class class))))
-(defmethod documentation :around ((class smoke::smoke-standard-class)
+(defmethod documentation :around ((class cxx:class)
(doc-type t))
(if (and (subtypep class (find-class 'object))
- (not (subtypep class (find-class 'smoke::smoke-wrapper-class))))
+ (not (subtypep class (find-class 'cxx:class))))
(format nil "~@[~A~%~]Properties:~%~T~{~<~%~T~0,75:; ~(~A~)~>~}
Signals:
@@ -56,10 +55,6 @@
(meta-object-slots (cxx:static-meta-object class)))
-(defvar *children* (make-hash-table)
- "A list of custom subclasses of QObject which have a parent
-and therefor must not be garbage collected.")
-
(defmethod initialize-instance :after ((object object)
&key pointer &allow-other-keys)
"Registers the object to the parent when a parent was set in the constructor
@@ -69,16 +64,16 @@
(error "Object ~A has not been constructed" object))
(when (and (null pointer)
(not (null-pointer-p (smoke::pointer object)))
-; (typep (class-of object) 'smoke::smoke-wrapper-class)
+; (typep (class-of object) 'cxx:class)
(not (null-pointer-p (smoke::pointer (cxx:parent object)))))
- (setf (gethash (smoke::pointer object) *children*) object)))
+ (smoke::disown-object object)))
(define-condition wrapper-gc (storage-condition)
((class-name :initarg :class-name
:documentation "The class name of the gc'ed object.")
(pointer :initarg :pointer))
(:report (lambda (condition stream)
- (format stream "The object ~A ~A of type smoke-wrapper-class
+ (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)))))
@@ -97,33 +92,34 @@
"QObject")
"deleteLater")))
- (defmethod smoke::make-finalize ((object object))
+(defun print-object-to-string (object)
+ (with-output-to-string (stream)
+ (print-object object stream)))
+
+(defmethod smoke::make-finalize ((object object))
"Delete the qt:object OBJECT,
by calling cxx:delete-later iff it has no parent."
(let ((pointer (pointer object))
- (name (class-name (class-of object)))
+ (class (class-of object))
(next (call-next-method)))
- (if (typep (class-of object) 'smoke::smoke-wrapper-class)
+ (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
:pointer pointer)))
- (condition (condition)
- (format *debug-io* "error: wrap finalize ~A ~A~%" name
- condition))))
+ (error (condition)
+ (smoke::report-finalize-error condition "qt:object wrap"
+ (name class) pointer))))
#'(lambda ()
(handler-case
- (progn
- (when (null-pointer-p (smoke::pointer-call *get-parent* pointer))
- (funcall next)))
- (condition (condition)
- (format *debug-io* "error: qfinalize ~A ~A ~A~%" name
- pointer
- condition))))))
- ;(smoke::pointer-call delete-later pointer)))))))
- )
+ (if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
+ (funcall next)
+ (cerror 'continue "Finalizer for object with a parent called."))
+ (error (condition)
+ (smoke::report-finalize-error condition "qt:object"
+ (name class) pointer)))))))
;;;
;;; The event-notify callback get called by QCoreApplication,
@@ -143,27 +139,22 @@
(cffi:defcallback event-notify smoke:cxx-bool
((data :pointer))
(declare (optimize (speed 3)))
- (let ((event (make-instance 'event :pointer (cffi:mem-aref data :pointer 1)
- :owned-p nil)))
+ (let ((event (make-instance 'event :pointer (cffi:mem-aref data :pointer 1))))
(enum-case (cxx:type event)
(event.+child-added+
(let* ((child-event (make-instance 'child-event
:pointer
- (smoke::upcast event (find-class 'child-event))
- :owned-p nil))
- (child (smoke::get-object
- (smoke::pointer (cxx:child child-event)))))
-; (when (and child
-; (typep (class-of child)
-; 'smoke::smoke-wrapper-class))
- (when child
- (setf (gethash (smoke::pointer child) *children*) child))))
+ (smoke::upcast event (find-class 'child-event)))))
+ (smoke::disown-object (cxx:child child-event))))
(event.+child-removed+
(let* ((child-event (make-instance 'child-event
:pointer (smoke::upcast event
- (find-class 'child-event))
- :owned-p nil)))
- (remhash (smoke::pointer (cxx:child child-event)) *children*)))))
+ (find-class 'child-event)))))
+ ;; We receive child removed events for any QObject, wherter
+ ;; it was construted by Smoke or not. Only take ownership of objects
+ ;; that have been constructed by Smoke.
+ (when (smoke::has-pointer-p (smoke::pointer (cxx:child child-event)))
+ (smoke::take-ownership (cxx:child child-event)))))))
nil)
(eval-when (:compile-toplevel :load-toplevel :execute)
diff -rN -u old-qt.gui/src/package.lisp new-qt.gui/src/package.lisp
--- old-qt.gui/src/package.lisp 2014-10-30 07:01:10.000000000 +0100
+++ new-qt.gui/src/package.lisp 2014-10-30 07:01:10.000000000 +0100
@@ -21,6 +21,7 @@
#:property
#:property-p
+ #:remove-property
#:properties
#:class-properties
#:class-direct-properties
diff -rN -u old-qt.gui/src/properties.lisp new-qt.gui/src/properties.lisp
--- old-qt.gui/src/properties.lisp 2014-10-30 07:01:10.000000000 +0100
+++ new-qt.gui/src/properties.lisp 2014-10-30 07:01:10.000000000 +0100
@@ -14,12 +14,17 @@
"Returns the property NAME of OBJECT."
(from-variant (cxx:property object (property-name name))))
+
(defun (setf property) (new-value object name)
(cxx:set-property object (property-name name)
(make-instance 'qt:variant
:args (list new-value)))
new-value)
+(defun remove-property (object name)
+ "Removes the property NAME from OBJECT."
+ (setf (property object name) (qt:make-variant)))
+
(defun property-p (object name)
"Returns T when NAME is a property of OBJECT and NIL otherwise."
(variant-boundp (cxx:property object (property-name name))))
diff -rN -u old-qt.gui/src/signal-slot/signal-slot.lisp new-qt.gui/src/signal-slot/signal-slot.lisp
--- old-qt.gui/src/signal-slot/signal-slot.lisp 2014-10-30 07:01:10.000000000 +0100
+++ new-qt.gui/src/signal-slot/signal-slot.lisp 2014-10-30 07:01:10.000000000 +0100
@@ -2,7 +2,7 @@
(defclass funcallable-smoke-class (closer-mop:funcallable-standard-class
- smoke::smoke-wrapper-class)
+ cxx:class)
())
(defmethod closer-mop:validate-superclass ((class funcallable-smoke-class)
diff -rN -u old-qt.gui/src/signal-slot/slot.lisp new-qt.gui/src/signal-slot/slot.lisp
--- old-qt.gui/src/signal-slot/slot.lisp 2014-10-30 07:01:10.000000000 +0100
+++ new-qt.gui/src/signal-slot/slot.lisp 2014-10-30 07:01:10.000000000 +0100
@@ -7,7 +7,7 @@
(function :reader slot-function :initarg :slot-function
:initform (error "no function specified")
:documentation "The function called when the slot is invoked."))
- (:metaclass smoke::smoke-wrapper-class)
+ (:metaclass cxx:class)
(:documentation "A Qt slot that calls its associated function"))
(defun make-slot (function &optional (arguments nil arguments-p))