Thu Jul 23 00:21:01 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* support packages for symbols as property names.

--- old-qt.gui/TODO 2014-10-30 07:00:45.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"

--- old-qt.gui/qt.mbd 2014-10-30 07:00:45.000000000 +0100

+++ new-qt.gui/qt.mbd 2014-10-30 07:00:45.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"))

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

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

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

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

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

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

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

+++ new-qt.gui/src/painter.lisp 2014-10-30 07:00:45.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"

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

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

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

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

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

+++ new-qt.gui/src/signal-slot/connect.lisp 2014-10-30 07:00:45.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

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

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

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

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

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

+++ new-qt.gui/src/signal-slot/translate.lisp 2014-10-30 07:00:45.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)

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

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