Sun May 31 19:33:32 CEST 2009 Tobias Rautenkranz * 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:48:29.000000000 +0100 +++ new-qt.gui/src/application.lisp 2014-10-30 07:48:29.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:48:29.000000000 +0100 +++ new-qt.gui/src/lisp-object.lisp 2014-10-30 07:48:29.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:48:29.000000000 +0100 +++ new-qt.gui/src/object.lisp 2014-10-30 07:48:29.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:48:29.000000000 +0100 +++ new-qt.gui/src/package.lisp 2014-10-30 07:48:29.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:48:29.000000000 +0100 +++ new-qt.gui/src/properties.lisp 2014-10-30 07:48:29.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:48:29.000000000 +0100 +++ new-qt.gui/src/signal-slot/signal-slot.lisp 2014-10-30 07:48:29.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:48:29.000000000 +0100 +++ new-qt.gui/src/signal-slot/slot.lisp 2014-10-30 07:48:29.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))