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.

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

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

@@ -11,7 +11,7 @@

(:default-initargs :type "txt"))

(defclass sysdef.cmake:cmake-library (component)

- ())

+ ((package :initarg :package)))

;;; end SYSDEF.CMAKE

(in-package :sysdef-user)

@@ -34,7 +34,7 @@

("lib" module

(:needs "package")

(:components

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

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

("CMakeLists.txt" static-file)

("qt-smoke.cpp" static-file)

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

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

@@ -1,4 +1,4 @@

-(in-package :qt)

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

(declaim (optimize (debug 3)))

@@ -7,15 +7,15 @@

(defvar *exec-p* t

"Run exec if true and not otherwise.")

-(defun app ()

+(defun qt:app ()

"Returns the APPLICATION (or CORE-APPLICATION) object,

within a WITH-APP."

- (assert (app-p)

+ (assert (qt:app-p)

(*app*)

"No application.")

*app*)

-(defun app-p ()

+(defun qt:app-p ()

"Returns t when the APPLICATION object exists and nil otherwise."

(boundp '*app*))

@@ -24,7 +24,7 @@

(argc (null-pointer)))

(declare (cffi:foreign-pointer argv argc))

(defun ensure-app (&optional

- (application 'application)

+ (application 'qt:application)

(args #+sbcl sb-ext:*posix-argv*

#+ccl ccl:*command-line-argument-list*

#-(or sbcl ccl) (list (lisp-implementation-type))))

@@ -36,17 +36,19 @@

(assert (not (null args))

(args)

"No program name supplied.")

- (if (app-p)

+ (if (qt:app-p)

(progn

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

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

(application)

"The existing application object ~A is

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

- (values (app) nil))

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

+ (values (qt:app) nil))

(progn

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

(foreign-free argv)

(foreign-free argc)

@@ -56,22 +58,22 @@

(tg:cancel-finalization app)

(values app t)))))

(defun kill-app ()

- (when (typep (app) 'application)

- (application.close-all-windows)

+ (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 (application.all-widgets) do

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

(trivial-garbage:cancel-finalization widget)))

- (cxx:quit (app))

+ (cxx:quit (qt:app))

(setf *widgets* nil)

;; Call the destructer; -> destructed callback is called,

;; (~QApplication() is virtual) which takes care of cleanup

;; on the Lisp side.

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

(makunbound '*app*)))

(defmacro with-application ((ensure-app remove-app) &body body)

@@ -82,7 +84,7 @@

(when ,cleanup-p

,remove-app)))))

-(defmacro with-app (&body body)

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

"Ensures that a APPLICATION instance exists,

evaluates BODY and executes the APPLICATION instance after BODY.

The instance can be accessed with:

@@ -92,20 +94,20 @@

When a APPLICATION was created, it will be deleted when returning

from BODY."

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

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

,@body))

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

,@body))

-(defun exec (&rest widgets)

+(defun qt:exec (&rest widgets)

"Executes APP."

(setf *widgets* (append widgets *widgets*))

(when *exec-p*

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

- (cxx:quit (app))

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

+ (cxx:quit (qt:app))

(invoke-restart (find-restart 'continue)))

:report-function

#'(lambda (stream)

@@ -113,6 +115,6 @@

:test-function

#'(lambda (condition)

(declare (ignore condition))

- (and (app-p)

+ (and (qt:app-p)

(find-restart 'continue)))))

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

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

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

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

@@ -1,6 +1,6 @@

-(in-package :qt)

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

-(defun tr (message &optional context)

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

"Returns the translated MESSAGE for CONTEXT or

a string STRING-EQUAL to MESSAGE when no translation was found.

@@ -14,13 +14,13 @@

,@body)

(cxx:remove-translator (qt:app) ,translator)))

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

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

"Loads the translations in the BASE-NAME_LANGCODE.qm file;

searching PATHS.

Must be in a WITH-APP."

(let ((translator (gensym)))

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

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

(unless

(find-if #'(lambda (path)

(cxx:load ,translator

@@ -33,12 +33,12 @@

(with-installed-translator ,translator

,@body))))

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

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

"Loads the translations for the Qt library.

Must be in a WITH-APP."

(let ((translator (gensym)))

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

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

(unless (cxx:load ,translator (format nil "qt_~A"

(cxx:name (qt:locale.system)))

(qt:library-info.location qt:library-info.+translations-path+))

@@ -46,7 +46,7 @@

(with-installed-translator ,translator

,@body))))

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

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

"Searches the file NAME in PATHS and returns its path."

(let ((file-path (find-if #'(lambda (path)

(probe-file (merge-pathnames name path)))

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

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

@@ -1,4 +1,4 @@

-(in-package :qt)

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

(defvar *cxx-lisp-objects* (smoke::make-synchronized-hash-table)

"Objects that are currently passed in a C++ class.")

@@ -33,7 +33,7 @@

(setf *cxx-lisp-object-metatype*

(qt-smoke-setup-lisp-object (callback destruct-cxx-lisp-object)))

(assert (>= *cxx-lisp-object-metatype*

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

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

(*cxx-lisp-object-metatype*)

"setup of lisp-object failed"))

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

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

@@ -1,4 +1,4 @@

-(in-package :qt)

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

(defmacro define-qlist-wrapper (type-name &optional c-name)

(let* ((c-name (or c-name type-name))

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

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

@@ -1,4 +1,4 @@

-(in-package :qt)

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

(cffi:defcenum qt-msg-type

(:debug-message)

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

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

@@ -1,15 +1,15 @@

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

"No OBJECT.STATIC-META-OBJECT (r558420)."

(cxx:meta-object object))

(defmethod cxx:static-meta-object ((class cxx:class))

(cxx:static-meta-object (smoke::find-smoke-class class))))

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

(not (subtypep class (find-class 'cxx:class))))

(format nil "~@[~A~%~]Properties:~%~T~{~<~%~T~0,75:; ~(~A~)~>~}

@@ -17,12 +17,12 @@

~{~T~A~%~}

Slots:

~{~T~A~%~}"

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

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

(sort (class-signals class) #'string<=)

(sort (class-slots class) #'string<=))

(call-next-method)))

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

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

(if (or (not (slot-boundp object 'pointer))

(null-pointer-p (pointer object)))

(call-next-method)

@@ -35,27 +35,43 @@

collect (cxx:method meta-object index)))

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

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

(mapcar #'cxx:signature

(remove-if-not #'(lambda (m) (enum= qt:meta-method.+signal+

(cxx:method-type m)))

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

(mapcar #'cxx:signature

(remove-if-not #'(lambda (m) (enum= qt:meta-method.+slot+

(cxx:method-type m)))

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

+

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

+(defmethod initialize-instance :after ((object qt:object)

&key pointer &allow-other-keys)

"Registers the object to the parent when a parent was set in the constructor

and the objects metaclass is SMOKE-WRAPPER-CLASS."

@@ -64,9 +80,9 @@

(error "Object ~A has not been constructed" object))

(when (and (null pointer)

(not (null-pointer-p (smoke::pointer 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))))

(define-condition wrapper-gc (storage-condition)

((class-name :initarg :class-name

@@ -95,7 +111,7 @@

(with-output-to-string (stream)

(print-object object stream)))

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

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

"Delete the qt:object OBJECT,

by calling cxx:delete-later iff it has no parent."

(let ((pointer (pointer object))

@@ -121,6 +137,7 @@

(smoke::report-finalize-error condition "qt:object"

(name class) pointer)))))))

+

;;;

;;; The event-notify callback get called by QCoreApplication,

;;; on notification of an event.

@@ -140,19 +157,22 @@

((data :pointer))

(declare (optimize (speed 3)))

(let ((receiver (smoke::get-object (cffi:mem-aref data :pointer 0)))

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

+ (event (make-instance 'qt:event

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

(enum-case (cxx:type event)

- (event.+child-added+

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

+ (qt:event.+child-added+

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

:pointer

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

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

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

(when (smoke::has-pointer-p (smoke::pointer (cxx:child child-event)))

- (assert receiver)

+ (unless receiver

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

(smoke::transfer-ownership-to (cxx:child child-event) receiver))))

- (event.+child-removed+

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

+ (qt:event.+child-removed+

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

:pointer (smoke::upcast event

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

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

;; We receive child removed events for any QObject, wherter

;; it was construted by Smoke or not. Only take ownership of objects

;; that have been constructed by Smoke.

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

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

@@ -1,4 +1,4 @@

-(in-package :qt)

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

(defun cxx:= (object &rest more-objects)

(if (null more-objects)

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

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

@@ -1,7 +1,7 @@

-(in-package :qt)

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

;; undo-stack

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

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

undo-command)

@@ -23,46 +23,46 @@

;; AbstractFileEngine::beginEntryList return value

;; grid-layout

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

row column)

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)

row column row-span)

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)

row column row-span colum-span)

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)

row column row-span colum-span aligment)

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

item)

;; QIcon::QIcon(QIconEngine* engine)

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

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

type creator)

creator)

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

item)

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

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

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)

column item)

item)

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

row item)

item)

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

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

row column item)

item)

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

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

row item)

item)

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

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

item)

item)

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

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

@@ -1,5 +1,9 @@

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

(:export #:app

#:app-p

#:exec

@@ -26,6 +30,9 @@

#:class-properties

#:class-direct-properties

+ #:make-char

+ #:from-char

+

#:from-variant

#:make-variant

#:make-lisp-variant

@@ -35,6 +42,8 @@

#:search-file

#:connect

+ #:disconnect

+ #:disconnect-all

#:get-slot

#:get-signal

#:make-slot

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

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

@@ -1,12 +1,12 @@

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

"Binds a PAINTER instance for PAINT-DEVICE to PAINTER

during the evaulation of BODY.

Makes sure the painter ends after BODY; thus prevening problems with

still active and not yet garbage collected painters."

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

+ `(let ((,painter (make-instance 'qt:painter :args (list ,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:57.000000000 +0100

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

@@ -1,4 +1,4 @@

-(in-package :qt)

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

(defun reverse-lispify (symbol)

"Converts the name of symbol to C++ style."

@@ -10,24 +10,24 @@

(string name)

(symbol (reverse-lispify name))))

-(defun property (object name)

+(defun qt:property (object name)

"Returns the property NAME of OBJECT."

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

(cxx:set-property object (property-name name)

(make-instance 'qt:variant

:args (list new-value)))

new-value)

-(defun remove-property (object name)

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

"Removes the property NAME from OBJECT."

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

"Returns T when NAME is a property of OBJECT and NIL otherwise."

- (variant-boundp (cxx:property object (property-name 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."

@@ -35,25 +35,25 @@

below (cxx:property-count meta-object)

collect (smoke::lispify (cxx:name (cxx:property meta-object index)))))

-(defgeneric class-properties (class)

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

(:method ((symbol symbol))

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

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

-(defgeneric class-direct-properties (class)

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

(:documentation "Returns a list of the properties of CLASS.")

(:method ((class class))

(meta-object-properties (cxx:static-meta-object class) nil))

(:method ((symbol symbol))

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

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

(defun dynamic-properties (object)

(map 'list (compose #'smoke::lispify #'cxx:data)

(cxx:dynamic-property-names object)))

-(defun properties (object)

+(defun qt:properties (object)

"Returns a list of the properties of OBJECT."

(nconc (dynamic-properties object)

(meta-object-properties (cxx:meta-object object))))

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

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

@@ -1,4 +1,4 @@

-(in-package :qt)

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

(defcfun qt-smoke-string-to-qstring :pointer

(data :string)

@@ -28,26 +28,26 @@

;;; (setq slime-net-coding-system 'utf-8-unix)

;;; to .emacs helps.

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

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

(define-parse-method qstring ()

(make-instance 'qstring))

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

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

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

"data")))

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

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

(values ;; Discarge 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))

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

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

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

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

@@ -59,7 +59,7 @@

(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 'qt::qstring)

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

nil))))

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

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

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

@@ -25,9 +25,9 @@

;;; do so. If you do not wish to do so, delete this exception statement

;;; from your version.

-(in-package :qt)

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

-(define-smoke-module libsmokeqt

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

(*qt-smoke* "qt_Smoke")

(init-qt-smoke "init_qt_Smoke"))

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

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

@@ -1,12 +1,12 @@

-(in-package :qt)

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

-(defgeneric connect (qsignal slot &optional type)

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

(:documentation "Connects a signal to a slot."))

-(defgeneric disconnect (qsignal slot)

+(defgeneric qt:disconnect (qsignal slot)

(:documentation "Disconnects a connection."))

-(defgeneric disconnect-all (qsignal)

+(defgeneric qt:disconnect-all (qsignal)

(:documentation "Disconnects all connections of QSIGNAL."))

(defun check-argument-types (signal-arguments slot-arguments)

@@ -16,7 +16,7 @@

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

;;FIXME check argument-types

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

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

(assert (or (slot-boundp (signal-object qsignal) 'argument-types)

(slot-boundp qslot 'arguments))

((slot-value (signal-object qsignal) 'argument-types)

@@ -37,7 +37,7 @@

(types (arguments qslot)))

(cerror "Failed to connect ~S to ~S." qsignal qslot)))

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

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

(let ((slot (make-instance 'qslot

:args (list (signal-object sender))

:slot-function function)))

@@ -62,63 +62,65 @@

:reader receiver))

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

-(defgeneric get-slot (receiver name)

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

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

(:method (receiver name)

(make-instance 'qt-slot :receiver receiver :name name))

(:method (receiver (function function))

"Returns a slot for RECEIVER that calls function

with RECEIVER as the first argument."

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

(cxx:set-parent slot receiver)

slot)))

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

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

"Normalize the slot name."

(if (stringp name)

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

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

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

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

form

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

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

form))

-(defun get-signal (sender name)

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

"Returns the signal NAME of SENDER."

(make-instance 'qt-signal :sender sender :name name))

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

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

"Normalize the signal name."

(if (stringp name)

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

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

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

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

form

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

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

form))

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

(cerror "Failed to connect ~A ~A to ~A ~A."

(qsender qt-signal) (name qt-signal)

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

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

(cerror "Failed to disconnect ~A ~A from ~A ~A."

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

(qsender qt-signal) (name qt-signal))))

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

(cerror "Failed to disconnect everything connected to ~A."

sender)))

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

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

;; Set the sender as the slots parent,

@@ -141,7 +143,7 @@

(cerror "Ignore" "Failed to connect the signal ~S of ~S to the function ~S."

(name qt-signal) (qsender qt-signal) function))))

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

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

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

(if (slot-boundp slot 'arguments)

(check-argument-types (method-arguments-type (cxx:meta-object

@@ -159,7 +161,7 @@

(cerror "Ignore" "Failed to connect the signal ~S of ~S to the slot ~S."

(name qt-signal) (qsender qt-signal) slot))))

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

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

(let ((slot-id (find-slot-id (receiver slot) (name slot))))

(if (slot-boundp (signal-object qsignal) 'argument-types)

(check-argument-types (argument-types (signal-object slot))

@@ -177,12 +179,12 @@

(defun connect-id (sender signal-id receiver slot-id type types)

- (meta-object.connect sender signal-id

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

receiver slot-id

(if (null type)

- (value +auto-connection+)

+ (value qt:+auto-connection+)

(value type))

types))

(defun disconnect-id (sender signal-id receiver slot-id)

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

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

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

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

@@ -1,4 +1,4 @@

-(in-package :qt)

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

(defclass funcallable-smoke-class (closer-mop:funcallable-standard-class

@@ -18,17 +18,17 @@

((#\0 #\1 #\2) t)

(t nil))))

-(defun qmethod (name)

+(defun qt:qmethod (name)

"Equivalent of the METHOD(a) CPP macro."

(assert (not (munged-name-p name)))

(format nil "0~A" name))

-(defun qslot (name)

+(defun qt:qslot (name)

"Equivalent of the SLOT(a) CPP macro."

(assert (not (munged-name-p name)))

(format nil "1~A" name))

-(defun qsignal (name)

+(defun qt:qsignal (name)

"Equivalent of the SIGNAL(a) CPP macro."

(assert (not (munged-name-p name)))

(format nil "2~A" name))

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

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

@@ -1,4 +1,4 @@

-(in-package :qt)

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

(declaim (optimize (debug 3)))

(defclass qsignal-mixin ()

@@ -12,7 +12,7 @@

See:

http://www.sbcl.org/manual/Metaobject-Protocol.html#index-validate_002dsuperclass-164"))

-(defclass signal-object (object)

+(defclass signal-object (qt:object)

((argument-types :accessor argument-types

:initarg :argument-types

:documentation "List of the argument types"))

@@ -30,7 +30,7 @@

The argument types can be supplied by the :METHOD-TYPES initarg.

Calling an instance emits the signal."))

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

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

"Returns a funcallable signal. When ARGUMENT-TYPES are not

specified, they are determined when the first connection is made."

(if argument-types

@@ -60,7 +60,7 @@

slot)))

(when (< id 0)

(setf id (cxx:index-of-slot (cxx:meta-object receiver)

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

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

(when (< id 0)

(error "No slot ~S for class ~S.

The valid slots are: ~{~<~%~T~0,75:;~A ~>~}"

@@ -113,11 +113,11 @@

'smoke::smoke-stack-item 'smoke::voidp))))

(setf (mem-aref args :pointer 0)

(null-pointer))

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

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

(id qsignal)

args)))))

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

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

(unless (disconnect-id (signal-object qsignal)

(id (signal-object qsignal))

0

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

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

@@ -1,7 +1,6 @@

-(in-package :qt)

-(declaim (optimize (debug 3)))

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

-(defclass qslot (object)

+(defclass qslot (qt:object)

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

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

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

@@ -10,7 +9,7 @@

(:metaclass cxx:class)

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

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

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

"Returns a slot that calls FUNCTION when it receives a signal."

(if arguments-p

(make-instance 'qslot

@@ -24,7 +23,7 @@

(defparameter *sender* nil "The sender of the signal.")

(defparameter *this* nil "The slot that is invoked.")

-(defmacro sender ()

+(defmacro qt:sender ()

"Returns the sender that invoked the slot."

`*sender*)

@@ -34,7 +33,7 @@

(let ((id (call-next-method)))

(if (< id 0)

id

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

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

(progn

(ccase id

(0 (let ((*sender* (cxx:sender slot))

@@ -55,7 +54,7 @@

signal)))

(when (< id 0)

(setf id (cxx:index-of-signal (cxx:meta-object sender)

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

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

(when (< id 0)

(error "No signal ~S for class ~S."

signal (class-of sender)))

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

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

@@ -1,4 +1,4 @@

-(in-package :qt)

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

(defun find-type (name &optional start end)

(smoke::make-smoke-type *qt-smoke* (subseq name start end)))

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

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

@@ -1,4 +1,4 @@

-(in-package :qt)

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

(defcfun qt-smoke-string-list-size :int

(string-list :pointer))

@@ -52,9 +52,9 @@

(defun coerce-string-list (list)

(make-cleanup-pointer

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

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

#'(lambda (pointer)

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

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

nil))))

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

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

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

@@ -1,4 +1,4 @@

-(in-package :qt)

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

(defclass single-shot-timer (qt:object)

((function :initarg :function

@@ -18,7 +18,7 @@

(cxx:start-timer timer (floor timeout 100)))

(push timer *single-shot-timers*)))

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

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

"Run body when the event loop starts.

http://techbase.kde.org/Development/Tutorials/Common_Programming_Mistakes#Delayed_Initialization"

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

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

@@ -1,6 +1,6 @@

-(in-package :qt)

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

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

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

"Print the type and value of the variant."

(if (or (not (slot-boundp variant 'pointer))

(null-pointer-p (pointer variant)))

@@ -8,22 +8,22 @@

(print-unreadable-object (variant stream :type t :identity t)

(format stream "~A~@[ ~S~]"

(cxx:type-name variant)

- (handler-case (from-variant variant)

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

(error () nil))))))

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

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

"Returns a new VARIANT containing a C++ version of VALUE

or an empty variant when VALUE is not specified."

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

"Returns a char for a lisp CHARACTER."

(let ((octets (babel:string-to-octets (string character))))

(case (length octets)

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

(aref octets 1))))

(t (error "qt:char requires the character ~A to be encoded

in one or two octets, but it is using ~A."

@@ -33,7 +33,7 @@

(or (cxx:is-high-surrogate char)

(cxx:is-low-surrogate char)))

-(defun from-char (char)

+(defun qt:from-char (char)

"Returns the lisp character represented by CHAR."

(assert (not (surrogate-p char))

(char)

@@ -46,30 +46,30 @@

(char-code (cxx:row char)))))

0))

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

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

(if (or (null-pointer-p (pointer char))

(surrogate-p char))

(call-next-method)

(print-unreadable-object (char stream :type t)

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

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

;; FIXME include in MAKE-VARIANT?

-(defun make-lisp-variant (value)

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

"Returns a new VARIANT that wraps VALUE.

The variant contains the actual Lisp object

and not its C++ value like in MAKE-VARIANT."

(let ((object (make-cxx-lisp-object value)))

(unwind-protect

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

- object))

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

+ object))

(free-cxx-lisp-object object))))

(defcfun qt-smoke-lisp-object-value :pointer

(variant :pointer))

-(defun variant-boundp (variant)

+(defun qt:variant-boundp (variant)

"Returns true when VARIANT is valid (has a value) and false otherwise."

(cxx:is-valid variant))

@@ -78,14 +78,16 @@

,@(loop for type in types collect

(if (symbolp type)

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

+ `(,(value (symbol-value

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

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

(,(intern (format nil "TO-~A" type) :cxx) ,variant))

type))))

-(defun from-variant (variant)

+(defun qt:from-variant (variant)

"Returns the value of VARIANT."

(variant-conversions (variant)

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

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

(cerror "Return (VALUES)" "Type of variant ~A is invalid." variant)

(values))

bit-array bool byte-array

@@ -107,10 +109,10 @@

(free-cxx-lisp-object lisp-object)

value))))

-(defmethod value ((variant variant))

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

"Returns the value of 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))

new-value)