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/qt.mbd 2014-10-30 07:00:41.000000000 +0100

+++ new-qt.gui/qt.mbd 2014-10-30 07:00:41.000000000 +0100

@@ -45,7 +45,7 @@

("qt" (:needs "package" "lib"))

("ownership" (:needs "qt"))

- ("object" (:needs "qt"))

+ ("object" (:needs "qt" "signal-slot" "qstring"))

("operator" (:needs "qt" "object"))

("application" (:needs "qt" "properties"))

("qstring" (:needs "qt"))

--- old-qt.gui/src/application.lisp 2014-10-30 07:00:41.000000000 +0100

+++ new-qt.gui/src/application.lisp 2014-10-30 07:00:41.000000000 +0100

@@ -40,7 +40,9 @@

(progn

(when (not (null-pointer-p (smoke::pointer

(qt:core-application.instance))))

- (cerror "Delete the active application." "Active application not created by QT:WITH-APP.")

+ (cerror (format nil "Delete the active application ~A."

+ (qt:core-application.instance))

+ "Active application not created by QT:WITH-APP.")

(smoke::delete-pointer (smoke::pointer (qt:core-application.instance))

(find-class 'qt:core-application)))

(let* ((argc (smoke:make-auto-pointer

--- old-qt.gui/src/lib/qt-smoke.cpp 2014-10-30 07:00:41.000000000 +0100

+++ new-qt.gui/src/lib/qt-smoke.cpp 2014-10-30 07:00:41.000000000 +0100

@@ -14,7 +14,7 @@

*

* @param callback the callback

*

- * @return @c true on success and @c false when the callback table is full.

+ * @return @c true on success and @c false otherwise

*/

CL_SMOKE_QT_EXPORT int

qt_smoke_register_event_notify(void* callback)

@@ -25,4 +25,20 @@

reinterpret_cast<qInternalCallback>(callback));

}

+/** Returns the most specific QMetaObject of the QObject instance @a object.

+ * Used to determine the actual class of an object. Smoke can not be used since it calls the

+ * metaObject() of the class the method was called for.

+ *

+ * @param object A QObject

+ *

+ * @return QMetaObject

+ */

+CL_SMOKE_QT_EXPORT void*

+qt_smoke_meta_object(void* object)

+{

+ Q_ASSERT(object);

+ static_cast<QObject*>(object)->metaObject();

+}

+

+

} // extern "C"

--- old-qt.gui/src/list.lisp 2014-10-30 07:00:41.000000000 +0100

+++ new-qt.gui/src/list.lisp 2014-10-30 07:00:41.000000000 +0100

@@ -21,22 +21,12 @@

"Appends NEW-ELEMENT to LIST."

(list :pointer)

(new-element :pointer))

- (define-foreign-type ,list-type ()

- ()

- (:actual-type :pointer))

- (define-parse-method ,list-type ()

- (make-instance ',list-type))

- (eval-when (:load-toplevel :execute)

- ,@(loop for type-name in (ensure-list type-name) collect

- `(smoke::add-type ,(format nil "const QList<~A>&" type-name)

- ',list-type))

- ,@(loop for type-name in (ensure-list type-name) collect

- `(smoke::add-type ,(format nil "QList<~A>" type-name) ',list-type)))

+ ;; To Lisp

,@(loop for type-name in (ensure-list type-name) collect

- `(defmethod translate-from-foreign (list (type ,list-type))

+ `(defun ,(symbolicate 'from- type-name) (list-pointer)

(let ((vector (make-array (,(symbolicate 'qt-smoke-list-

type '-size)

- list))))

+ list-pointer))))

(dotimes (index (length vector) vector)

(setf (aref vector index)

;; FIXME the returned object is not wrapped by Smoke

@@ -44,23 +34,27 @@

(smoke::object-to-lisp

(,(symbolicate 'qt-smoke-list-

type '-at)

- list index)

- (smoke::make-smoke-type *smoke-module* ,type-name)))))))

- (defmethod free-translated-object (pointer (type ,list-type) param)

- (declare (ignore param))

- (,(symbolicate 'qt-smoke-free-list- type)

- pointer))

+ list-pointer index)

+ (smoke::make-smoke-type *smoke-module*

+ ,type-name)))))))

+ ,@(loop for type-name in (ensure-list type-name) collect

+ `(define-to-lisp-translation

+ (,(format nil "const QList<~A>&" type-name)

+ ,(format nil "QList<~A>" type-name))

+ ,(symbolicate 'from- type-name)

+ ,(symbolicate 'qt-smoke-free-list- type)))

+ ;; From Lisp

(defun ,(symbolicate 'coerce- list-type) (list)

(let ((qlist (,(symbolicate 'qt-smoke-make-list- type))))

(loop for element in list do

(,(symbolicate 'qt-smoke-list- type '-append)

qlist (pointer (make-instance ',type :args (list element)))))

- (smoke::make-cleanup-pointer

+ (make-cleanup-pointer

qlist

(function ,(symbolicate 'qt-smoke-free-list- type)))))

,@(loop for type-name in (ensure-list type-name) collect

`(define-from-lisp-translation (,(format nil "const QList<~A>&" type-name)

- ,(format nil "QLIst<~A>" type-name))

+ ,(format nil "QList<~A>" type-name))

list ;; FIXME allow sequence and define element type

,(symbolicate 'coerce- list-type))))))

--- old-qt.gui/src/msg-handler.lisp 2014-10-30 07:00:41.000000000 +0100

+++ new-qt.gui/src/msg-handler.lisp 2014-10-30 07:00:41.000000000 +0100

@@ -6,6 +6,9 @@

(:critical-message)

(:fatal-message))

+;; QtMsgHandler is a typedef for a pointer.

+(define-pointer-typedef "QtMsgHandler" foreign-pointer)

+

(defcallback qt-msg-handler :void

((type qt-msg-type)

(message :string))

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

+++ new-qt.gui/src/object.lisp 2014-10-30 07:00:41.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))

--- old-qt.gui/src/qstring.lisp 2014-10-30 07:00:41.000000000 +0100

+++ new-qt.gui/src/qstring.lisp 2014-10-30 07:00:41.000000000 +0100

@@ -10,17 +10,6 @@

(defcfun qt-smoke-qstring-to-byte-array :pointer

(qstring :pointer))

-(define-foreign-type qstring ()

- ()

- (:actual-type :pointer))

-

-(defun setup-type-map ()

- (smoke::add-type "QString" 'qstring)

- (smoke::add-type "const QString&" 'qstring))

-

-(eval-when (:load-toplevel :execute)

- (setup-type-map))

-

;;; make sure, that you have configured slime correctly.

;;; e.g.:

;;; (string #\U9999) crashed slime for me. Adding

@@ -34,33 +23,27 @@

(qt:text-codec.set-codec-for-locale

(qt:text-codec.codec-for-name (string *default-foreign-encoding*))))

-(define-parse-method qstring ()

- (make-instance 'qstring))

-

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

- (let ((method (smoke::make-smoke-method-from-name (find-class 'qt:byte-array)

- "data")))

- (defmethod cxx:data ((array qt:byte-array))

- (values ;; Discharge second return value (length of string)

- (foreign-string-to-lisp (smoke::pointer-call method

- (smoke::pointer array))

- :count (cxx:size array))))))

+ (let ((method (smoke::make-smoke-method-from-name (find-class 'qt:byte-array)

+ "data")))

+ (defmethod cxx:data ((array qt:byte-array))

+ (values ;; Discharge second return value (length of string)

+ (foreign-string-to-lisp (smoke::pointer-call method

+ (smoke::pointer array))

+ :count (cxx:size array))))))

-(defmethod translate-from-foreign (string (type qstring))

+(defun from-qstring (qstring)

(cxx:data (make-instance 'qt:byte-array

- :pointer (qt-smoke-qstring-to-byte-array string))))

+ :pointer (qt-smoke-qstring-to-byte-array qstring))))

-(defmethod free-translated-object (pointer (type qstring) param)

- (declare (ignore param))

- (qt-smoke-free-qstring pointer))

+(define-to-lisp-translation ("QString" "const QString&")

+ from-qstring qt-smoke-free-qstring)

(defun coerce-qstring (string)

(make-cleanup-pointer

(with-foreign-string ((data length) string :null-terminated-p nil)

(qt-smoke-string-to-qstring data length))

- #'(lambda (pointer)

- (free-translated-object pointer (make-instance 'qstring)

- nil))))

+ #'qt-smoke-free-qstring))

(define-from-lisp-translation ("const QString&" "QString") string

coerce-qstring)

--- old-qt.gui/src/signal-slot/connect.lisp 2014-10-30 07:00:41.000000000 +0100

+++ new-qt.gui/src/signal-slot/connect.lisp 2014-10-30 07:00:41.000000000 +0100

@@ -13,7 +13,9 @@

(assert (= (length signal-arguments) (length slot-arguments)))

(loop for signal-arg in signal-arguments

for slot-arg in slot-arguments do

- (assert (subtypep signal-arg slot-arg))))

+ (if (typep signal-arg 'smoke::smoke-type)

+ (assert (smoke-type= signal-arg slot-arg))

+ (assert (subtypep signal-arg slot-arg)))))

;;FIXME check argument-types

(defmethod qt:connect ((qsignal qsignal) (qslot qslot) &optional type)

@@ -39,9 +41,10 @@

(defmethod qt:connect ((sender qsignal) (function function) &optional type)

(let ((slot (make-instance 'qslot

- :args (list (signal-object sender))

+ :arg0 (signal-object sender)

:argument-types (argument-types (signal-object sender))

:slot-function function)))

+

(unless (connect-id (signal-object sender) (id (signal-object sender))

slot (id slot)

type

@@ -63,6 +66,14 @@

:reader receiver))

(:documentation "Qt C++ slot."))

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

+ (print-unreadable-object (qt-signal stream :type t :identity t)

+ (when (slot-boundp qt-signal 'sender)

+ (princ (qsender qt-signal) stream))

+ (princ " " stream)

+ (when (slot-boundp qt-signal 'name)

+ (princ (name qt-signal) stream))))

+

(defgeneric qt:get-slot (receiver name)

(:documentation "Returns the slot of RECEIVER with NAME.")

(:method (receiver name)

@@ -70,18 +81,18 @@

(:method (receiver (function function))

"Returns a slot for RECEIVER that calls function

with RECEIVER as the first argument."

- (let ((slot (qt:make-slot #'(lambda (&rest args)

- (apply function (cxx:parent *this*)

- args)))))

- (cxx:set-parent slot receiver)

- slot)))

+ (make-instance 'qslot

+ :arg0 receiver

+ :slot-function #'(lambda (&rest args)

+ (apply function (cxx:parent *this*)

+ args)))))

(define-compiler-macro qt:get-slot (&whole form receiver name)

"Normalize the slot name."

(if (stringp name)

(let ((normalized-name (cxx:data

(qt:meta-object.normalized-signature name))))

- (if (string= name normalized-name) ;; Avoid loop

+ (if (string= name normalized-name) ;; Avoid infinite recursion

form

`(qt:get-slot ,receiver ,normalized-name)))

form))

@@ -95,7 +106,7 @@

(if (stringp name)

(let ((normalized-name (cxx:data

(qt:meta-object.normalized-signature name))))

- (if (string= name normalized-name) ;; Avoid loop

+ (if (string= name normalized-name) ;; Avoid infinite recursion

form

`(qt:get-signal ,sender ,normalized-name)))

form))

@@ -124,6 +135,7 @@

(defmethod qt:connect ((qt-signal qt-signal) (function function) &optional type)

(let* ((signal-id (find-signal-id (qsender qt-signal) (name qt-signal)))

(slot (make-instance 'qslot

+ :arg0 (qsender qt-signal)

:slot-function function

:argument-types

(method-arguments-type

@@ -137,17 +149,6 @@

;; object is not accessible to the user,

;; who thus can not connect it to other

;; signals.

- (if (smoke::has-pointer-p (smoke:pointer (qsender qt-signal)))

- (setf (cxx:parent slot) (qsender qt-signal))

- ;; when QT-SIGNAL is not a Smoke instance.

- (progn

- (unless (qt:property-p (qsender qt-signal) 'connected-slots)

- (setf (qt:property (qsender qt-signal) 'connected-slots)

- (qt:make-lisp-variant (list))))

- (setf (qt:property (qsender qt-signal) 'connected-slots)

- (qt:make-lisp-variant

- (cons slot

- (qt:property (qsender qt-signal) 'connected-slots))))))

(if (connect-id (qsender qt-signal) signal-id

slot (id slot)

type (types (arguments slot)))

--- old-qt.gui/src/signal-slot/slot.lisp 2014-10-30 07:00:41.000000000 +0100

+++ new-qt.gui/src/signal-slot/slot.lisp 2014-10-30 07:00:41.000000000 +0100

@@ -4,7 +4,7 @@

((arguments :reader arguments :initarg :argument-types

:documentation "List of the argument types for the slot.")

(function :reader slot-function :initarg :slot-function

- :initform (error "no function specified")

+ :initform (error "no slot function specified")

:documentation "The function called when the slot is invoked."))

(:metaclass cxx:class)

(:documentation "A Qt slot that calls its associated function"))

--- old-qt.gui/src/signal-slot/translate.lisp 2014-10-30 07:00:41.000000000 +0100

+++ new-qt.gui/src/signal-slot/translate.lisp 2014-10-30 07:00:41.000000000 +0100

@@ -52,12 +52,11 @@

;; returns.

(disown-object (smoke::object-to-lisp pointer type)))

(ecase (smoke::type-id type)

- (0 (let ((cffi-type (smoke::get-type (name type))))

- (if (null cffi-type)

- (progn

- pointer)

- (convert-from-foreign pointer

- cffi-type))))

+ (0 (if-let ((translation (gethash (name type) smoke::*to-lisp-translations*)))

+ ;; Do not free stack allocated stuff (e.g.: QString); that is the callers

+ ;; responisbility.

+ (funcall (car translation) pointer)

+ (error "Do not know how to convert the type ~A to Lisp." type)))

(1 (mem-ref pointer 'cxx-bool))

(2 (code-char (mem-ref pointer :char)))

(3 (code-char (mem-ref pointer :unsigned-char)))

--- old-qt.gui/src/string-list.lisp 2014-10-30 07:00:41.000000000 +0100

+++ new-qt.gui/src/string-list.lisp 2014-10-30 07:00:41.000000000 +0100

@@ -17,45 +17,28 @@

(string :pointer)

(length :int))

-(define-foreign-type string-list ()

- ()

- (:actual-type :pointer))

-

-(eval-when (:load-toplevel)

- (smoke::add-type "QStringList" 'string-list)

- (smoke::add-type "const QStringList&" 'string-list))

-

-

-(define-parse-method string-list ()

- (make-instance 'string-list))

-

-(defmethod translate-to-foreign (sequence (type string-list))

- (let ((string-list (qt-smoke-make-string-list)))

- (map nil #'(lambda (string)

- (with-foreign-string ((data length) string :null-terminated-p nil)

- (qt-smoke-string-list-append string-list data length)))

- sequence)

- string-list))

-

-

-(defmethod translate-from-foreign (string-list (type string-list))

- (let ((vector (make-array (qt-smoke-string-list-size string-list))))

+(defun from-string-list (string-list)

+ (let ((vector (make-array (qt-smoke-string-list-size string-list)

+ :initial-element ""

+ :element-type 'string)))

(dotimes (index (length vector) vector)

(setf (aref vector index)

(cxx:data (make-instance 'qt:byte-array

:pointer (qt-smoke-string-list-at

string-list index)))))))

+

+(define-to-lisp-translation ("QStringList" "const QStringList&")

+ from-string-list qt-smoke-free-string-list)

-(defmethod free-translated-object (string-list (type string-list) param)

- (declare (ignore param))

- (qt-smoke-free-string-list string-list))

-

-(defun coerce-string-list (list)

- (make-cleanup-pointer

- (translate-to-foreign list (make-instance 'string-list))

- #'(lambda (pointer)

- (free-translated-object pointer (make-instance 'string-list)

- nil))))

+(defun coerce-string-list (sequence)

+ (let ((string-list (qt-smoke-make-string-list)))

+ (map nil

+ #'(lambda (string)

+ (with-foreign-string ((data length) string :null-terminated-p nil)

+ (qt-smoke-string-list-append string-list data length)))

+ sequence)

+ (make-cleanup-pointer

+ string-list #'qt-smoke-free-string-list)))

(define-from-lisp-translation "const QStringList&"

(vector string) coerce-string-list)