Thu Jun 11 16:59:48 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* :qt and :qt-impl packages to prevent collision with :cl symbols and fix object with non smoke parent.

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

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

@@ -1,15 +1,15 @@

-(in-package :qt)

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

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

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

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

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

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

(cxx:meta-object object))

(defmethod cxx:static-meta-object ((class cxx:class))

(cxx:static-meta-object (smoke::find-smoke-class class))))

-(defmethod documentation :around ((class cxx:class)

- (doc-type t))

- (if (and (subtypep class (find-class 'object))

+(defmethod documentation :around ((class smoke::smoke-standard-class)

+ (doc-type (eql 't)))

+ (if (and (subtypep class (find-class 'qt:object))

(not (subtypep class (find-class 'cxx:class))))

(format nil "~@[~A~%~]Properties:~%~T~{~<~%~T~0,75:; ~(~A~)~>~}

@@ -17,12 +17,12 @@

~{~T~A~%~}

Slots:

~{~T~A~%~}"

- (call-next-method) (sort (class-properties class) #'string<=)

+ (call-next-method) (sort (qt:class-direct-properties class) #'string<=)

(sort (class-signals class) #'string<=)

(sort (class-slots class) #'string<=))

(call-next-method)))

-(defmethod print-object ((object object) stream)

+(defmethod print-object ((object qt:object) stream)

(if (or (not (slot-boundp object 'pointer))

(null-pointer-p (pointer object)))

(call-next-method)

@@ -35,27 +35,43 @@

collect (cxx:method meta-object index)))

-(defun meta-object-signals (meta-object)

+(defun meta-object-signals (meta-object &key all)

(mapcar #'cxx:signature

(remove-if-not #'(lambda (m) (enum= qt:meta-method.+signal+

(cxx:method-type m)))

- (meta-object-methods meta-object))))

+ (meta-object-methods meta-object (not all)))))

-(defun class-signals (class)

- (meta-object-signals (cxx:static-meta-object class)))

+(defun class-signals (class &key all)

+ (meta-object-signals (cxx:static-meta-object class) :all all))

-(defun meta-object-slots (meta-object)

+(defun meta-object-slots (meta-object &key all)

(mapcar #'cxx:signature

(remove-if-not #'(lambda (m) (enum= qt:meta-method.+slot+

(cxx:method-type m)))

- (meta-object-methods meta-object))))

+ (meta-object-methods meta-object (not all)))))

-(defun class-slots (class)

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

+(defun class-slots (class &key all)

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

+ "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.

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

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

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

&key pointer &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."

@@ -64,9 +80,9 @@

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

(when (and (null pointer)

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

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

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

- (smoke::transfer-ownership-to object (cxx:parent object))))

+ (parent-p object))

+ (smoke::transfer-ownership-to object

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

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

((class-name :initarg :class-name

@@ -95,7 +111,7 @@

(with-output-to-string (stream)

(print-object object stream)))

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

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

"Delete the qt:object OBJECT,

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

(let ((pointer (pointer object))

@@ -121,6 +137,7 @@

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

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

+

;;;

;;; The event-notify callback get called by QCoreApplication,

;;; on notification of an event.

@@ -140,19 +157,22 @@

((data :pointer))

(declare (optimize (speed 3)))

(let ((receiver (smoke::get-object (cffi:mem-aref data :pointer 0)))

- (event (make-instance 'event :pointer (cffi:mem-aref data :pointer 1))))

+ (event (make-instance 'qt:event

+ :pointer (cffi:mem-aref data :pointer 1))))

(enum-case (cxx:type event)

- (event.+child-added+

- (let ((child-event (make-instance 'child-event

+ (qt:event.+child-added+

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

:pointer

- (smoke::upcast event (find-class 'child-event)))))

+ (smoke::upcast event (find-class 'qt:child-event)))))

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

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

- (assert receiver)

+ (unless receiver

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

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

- (event.+child-removed+

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

+ (qt:event.+child-removed+

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

:pointer (smoke::upcast event

- (find-class 'child-event)))))

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