Sun Aug 2 13:15:21 CEST 2009 Tobias Rautenkranz * Support ownership transfer to non smoke wrapped QObjects & cleanup C++ to Lisp translation. diff -rN -u old-qt.gui/qt.mbd new-qt.gui/qt.mbd --- old-qt.gui/qt.mbd 2014-10-30 07:44:28.000000000 +0100 +++ new-qt.gui/qt.mbd 2014-10-30 07:44:28.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")) 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:44:28.000000000 +0100 +++ new-qt.gui/src/application.lisp 2014-10-30 07:44:28.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 diff -rN -u old-qt.gui/src/lib/qt-smoke.cpp new-qt.gui/src/lib/qt-smoke.cpp --- old-qt.gui/src/lib/qt-smoke.cpp 2014-10-30 07:44:28.000000000 +0100 +++ new-qt.gui/src/lib/qt-smoke.cpp 2014-10-30 07:44:28.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(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(object)->metaObject(); +} + + } // extern "C" diff -rN -u old-qt.gui/src/list.lisp new-qt.gui/src/list.lisp --- old-qt.gui/src/list.lisp 2014-10-30 07:44:28.000000000 +0100 +++ new-qt.gui/src/list.lisp 2014-10-30 07:44:28.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)))))) diff -rN -u old-qt.gui/src/msg-handler.lisp new-qt.gui/src/msg-handler.lisp --- old-qt.gui/src/msg-handler.lisp 2014-10-30 07:44:28.000000000 +0100 +++ new-qt.gui/src/msg-handler.lisp 2014-10-30 07:44:28.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)) 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:44:28.000000000 +0100 +++ new-qt.gui/src/object.lisp 2014-10-30 07:44:28.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)) diff -rN -u old-qt.gui/src/qstring.lisp new-qt.gui/src/qstring.lisp --- old-qt.gui/src/qstring.lisp 2014-10-30 07:44:28.000000000 +0100 +++ new-qt.gui/src/qstring.lisp 2014-10-30 07:44:28.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) diff -rN -u old-qt.gui/src/signal-slot/connect.lisp new-qt.gui/src/signal-slot/connect.lisp --- old-qt.gui/src/signal-slot/connect.lisp 2014-10-30 07:44:28.000000000 +0100 +++ new-qt.gui/src/signal-slot/connect.lisp 2014-10-30 07:44:28.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))) 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:44:28.000000000 +0100 +++ new-qt.gui/src/signal-slot/slot.lisp 2014-10-30 07:44:28.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")) diff -rN -u old-qt.gui/src/signal-slot/translate.lisp new-qt.gui/src/signal-slot/translate.lisp --- old-qt.gui/src/signal-slot/translate.lisp 2014-10-30 07:44:28.000000000 +0100 +++ new-qt.gui/src/signal-slot/translate.lisp 2014-10-30 07:44:28.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))) diff -rN -u old-qt.gui/src/string-list.lisp new-qt.gui/src/string-list.lisp --- old-qt.gui/src/string-list.lisp 2014-10-30 07:44:28.000000000 +0100 +++ new-qt.gui/src/string-list.lisp 2014-10-30 07:44:28.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)