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.

- ())

+ ((package :initarg :package)))

- ("libqt-smoke-extra" sysdef.cmake:cmake-library)

+ ("libqt-smoke-extra" sysdef.cmake:cmake-library (:package :cl-smoke.qt-impl))

-(in-package :qt)

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

-(defun app ()

+(defun qt:app ()

- (assert (app-p)

+ (assert (qt:app-p)

-(defun app-p ()

+(defun qt:app-p ()

- (application 'application)

+ (application 'qt:application)

- (if (app-p)

+ (if (qt:app-p)

- (assert (typep (app) (find-class application))

+ (assert (typep (qt:app) (find-class application))

-not of type ~A." (app) (find-class application))

- (values (app) nil))

+not of type ~A." (qt:app) (find-class application))

+ (values (qt:app) nil))

- (assert (null-pointer-p (smoke::pointer (core-application.instance)))

- ()

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

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

- (when (typep (app) 'application)

- (application.close-all-windows)

+ (when (typep (qt:app) 'qt:application)

+ (qt:application.close-all-windows)

- (loop for widget across (application.all-widgets) do

+ (loop for widget across (qt:application.all-widgets) do

- (cxx:quit (app))

+ (cxx:quit (qt:app))

- (smoke::delete-pointer (smoke::pointer (app)) (class-of (app)))

- (setf (slot-value (app) 'pointer) (null-pointer))

+ (smoke::delete-pointer (smoke::pointer (qt:app)) (class-of (qt:app)))

+ (setf (slot-value (qt:app) 'pointer) (null-pointer))

-(defmacro with-app (&body body)

+(defmacro qt:with-app (&body body)

- `(with-application ((ensure-app 'application) (kill-app))

+ `(with-application ((cl-smoke.qt-impl::ensure-app 'qt:application) (kill-app))

-(defmacro with-core-app (&body body)

- `(with-application ((ensure-app 'core-application) (kill-app))

+(defmacro qt:with-core-app (&body body)

+ `(with-application ((cl-smoke.qt-impl::ensure-app 'qt:core-application) (kill-app))

-(defun exec (&rest widgets)

+(defun qt:exec (&rest widgets)

- (restart-bind ((abort-app #'(lambda ()

- (cxx:quit (app))

+ (restart-bind ((qt::abort-app #'(lambda ()

+ (cxx:quit (qt:app))

- (and (app-p)

+ (and (qt:app-p)

- (cxx:exec (app)))))

+ (cxx:exec (qt:app)))))

-(in-package :qt)

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

-(defun tr (message &optional context)

+(defun qt:tr (message &optional context)

-(defmacro with-translator ((base-name &rest paths) &body body)

+(defmacro qt:with-translator ((base-name &rest paths) &body body)

- `(let ((,translator (make-instance 'translator)))

+ `(let ((,translator (make-instance 'qt:translator)))

-(defmacro with-libqt-translator (&body body)

+(defmacro qt:with-libqt-translator (&body body)

- `(let ((,translator (make-instance 'translator)))

+ `(let ((,translator (make-instance 'qt:translator)))

-(defun search-file (name &rest paths)

+(defun qt:search-file (name &rest paths)

-(in-package :qt)

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

- (smoke::value meta-type.+user+))

+ (smoke::value qt:meta-type.+user+))

-(in-package :qt)

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

-(in-package :qt)

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

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

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

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

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

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

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

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

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

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

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

-(defmethod initialize-instance :after ((object 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 qt: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))))

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

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

+

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

+ (event (make-instance 'qt:event

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

- (event.+child-added+

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

+ (qt:event.+child-added+

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

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

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

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

- (assert receiver)

+ (unless receiver

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

- (event.+child-removed+

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

+ (qt:event.+child-removed+

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

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

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

-(in-package :qt)

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

-(in-package :qt)

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

-(define-takes-ownership cxx:push ((undo-stack undo-stack) undo-command)

+(define-takes-ownership cxx:push ((undo-stack qt:undo-stack) undo-command)

-(define-takes-ownership cxx:add-item ((layout grid-layout) (item layout-item)

+(define-takes-ownership cxx:add-item ((layout qt:grid-layout) (item qt:layout-item)

-(define-takes-ownership cxx:add-item ((layout grid-layout) (item layout-item)

+(define-takes-ownership cxx:add-item ((layout qt:grid-layout) (item qt:layout-item)

-(define-takes-ownership cxx:add-item ((layout grid-layout) (item layout-item)

+(define-takes-ownership cxx:add-item ((layout qt:grid-layout) (item qt:layout-item)

-(define-takes-ownership cxx:add-item ((layout grid-layout) (item layout-item)

+(define-takes-ownership cxx:add-item ((layout qt:grid-layout) (item qt:layout-item)

-(define-takes-ownership cxx:add-item ((layout layout) (item layout-item))

+(define-takes-ownership cxx:add-item ((layout qt:layout) (item qt:layout-item))

-(define-takes-ownership cxx:register-editor ((factory item-editor-factory)

+(define-takes-ownership cxx:register-editor ((factory qt:item-editor-factory)

-(define-takes-ownership cxx:set-child ((this standard-item) row colum item)

+(define-takes-ownership cxx:set-child ((this qt:standard-item) row colum item)

-(define-takes-ownership cxx:set-child ((this standard-item) row item)

+(define-takes-ownership cxx:set-child ((this qt:standard-item) row item)

-(define-takes-ownership cxx:set-horizontal-header-item ((this standard-item-model)

+(define-takes-ownership cxx:set-horizontal-header-item ((this qt:standard-item-model)

-(define-takes-ownership cxx:set-vertical-header-item ((this standard-item-model)

+(define-takes-ownership cxx:set-vertical-header-item ((this qt:standard-item-model)

-(define-takes-ownership cxx:set-item ((this standard-item-model)

+(define-takes-ownership cxx:set-item ((this qt:standard-item-model)

-(define-takes-ownership cxx:set-item ((this standard-item-model)

+(define-takes-ownership cxx:set-item ((this qt:standard-item-model)

-(define-takes-ownership cxx:set-item-prototype ((this standard-item-model)

+(define-takes-ownership cxx:set-item-prototype ((this qt:standard-item-model)

-(defpackage :qt

- (:use :cl :smoke :cffi :bordeaux-threads :cxx-support :alexandria)

+(defpackage :cl-smoke.qt-impl

+ (:use :cl :smoke :cffi :bordeaux-threads :cxx-support :alexandria))

+

+(defpackage :cl-smoke.qt

+ (:use) ;; do not use :cl to prevent collition with TIME and CHAR

+ (:nicknames :qt)

+ #:make-char

+ #:from-char

+ [_$_]

+ #:disconnect

+ #:disconnect-all

-(in-package :qt)

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

-(defmacro with-painter ((painter paint-device) &body body)

+(defmacro qt:with-painter ((painter paint-device) &body body)

- `(let ((,painter (make-instance 'painter :args (list ,paint-device))))

+ `(let ((,painter (make-instance 'qt:painter :args (list ,paint-device))))

-(in-package :qt)

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

-(defun property (object name)

+(defun qt:property (object name)

- (from-variant (cxx:property object (property-name name))))

+ (qt:from-variant (cxx:property object (property-name name))))

-(defun (setf property) (new-value object name)

+(defun (setf qt:property) (new-value object name)

-(defun remove-property (object name)

+(defun qt:remove-property (object name)

- (setf (property object name) (qt:make-variant)))

+ (setf (qt:property object name) (qt:make-variant)))

-(defun property-p (object name)

+(defun qt:property-p (object name)

- (variant-boundp (cxx:property object (property-name name))))

+ (qt:variant-boundp (cxx:property object (property-name name))))

-(defgeneric class-properties (class)

+(defgeneric qt:class-properties (class)

- (class-properties (find-class symbol))))

+ (qt:class-properties (find-class symbol))))

-(defgeneric class-direct-properties (class)

+(defgeneric qt:class-direct-properties (class)

- (class-direct-properties (find-class symbol))))

+ (qt:class-direct-properties (find-class symbol))))

-(defun properties (object)

+(defun qt:properties (object)

-(in-package :qt)

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

- (text-codec.set-codec-for-cstrings

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

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

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

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

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

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

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

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

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

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

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

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

-(in-package :qt)

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

-(define-smoke-module libsmokeqt

+(define-smoke-module :cl-smoke.qt libsmokeqt

-(in-package :qt)

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

-(defgeneric connect (qsignal slot &optional type)

+(defgeneric qt:connect (qsignal slot &optional type)

-(defgeneric disconnect (qsignal slot)

+(defgeneric qt:disconnect (qsignal slot)

-(defgeneric disconnect-all (qsignal)

+(defgeneric qt:disconnect-all (qsignal)

-(defmethod connect ((qsignal qsignal) (qslot qslot) &optional type)

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

-(defmethod connect ((sender qsignal) (function function) &optional type)

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

-(defgeneric get-slot (receiver name)

+(defgeneric qt:get-slot (receiver name)

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

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

- args)))))

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

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

+ args)))))

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

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

- (let ((normalized-name (cxx:data (meta-object.normalized-signature name))))

+ (let ((normalized-name (cxx:data

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

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

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

-(defun get-signal (sender name)

+(defun qt:get-signal (sender name)

-(define-compiler-macro get-signal (&whole form sender name)

+(define-compiler-macro qt:get-signal (&whole form sender name)

- (let ((normalized-name (cxx:data (meta-object.normalized-signature name))))

+ (let ((normalized-name (cxx:data [_$_]

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

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

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

-(defmethod connect ((qt-signal qt-signal) (qt-slot qt-slot) &optional type)

- (unless (object.connect (qsender qt-signal) (qsignal (name qt-signal))

- (receiver qt-slot) (qslot (name qt-slot))

- (or type +auto-connection+))

+(defmethod qt:connect ((qt-signal qt-signal) (qt-slot qt-slot) &optional type)

+ (unless (qt:object.connect (qsender qt-signal) (qt:qsignal (name qt-signal))

+ (receiver qt-slot) (qt:qslot (name qt-slot))

+ (or type qt:+auto-connection+))

-(defmethod disconnect ((qt-signal qt-signal) (qt-slot qt-slot))

- (unless (object.disconnect (qsender qt-signal) (qsignal (name qt-signal))

- (receiver qt-slot) (qslot (name qt-slot)))

+(defmethod qt:disconnect ((qt-signal qt-signal) (qt-slot qt-slot))

+ (unless (qt:object.disconnect (qsender qt-signal) (qt:qsignal (name qt-signal))

+ (receiver qt-slot) (qt:qslot (name qt-slot)))

-(defmethod disconnect-all ((sender object))

- (unless (object.disconnect sender 0 0 0)

+(defmethod qt:disconnect-all ((sender qt:object))

+ (unless (qt:object.disconnect sender 0 0 0)

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

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

-(defmethod connect ((qt-signal qt-signal) (slot qslot) &optional type)

+(defmethod qt:connect ((qt-signal qt-signal) (slot qslot) &optional type)

-(defmethod connect ((qsignal qsignal) (slot qt-slot) &optional type)

+(defmethod qt:connect ((qsignal qsignal) (slot qt-slot) &optional type)

- (meta-object.connect sender signal-id

+ (qt:meta-object.connect sender signal-id

- (value +auto-connection+)

+ (value qt:+auto-connection+)

- (meta-object.disconnect sender signal-id receiver slot-id))

+ (qt:meta-object.disconnect sender signal-id receiver slot-id))

-(in-package :qt)

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

-(defun qmethod (name)

+(defun qt:qmethod (name)

-(defun qslot (name)

+(defun qt:qslot (name)

-(defun qsignal (name)

+(defun qt:qsignal (name)

-(in-package :qt)

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

-(defclass signal-object (object)

+(defclass signal-object (qt:object)

-(defun make-signal (&rest argument-types)

+(defun qt:make-signal (&rest argument-types)

- (cxx:data (meta-object.normalized-signature slot)))))

+ (cxx:data (qt:meta-object.normalized-signature slot)))))

- (meta-object.activate qsignal (cxx:meta-object qsignal)

+ (qt:meta-object.activate qsignal (cxx:meta-object qsignal)

-(defmethod disconnect-all ((qsignal qsignal))

+(defmethod qt:disconnect-all ((qsignal qsignal))

-(in-package :qt)

-(declaim (optimize (debug 3)))

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

-(defclass qslot (object)

+(defclass qslot (qt:object)

-(defun make-slot (function &optional (arguments nil arguments-p))

+(defun qt:make-slot (function &optional (arguments nil arguments-p))

-(defmacro sender ()

+(defmacro qt:sender ()

- (if (enum= call meta-object.+invoke-meta-method+)

+ (if (enum= call qt:meta-object.+invoke-meta-method+)

- (cxx:data (meta-object.normalized-signature signal)))))

+ (cxx:data (qt:meta-object.normalized-signature signal)))))

-(in-package :qt)

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

-(in-package :qt)

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

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

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

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

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

-(in-package :qt)

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

-(defmacro do-delayed-initialize (&body body)

+(defmacro qt:do-delayed-initialize (&body body)

-(in-package :qt)

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

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

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

- (handler-case (from-variant variant)

+ (handler-case (qt:from-variant variant)

-(defun make-variant (&optional (value nil value-p))

+(defun qt:make-variant (&optional (value nil value-p))

- (make-instance 'variant :args (list value))

- (make-instance 'variant)))

+ (make-instance 'qt:variant :args (list value))

+ (make-instance 'qt:variant)))

-(defun make-char (character)

+(defun qt:make-char (character)

- (1 (make-instance 'char :args (list (aref octets 0))))

- (2 (make-instance 'char :args (list (aref octets 0)

+ (1 (make-instance 'qt:char :args (list (aref octets 0))))

+ (2 (make-instance 'qt:char :args (list (aref octets 0)

-(defun from-char (char)

+(defun qt:from-char (char)

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

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

- (princ (from-char char) stream))))

+ (princ (qt:from-char char) stream))))

-(defun make-lisp-variant (value)

+(defun qt:make-lisp-variant (value)

- (make-instance 'variant :args (list *cxx-lisp-object-metatype*

- object))

+ (make-instance 'qt:variant :args (list *cxx-lisp-object-metatype*

+ object))

-(defun variant-boundp (variant)

+(defun qt:variant-boundp (variant)

- `(,(value (symbol-value (alexandria:symbolicate 'variant.+ type '+)))

+ `(,(value (symbol-value [_$_]

+ (let ((*package* (find-package :cl-smoke.qt)))

+ (alexandria:symbolicate 'variant.+ type '+))))

-(defun from-variant (variant)

+(defun qt:from-variant (variant)

- (#.(value variant.+invalid+)

+ (#.(value qt:variant.+invalid+)

-(defmethod value ((variant variant))

+(defmethod qt:value ((variant qt:variant))

- (from-variant variant))

+ (qt:from-variant variant))

-(defmethod (setf value) (new-value (variant variant))

- (cxx:operator= variant (make-variant new-value))

+(defmethod (setf qt:value) (new-value (variant qt:variant))

+ (cxx:operator= variant (qt:make-variant new-value))