Thu Jul 23 00:21:01 CEST 2009 Tobias Rautenkranz * support packages for symbols as property names. diff -rN -u old-qt.gui/TODO new-qt.gui/TODO --- old-qt.gui/TODO 2014-10-30 07:45:05.000000000 +0100 +++ new-qt.gui/TODO 1970-01-01 01:00:00.000000000 +0100 @@ -1 +0,0 @@ -* QApplication and KCmdLineArgs.init call exit() on e.g. "--help" diff -rN -u old-qt.gui/qt.mbd new-qt.gui/qt.mbd --- old-qt.gui/qt.mbd 2014-10-30 07:45:05.000000000 +0100 +++ new-qt.gui/qt.mbd 2014-10-30 07:45:05.000000000 +0100 @@ -47,7 +47,7 @@ ("ownership" (:needs "qt")) ("object" (:needs "qt")) ("operator" (:needs "qt" "object")) - ("application" (:needs "qt")) + ("application" (:needs "qt" "properties")) ("qstring" (:needs "qt")) ("list" (:needs "qt")) ("msg-handler" (:needs "lib")) 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:45:05.000000000 +0100 +++ new-qt.gui/src/application.lisp 2014-10-30 07:45:05.000000000 +0100 @@ -17,61 +17,61 @@ "Returns t when the APPLICATION object exists and nil otherwise." (boundp '*app*)) -(let ((argv (null-pointer)) - (argc (null-pointer))) - (declare (cffi:foreign-pointer argv argc)) - (defun ensure-app (&optional - (application 'qt:application) - (args #+sbcl sb-ext:*posix-argv* - #+ccl ccl:*command-line-argument-list* - #-(or sbcl ccl) (list (lisp-implementation-type)))) - "Constructs the global application object, when there is none, +(defun ensure-app (&optional + (application 'qt:application) + (args #+sbcl sb-ext:*posix-argv* + #+ccl ccl:*command-line-argument-list* + #-(or sbcl ccl) (list (lisp-implementation-type)))) + "Constructs the global application object, when there is none, with the command line arguments ARGS. Returns the application object a first value and true when a new application was created and false otherwise." - (assert (not (null args)) - (args) - "No program name supplied.") - (if (qt:app-p) - (progn - (assert (typep (qt:app) (find-class application)) - (application) - "The existing application object ~A is + (assert (not (null args)) + (args) + "No program name supplied.") + (if (qt:app-p) + (progn + (assert (typep (qt:app) (find-class application)) + (application) + "The existing application object ~A is not of type ~A." (qt:app) (find-class application)) - (values (qt:app) nil)) - (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.") - (smoke::delete-pointer (smoke::pointer (qt:core-application.instance)) - (find-class 'qt:core-application))) - (foreign-free argv) - (foreign-free argc) - - (setf argc (foreign-alloc :int :initial-element (length args))) - (setf argv (foreign-alloc :string :initial-contents args)) - (let ((app (make-instance 'qt:application :args (list argc argv)))) - (tg:cancel-finalization app) - (values app t))))) - (defun kill-app () - (when (typep (qt:app) 'qt:application) - (qt:application.close-all-windows) - ;; widgets are only valid as long, as an application object exists. - ;; QApplication::~QApplication() deletes all widgets in - ;; QApplication::allWidgets(). - ;; - ;; see: qt4/src/gui/kernel/qapplication.cpp - (loop for widget across (qt:application.all-widgets) do - (trivial-garbage:cancel-finalization widget))) - (cxx:quit (qt:app)) - (setf *widgets* nil) - ;; Call the destructor; -> destructed callback is called, - ;; (~QApplication() is virtual) which takes care of cleanup - ;; on the Lisp side. - (smoke::delete-pointer (smoke::pointer (qt:app)) (class-of (qt:app))) - (setf (slot-value (qt:app) 'pointer) (null-pointer)) - (makunbound '*app*))) + (values (qt:app) nil)) + (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.") + (smoke::delete-pointer (smoke::pointer (qt:core-application.instance)) + (find-class 'qt:core-application))) + (let* ((argc (smoke:make-auto-pointer + (foreign-alloc :int :initial-element (length args)))) + (argv (smoke:make-auto-pointer + (foreign-alloc :string :initial-contents args))) + (app (make-instance 'qt:application :args (list argc argv)))) + ;; argc and argv must remain valid during the lifetime of APP. + (setf (qt:property app 'cmdline-args) + (qt:make-lisp-variant (list argc argv))) + (tg:cancel-finalization app) + (values app t))))) + +(defun kill-app () + (when (typep (qt:app) 'qt:application) + (qt:application.close-all-windows) + ;; widgets are only valid as long, as an application object + ;; exists. QApplication::~QApplication() deletes all widgets in + ;; QApplication::allWidgets(). + ;; + ;; see: qt4/src/gui/kernel/qapplication.cpp + (loop for widget across (qt:application.all-widgets) do + (tg:cancel-finalization widget))) + (cxx:quit (qt:app)) + (setf *widgets* nil) + ;; Call the destructor; -> destructed callback is called, + ;; (~QApplication() is virtual) which takes care of cleanup on the + ;; Lisp side. + (smoke::delete-pointer (smoke:pointer (qt:app)) (class-of (qt:app))) + (setf (slot-value (qt:app) 'pointer) (null-pointer)) + (makunbound '*app*)) (defmacro with-application ((ensure-app remove-app) &body body) (let ((cleanup-p (gensym))) 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:45:05.000000000 +0100 +++ new-qt.gui/src/object.lisp 2014-10-30 07:45:05.000000000 +0100 @@ -99,12 +99,13 @@ (slot-value condition 'pointer))))) (smoke:eval-startup (:compile-toplevel :execute) -(defparameter *get-parent* - (smoke::make-smoke-method-from-name (find-class 'qt:object) "parent")) - ;; FIXME this leaks memory when QCoreApplication::exec is never called, - ;; beause then, deleteLater has no effect. -(defparameter *delete-later* - (smoke::make-smoke-method-from-name (find-class 'qt:object) "deleteLater"))) + (defparameter *get-parent* + (smoke::make-smoke-method-from-name (find-class 'qt:object) "parent")) + + ;; FIXME this leaks memory when QCoreApplication::exec() is never + ;; called, beause then, deleteLater() has no effect. + (defparameter *delete-later* + (smoke::make-smoke-method-from-name (find-class 'qt:object) "deleteLater"))) (defmethod smoke::make-finalize ((object qt:object)) "Delete the qt:object OBJECT, @@ -137,10 +138,12 @@ ;;; -;;; The event-notify callback get called by QCoreApplication, -;;; on notification of an event. +;;; The event-notify callback get called by QCoreApplication, on +;;; notification of an event. +;;; +;;; The DATA argument is an array of size three, containing the +;;; pointers: ;;; -;;; The DATA argument is an array of size three, containing the pointers: ;;; void* receiver ;;; void* event ;;; void* result @@ -149,7 +152,8 @@ ;;; Returning true marks the event as handled; false on the other hand ;;; leaves the event processing unchanged. ;;; -;;; See: QCoreApplication::notifyInternal(QObject *receiver, QEvent *event) +;;; See: QCoreApplication::notifyInternal(QObject *receiver, QEvent +;;; *event) (cffi:defcallback event-notify smoke:cxx-bool ((data :pointer)) @@ -172,8 +176,8 @@ :pointer (smoke::upcast event (find-class 'qt:child-event))))) ;; We receive child removed events for any QObject, whether - ;; it was constructed by Smoke or not. Only take ownership of objects - ;; that have been constructed by Smoke. + ;; it was constructed 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))) (assert receiver) (smoke::take-ownership (cxx:child child-event) receiver)))))) diff -rN -u old-qt.gui/src/operator.lisp new-qt.gui/src/operator.lisp --- old-qt.gui/src/operator.lisp 2014-10-30 07:45:05.000000000 +0100 +++ new-qt.gui/src/operator.lisp 2014-10-30 07:45:05.000000000 +0100 @@ -95,6 +95,8 @@ ;; > $hasPublicDestructor = 1; ;; > $hasPublicProtectedConstructor = 1; ;; + ;; RESOLUTION: + ;; wait for KDE 4.4 -- the new smoke_generator should fix this. (cxx:operator= (cxx:operator[] object index) new-value) new-value) diff -rN -u old-qt.gui/src/painter.lisp new-qt.gui/src/painter.lisp --- old-qt.gui/src/painter.lisp 2014-10-30 07:45:05.000000000 +0100 +++ new-qt.gui/src/painter.lisp 2014-10-30 07:45:05.000000000 +0100 @@ -5,8 +5,8 @@ during the evaluation of BODY. Makes sure the painter ends after BODY; thus preventing problems with -still active and not yet garbage collected painters." - `(let ((,painter (make-instance 'qt:painter :args (list ,paint-device)))) +still active and not yet garbage collected painters in CXX:PAINT-EVENT." + `(let ((,painter (make-instance 'qt:painter :arg0 ,paint-device))) (assert (cxx:is-active ,painter) (,painter) "Painter ~A for ~A is not active" 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:45:05.000000000 +0100 +++ new-qt.gui/src/properties.lisp 2014-10-30 07:45:05.000000000 +0100 @@ -2,7 +2,28 @@ (defun reverse-lispify (symbol) "Converts the name of symbol to C++ style." - (smoke::lisp-to-cxx (symbol-name symbol))) + (if (eq (symbol-package symbol) + (find-package :keyword)) + (smoke::lisp-to-cxx (symbol-name symbol)) + (concatenate 'string + (package-name (symbol-package symbol)) + "::" + (symbol-name symbol)))) + +(defun property-package (name) + (let ((package-end (search "::" name))) + (if package-end + (values + (find-package (intern (subseq name 0 package-end) :keyword)) + (+ 2 package-end)) + (values (find-package :keyword) 0)))) + +(defun lispify-property-name (name) + (multiple-value-bind (package name-start) + (property-package name) + (if (= 0 name-start) + (smoke::lispify name package) + (intern (subseq name name-start) package)))) (defun property-name (name) "The property name is a string or a to camelCase converted symbol." @@ -12,33 +33,48 @@ (defun qt:property (object name) "Returns the property NAME of OBJECT." + (declare (type qt:object object) + (type (or string symbol) name)) + (assert (qt:property-p object name) + (object name) + "~A has no property ~A." object name) (qt:from-variant (cxx:property object (property-name name)))) - (defun (setf qt:property) (new-value object name) - (cxx:set-property object (property-name name) - (make-instance 'qt:variant - :args (list new-value))) + (declare (type qt:object object) + (type (or string symbol) name)) + (cxx:set-property object (property-name name) + (make-instance 'qt:variant :arg0 new-value)) new-value) (defun qt:remove-property (object name) "Removes the property NAME from OBJECT." + (declare (type qt:object object) + (type (or string symbol) name)) (setf (qt:property object name) (qt:make-variant))) (defun qt:property-p (object name) "Returns T when NAME is a property of OBJECT and NIL otherwise." + (declare (type qt:object object) + (type (or string symbol) name)) (qt:variant-boundp (cxx:property object (property-name name)))) (defun meta-object-properties (meta-object &optional (all t)) "Returns a list of the properties of META-OBJECT." (loop for index from (if all 0 (cxx:property-offset meta-object)) below (cxx:property-count meta-object) - collect (smoke::lispify (cxx:name (cxx:property meta-object index))))) + collect (lispify-property-name (cxx:name (cxx:property meta-object index))))) + +(defun sort-symbols (symbols) + (sort symbols + #'(lambda (a b) + (string<= (write-to-string a) (write-to-string b))))) (defgeneric qt:class-properties (class) (:documentation "Returns a list of the properties of CLASS.") (:method ((class class)) - (meta-object-properties (cxx:static-meta-object class))) + (sort-symbols + (meta-object-properties (cxx:static-meta-object class)))) (:method ((symbol symbol)) (qt:class-properties (find-class symbol)))) @@ -50,10 +86,12 @@ (qt:class-direct-properties (find-class symbol)))) (defun dynamic-properties (object) - (map 'list (compose #'smoke::lispify #'cxx:data) + (map 'list (compose #'lispify-property-name #'cxx:data) (cxx:dynamic-property-names object))) (defun qt:properties (object) "Returns a list of the properties of OBJECT." - (nconc (dynamic-properties object) - (meta-object-properties (cxx:meta-object object)))) + (declare (type qt:object object)) + (sort-symbols + (nconc (dynamic-properties object) + (meta-object-properties (cxx:meta-object object))))) 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:45:05.000000000 +0100 +++ new-qt.gui/src/qstring.lisp 2014-10-30 07:45:05.000000000 +0100 @@ -22,18 +22,18 @@ (setup-type-map)) ;;; make sure, that you have configured slime correctly. -;;; e.g. +;;; e.g.: ;;; (string #\U9999) crashed slime for me. Adding ;;; (set-language-environment "UTF-8") ;;; (setq slime-net-coding-system 'utf-8-unix) ;;; to .emacs helps. +;;; Use emacs 23 for better unicode support. (smoke:eval-startup (:compile-toplevel :execute) (qt:text-codec.set-codec-for-cstrings (qt:text-codec.codec-for-name (string *default-foreign-encoding*))) (qt:text-codec.set-codec-for-locale (qt:text-codec.codec-for-name (string *default-foreign-encoding*)))) - (define-parse-method qstring () (make-instance '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:45:05.000000000 +0100 +++ new-qt.gui/src/signal-slot/connect.lisp 2014-10-30 07:45:05.000000000 +0100 @@ -126,10 +126,12 @@ (slot (make-instance 'qslot ;; Set the sender as the slots parent, ;; to ensure it does not get gc'ed. - ;; FIXME: unset parent on disconnect - ;; this no not critical because the slot object - ;; is hidden from the user, who thus can not - ;; connect it to other signals. + ;; + ;; FIXME: unset parent on disconnect. + ;; This no not critical because the slot + ;; object is not accessible to the user, + ;; who thus can not connect it to other + ;; signals. :args (list (qsender qt-signal)) :slot-function function :argument-types diff -rN -u old-qt.gui/src/signal-slot/signal.lisp new-qt.gui/src/signal-slot/signal.lisp --- old-qt.gui/src/signal-slot/signal.lisp 2014-10-30 07:45:05.000000000 +0100 +++ new-qt.gui/src/signal-slot/signal.lisp 2014-10-30 07:45:05.000000000 +0100 @@ -48,13 +48,12 @@ argument-types)) (closer-mop:set-funcallable-instance-function object #'(lambda (&rest args) - (apply #'emit (signal-object object) args))) - ) + (apply #'emit (signal-object object) args)))) (defun find-slot-id (receiver slot) "Returns the ID of RECEIVER from SLOT." - ;; For efficiency assume that SLOT is normalized and fallback - ;; to normalizing when not. (Just like Qt does.) + ;; For efficiency assume that SLOT is normalized and fallback to + ;; normalizing when not. (Just like Qt does.) (let ((id (cxx:index-of-slot (cxx:meta-object receiver) slot))) (when (< id 0) @@ -69,8 +68,8 @@ (defun make-lisp-object (object) - (smoke::make-cleanup-pointer (make-cxx-lisp-object object) - #'qt-smoke-free-lisp-object)) + (smoke:make-cleanup-pointer (make-cxx-lisp-object object) + #'qt-smoke-free-lisp-object)) (defun convert-arguments (arguments types) @@ -89,9 +88,9 @@ (activate qsignal (id qsignal) (argument-types qsignal) arguments)) (defun activate (object id types arguments) -;;; The first element of args would be used for the return value -;;; by QMetaObject::invokeMethod(), but for signal-slot connection -;;; it is ignored. +;;; The first element of args would be used for the return value by +;;; QMetaObject::invokeMethod(), but for signal-slot connection it is +;;; ignored. (smoke::with-stack (stack (convert-arguments arguments types) types) (cffi:with-foreign-object (args :pointer (1+ (length arguments))) 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:45:05.000000000 +0100 +++ new-qt.gui/src/signal-slot/slot.lisp 2014-10-30 07:45:05.000000000 +0100 @@ -49,8 +49,8 @@ (defun find-signal-id (sender signal) "Returns the ID of SIGNAL from SENDER." - ;; For efficiency assume that SIGNAL is normalized and fallback - ;; to normalizing when not. (Just like Qt does.) + ;; For efficiency assume that SIGNAL is normalized and fallback to + ;; normalizing when not. (Just like Qt does.) (let ((id (cxx:index-of-signal (cxx:meta-object sender) signal))) (when (< id 0) 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:45:05.000000000 +0100 +++ new-qt.gui/src/signal-slot/translate.lisp 2014-10-30 07:45:05.000000000 +0100 @@ -13,8 +13,8 @@ (loop as pos = (position #\, arguments :from-end t :end last-pos) while pos do - (push (find-type arguments (1+ pos) last-pos) argument-types) - (setf last-pos pos)) + (push (find-type arguments (1+ pos) last-pos) argument-types) + (setf last-pos pos)) (when (> last-pos 0) (push (find-type arguments 0 last-pos) argument-types)))) @@ -46,9 +46,10 @@ (if (smoke::class-p type) (if (smoke::pointer-p type) (smoke::object-to-lisp (mem-ref pointer :pointer) type) - ;; By value means that they are allocated by the C++ signal - ;; code and have dynamic extend in the slot. The C++ signal code - ;; frees the object when the slot returns. + ;; By-value means that the object at POINTER is allocated by + ;; the C++ signal code and has dynamic extend in the + ;; slot. The C++ signal code frees the object when the slot + ;; returns. (disown-object (smoke::object-to-lisp pointer type))) (ecase (smoke::type-id type) (0 (let ((cffi-type (smoke::get-type (name type)))) @@ -75,9 +76,10 @@ (defun arguments-to-lisp (arguments types) "Returns ARGUMENTS for a slot invocation as lisp objects." - (arguments-to-lisp2 (inc-pointer arguments ;; index 0 is for the return value - (foreign-type-size :pointer)) - types ())) + (arguments-to-lisp2 + (inc-pointer arguments ;; index 0 is for the return value + (foreign-type-size :pointer)) + types ())) (defun get-type (smoke-type) @@ -85,7 +87,7 @@ (typecase smoke-type (smoke::smoke-standard-object (if (smoke::pointer-p smoke-type) - (error "FOO");;qmetatype.+voidstar+ + (error "Not implemented: pointer type.") ;;qmetatype.+voidstar+ (let ((type (qt:meta-type.type (smoke::name smoke-type)))) (assert (/= 0 type) (type) @@ -98,7 +100,7 @@ (defun types (smoke-types) "Returns a newly allocated array of QMetaType IDs of SMOKE-TYPES." - ;;FIXME free TYPES on error. + ;; FIXME free TYPES on error. (let ((types (cffi:foreign-alloc :int :count (1+ (length smoke-types)))) (index 0)) (dolist (type smoke-types) diff -rN -u old-qt.gui/src/variant.lisp new-qt.gui/src/variant.lisp --- old-qt.gui/src/variant.lisp 2014-10-30 07:45:05.000000000 +0100 +++ new-qt.gui/src/variant.lisp 2014-10-30 07:45:05.000000000 +0100 @@ -15,16 +15,16 @@ "Returns a new VARIANT containing a C++ version of VALUE or an empty variant when VALUE is not specified." (if value-p - (make-instance 'qt:variant :args (list value)) + (make-instance 'qt:variant :arg0 value) (make-instance 'qt:variant))) (defun qt:make-char (character) "Returns a char for a lisp CHARACTER." (let ((octets (babel:string-to-octets (string character)))) (case (length octets) - (1 (make-instance 'qt:char :args (list (aref octets 0)))) + (1 (make-instance 'qt:char :arg0 (aref octets 0))) (2 (make-instance 'qt:char :args (list (aref octets 0) - (aref octets 1)))) + (aref octets 1)))) (t (error "qt:char requires the character ~A to be encoded in one or two octets, but it is using ~A." character (length octets)))))) @@ -34,7 +34,7 @@ (cxx:is-low-surrogate char))) (defun qt:from-char (char) - "Returns the lisp character represented by CHAR." + "Returns the Lisp character represented by CHAR." (assert (not (surrogate-p char)) (char) "The char ~A is part of a surrogate.") @@ -54,11 +54,11 @@ (princ (qt:from-char char) stream)))) -;; FIXME include in MAKE-VARIANT? +;; FIXME include in MAKE-VARIANT? how?? (defun qt:make-lisp-variant (value) "Returns a new VARIANT that wraps VALUE. -The variant contains the actual Lisp object +The variant contains the actual Lisp object VALUE and not its C++ value like in MAKE-VARIANT." (let ((object (make-cxx-lisp-object value))) (unwind-protect