Sun Mar 13 20:40:35 CET 2011 Tobias Rautenkranz * Fix loading on OSX. Thanks to Elliott Slaughter Sat Apr 3 14:34:21 CEST 2010 Tobias Rautenkranz * Account for possible lisp-object metatype id change when loading an image. Sat Feb 20 22:04:46 CET 2010 Tobias Rautenkranz * cleanup Sat Feb 20 22:02:38 CET 2010 Tobias Rautenkranz * Make qt:application cleanup more stable Sat Feb 20 22:00:30 CET 2010 Tobias Rautenkranz * support all from qt:variant conversions. Mon Feb 15 16:33:05 CET 2010 Tobias Rautenkranz * Build a shared library not a module. Fixes a build error on OS X. Thu Feb 4 16:06:38 CET 2010 Tobias Rautenkranz * Test building libclsmokeqtcore Thu Feb 4 10:22:53 CET 2010 Tobias Rautenkranz * Add qvector.cpp Sat Jan 30 16:40:15 CET 2010 Tobias Rautenkranz * Get the QList size using Lisp instead of an external C function. Tue Jan 26 17:19:51 CET 2010 Tobias Rautenkranz * Fix define-qlist-wrapper usage for other modules. (i.e. qt.gui) Mon Jan 25 20:07:22 CET 2010 Tobias Rautenkranz * Export delete-app since other modules (qt.gui) might like to add methods to it. Mon Jan 25 19:53:36 CET 2010 Tobias Rautenkranz * Use ELT instead of AREF for sequences in vector translations. Mon Jan 25 19:45:04 CET 2010 Tobias Rautenkranz * Allow other modules to define QList conversions. Mon Jan 25 19:43:56 CET 2010 Tobias Rautenkranz * Fix error reporting on signal-slot connection failure. Sat Jan 23 23:17:35 CET 2010 Tobias Rautenkranz * QVector translation diff -rN -u old-qt.core/cl-smoke.qt.core.asd new-qt.core/cl-smoke.qt.core.asd --- old-qt.core/cl-smoke.qt.core.asd 2014-11-21 23:55:19.000000000 +0100 +++ new-qt.core/cl-smoke.qt.core.asd 2014-11-21 23:55:19.000000000 +0100 @@ -19,6 +19,7 @@ (:file "application" :depends-on ("qt.core" "properties")) (:file "qstring" :depends-on ("qt.core")) (:file "list" :depends-on ("qt.core")) + (:file "vector" :depends-on ("qt.core" "signal-slot")) (:file "msg-handler" :depends-on ("lib" "qt.core")) (:file "timer" :depends-on ("qt.core")) (:file "i18n" :depends-on ("qt.core")) diff -rN -u old-qt.core/src/application.lisp new-qt.core/src/application.lisp --- old-qt.core/src/application.lisp 2014-11-21 23:55:19.000000000 +0100 +++ new-qt.core/src/application.lisp 2014-11-21 23:55:19.000000000 +0100 @@ -57,12 +57,12 @@ (defgeneric delete-app (application) (:method (application) - (cxx:quit application) - ;; Call the destructor; -> destructed callback is called, - ;; (~QApplication() is virtual) which takes care of cleanup on the - ;; Lisp side. - (smoke::delete-pointer (smoke:pointer application) (class-of application)) - (setf (slot-value application 'pointer) (null-pointer)) + (unless (null-pointer-p (smoke:pointer application)) + (cxx:quit application) + ;; Call the destructor; -> destructed callback is called, + ;; (~QApplication() is virtual) which takes care of cleanup on the + ;; Lisp side. + (smoke::delete-pointer (smoke:pointer application) (class-of application))) (makunbound '*app*))) (defun kill-app () diff -rN -u old-qt.core/src/event.lisp new-qt.core/src/event.lisp --- old-qt.core/src/event.lisp 2014-11-21 23:55:19.000000000 +0100 +++ new-qt.core/src/event.lisp 2014-11-21 23:55:19.000000000 +0100 @@ -4,7 +4,7 @@ (enum-case (cxx:type event) ((qt:event.+child-added+ qt:event.+child-removed+ qt:event.+child-polished+) - (setf (slot-value event 'smoke::pointer) - (smoke::upcast event (find-class 'qt:child-event))) + (setf (slot-value event 'pointer) + (upcast event (find-class 'qt:child-event))) (change-class event 'qt:child-event))) event) diff -rN -u old-qt.core/src/lib/CMakeLists.txt new-qt.core/src/lib/CMakeLists.txt --- old-qt.core/src/lib/CMakeLists.txt 2014-11-21 23:55:19.000000000 +0100 +++ new-qt.core/src/lib/CMakeLists.txt 2014-11-21 23:55:19.000000000 +0100 @@ -8,8 +8,10 @@ set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -fvisibility=hidden -fvisibility-inlines-hidden") endif(CXX_VISIBILITY) -set(QT_SMOKE_SOURCES qt_smoke.cpp qstring.cpp qstringlist.cpp lisp_object.cpp qlist.cpp) -add_library(clsmokeqtcore MODULE ${QT_SMOKE_SOURCES}) +set(QT_SMOKE_SOURCES qt_smoke.cpp + qstring.cpp qstringlist.cpp lisp_object.cpp qlist.cpp qvector.cpp) + +add_library(clsmokeqtcore SHARED ${QT_SMOKE_SOURCES}) target_link_libraries(clsmokeqtcore ${QT_LIBRARIES}) set_target_properties(clsmokeqtcore PROPERTIES diff -rN -u old-qt.core/src/lib/qlist.cpp new-qt.core/src/lib/qlist.cpp --- old-qt.core/src/lib/qlist.cpp 2014-11-21 23:55:19.000000000 +0100 +++ new-qt.core/src/lib/qlist.cpp 2014-11-21 23:55:19.000000000 +0100 @@ -12,5 +12,4 @@ DEFINE_QLIST_WRAPPER_PTR(void) DEFINE_QLIST_WRAPPER(QByteArray) - } // extern "C" diff -rN -u old-qt.core/src/lib/qlist.h new-qt.core/src/lib/qlist.h --- old-qt.core/src/lib/qlist.h 2014-11-21 23:55:19.000000000 +0100 +++ new-qt.core/src/lib/qlist.h 2014-11-21 23:55:19.000000000 +0100 @@ -32,12 +32,6 @@ /** @internal * size, free and make_list. */ #define DEFINE_QLIST_WRAPPER_ALL_PART(NAME, TYPE) \ -CL_SMOKE_QT_EXPORT int \ -cl_smoke_list_ ## NAME ## _size(const void* list) \ -{ \ - return static_cast*>(list)->size(); \ -} \ -\ CL_SMOKE_QT_EXPORT void \ cl_smoke_free_list_ ## NAME (void* list) \ { \ diff -rN -u old-qt.core/src/lib/qvector.cpp new-qt.core/src/lib/qvector.cpp --- old-qt.core/src/lib/qvector.cpp 1970-01-01 01:00:00.000000000 +0100 +++ new-qt.core/src/lib/qvector.cpp 2014-11-21 23:55:19.000000000 +0100 @@ -0,0 +1,27 @@ +#include "cl_smoke_qt.h" + +#include +#include + +extern "C" { + +/** Construct a 0 sized QVector. + * Since the QVectorData is QVectorData::shared_null the template type does not matter. + * @return A null QVector + */ +CL_SMOKE_QT_EXPORT void* +cl_smoke_make_qvector() +{ + return new QVector(); +} + +/** Deletes a null QVector. i.e.: The QVectorData pointer is 0. + * @param qvector a null QVector + */ +CL_SMOKE_QT_EXPORT void +cl_smoke_delete_qvector(void* qvector) +{ + delete static_cast*>(qvector); +} + +} // extern "C" diff -rN -u old-qt.core/src/list.lisp new-qt.core/src/list.lisp --- old-qt.core/src/list.lisp 2014-11-21 23:55:19.000000000 +0100 +++ new-qt.core/src/list.lisp 2014-11-21 23:55:19.000000000 +0100 @@ -1,72 +1,117 @@ (in-package :cl-smoke.qt.core) -(defmacro define-qlist-wrapper (type-name element-type &optional c-name) - (let* ((c-name (or c-name type-name)) - (type (string-upcase c-name)) - (list-type (symbolicate 'qlist- type))) - `(progn - (defcfun ,(concatenate 'string "cl_smoke_list_" c-name "_size") :int - "Returns the size of LIST." - (list :pointer)) - (defcfun ,(concatenate 'string "cl_smoke_free_list_" c-name) :void - "Frees LIST." - (list :pointer)) - (defcfun ,(concatenate 'string "cl_smoke_make_list_" c-name) :pointer - "Makes a list.") - (defcfun ,(concatenate 'string "cl_smoke_list_" c-name "_at") :pointer - "Returns the a newly constructed copy of the element at position AT of LIST." - (list :pointer) - (index :int)) - (defcfun ,(concatenate 'string "cl_smoke_list_" c-name "_append") :pointer - "Appends NEW-ELEMENT to LIST." - (list :pointer) - (new-element :pointer)) - ;; To Lisp - ,@(loop for type-name in (ensure-list type-name) collect - `(defun ,(symbolicate 'from- type-name) (list-pointer) - (let ((vector (make-array (,(symbolicate 'cl-smoke-list- - type '-size) - list-pointer)))) - (dotimes (index (length vector) vector) - (setf (aref vector index) - ;; FIXME the returned object is not wrapped by Smoke - ;; -> change this? - (smoke::object-to-lisp - (,(symbolicate 'cl-smoke-list- - type '-at) - list-pointer index) - (smoke::make-smoke-type *smoke-module* - ,type-name))))))) - ,@(loop for type-name in (ensure-list type-name) collect - `(define-to-lisp-translation - (,(format nil "const QList<~A>&" type-name) - ,(format nil "QList<~A>" type-name)) - ,(symbolicate 'from- type-name) - ,(symbolicate 'cl-smoke-free-list- type))) - ;; From Lisp - (defun ,(symbolicate 'coerce- list-type) (list) - (let ((qlist (,(symbolicate 'cl-smoke-make-list- type)))) - (loop for element across list do - (,(symbolicate 'cl-smoke-list- type '-append) - qlist (pointer (make-instance ',element-type :args (list element))))) - (make-cleanup-pointer - qlist - (function ,(symbolicate 'cl-smoke-free-list- type))))) - (defun ,(symbolicate list-type '-p) (list) - (every #'(lambda (element) - (typep element ',element-type)) - list)) - ,@(loop for type-name in (ensure-list type-name) collect - `(define-from-lisp-translation (,(format nil "const QList<~A>&" type-name) - ,(format nil "QList<~A>" type-name)) - ;; FIXME allow sequence - (and (vector ,element-type) - (satisfies ,(symbolicate list-type '-p))) - ,(symbolicate 'coerce- list-type)))))) +(defbitfield qlist-data-flags + :sharable) + +(defcstruct qlist-data + (ref :char :count #.(class-size (find-class 'qt:basic-atomic-int))) + (alloc :int) + (begin :int) + (end :int) + (flags qlist-data-flags) + (array :pointer)) + +(defcstruct qlist + (data (:pointer qlist-data))) + +(defun qlist-size (qlist) + (let ((data (foreign-slot-value qlist 'qlist 'data))) + (- (foreign-slot-value data 'qlist-data 'end) + (foreign-slot-value data 'qlist-data 'begin)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (macrolet ((c-name (name) + `(nth-value 1 ,name)) + (fun-names-let (name-pre-post-fixes &body body) + `(flet (,@(mapcar + #'(lambda (npp) + `(,(first npp) (type) + (values + (intern (string-upcase + (concatenate 'string + ,(second npp) + type + ,(third npp))) + ,*package*) + (concatenate 'string + (substitute #\_ #\- + ,(second npp)) + type + (substitute #\_ #\- + ,(third npp)))))) + name-pre-post-fixes)) + ,@body))) + (fun-names-let ((list-free "cl-smoke-free-list-") + (list-make "cl-smoke-make-list-") + (list-at "cl-smoke-list-" "-at") + (list-append "cl-smoke-list-" "-append")) + (defmacro define-qlist-wrapper (type-name element-type &optional (c-name nil c-name-p) + &key def-cfuns) + (let* ((c-name (or c-name type-name)) + (type c-name) + (lisp-type (symbolicate 'qlist- element-type))) + `(progn + ,(when (or (not c-name-p) def-cfuns) + `(progn + (defcfun ,(c-name (list-free type)) :void + "Frees LIST." + (list :pointer)) + (defcfun ,(c-name (list-make type)) :pointer + "Makes a list.") + (defcfun ,(c-name (list-at type)) :pointer + "Returns the a newly constructed copy of the element at + position AT of LIST." + (list :pointer) + (index :int)) + (defcfun ,(c-name (list-append type)) :pointer + "Appends NEW-ELEMENT to LIST." + (list :pointer) + (new-element :pointer)))) + ;; To Lisp + ,@(loop for type-name in (ensure-list type-name) collect + `(defun ,(symbolicate 'from-list- type-name) (list-pointer) + (declare (optimize (speed 3))) + (let ((vector (make-array (qlist-size + list-pointer)))) + (dotimes (index (length vector) vector) + (setf (elt vector index) + ;; FIXME the returned object is not wrapped by Smoke + ;; -> change this? + (object-to-lisp + (,(list-at type) + list-pointer index) + (make-smoke-type ,(symbolicate '*smoke-module*) + ,type-name))))))) + ,@(loop for type-name in (ensure-list type-name) collect + `(define-to-lisp-translation + (,(format nil "const QList<~A>&" type-name) + ,(format nil "QList<~A>" type-name)) + ,(symbolicate 'from-list- type-name) + ,(list-free type))) + ;; From Lisp + (defun ,(symbolicate 'coerce- lisp-type) (list) + (let ((qlist (,(list-make type)))) + (loop for element across list do + (,(list-append type) + qlist (pointer (make-instance ',element-type :args (list element))))) + (make-cleanup-pointer + qlist + (function ,(list-free type))))) + (defun ,(symbolicate lisp-type '-p) (list) + (every #'(lambda (element) + ;(typep element ',element-type)) + (typep element (find-class ',element-type))) + list)) + ,@(loop for type-name in (ensure-list type-name) collect + `(define-from-lisp-translation (,(format nil "const QList<~A>&" type-name) + ,(format nil "QList<~A>" type-name)) + ;; FIXME allow sequence + (and (vector );,element-type) + (satisfies ,(symbolicate lisp-type '-p))) + ,(symbolicate 'coerce- lisp-type))))))))) -;; FIXME it would be nice to have QList as fallback for any -;; list we can not convert otherwise. e.g.: '("a" 1) (define-qlist-wrapper "QVariant" qt:variant) -(define-qlist-wrapper ("QObject*" "QWidget*") qt:object "void") (define-qlist-wrapper "QByteArray" qt:byte-array) + +(define-qlist-wrapper "QObject*" qt:object "void" :def-cfuns t) diff -rN -u old-qt.core/src/operator.lisp new-qt.core/src/operator.lisp --- old-qt.core/src/operator.lisp 2014-11-21 23:55:19.000000000 +0100 +++ new-qt.core/src/operator.lisp 2014-11-21 23:55:19.000000000 +0100 @@ -6,9 +6,9 @@ (every #'(lambda (o) ;; Consider Class::operator== and operator== ;; FIXME integrate this in the overload resolution - (if (typep object 'smoke::smoke-standard-object) + (if (typep object 'smoke-standard-object) (handler-case (qt:operator== object o) - (smoke::no-applicable-cxx-method () + (no-applicable-cxx-method () (cxx:operator== object o))) (qt:operator== object o))) more-objects))) diff -rN -u old-qt.core/src/package.lisp new-qt.core/src/package.lisp --- old-qt.core/src/package.lisp 2014-11-21 23:55:19.000000000 +0100 +++ new-qt.core/src/package.lisp 2014-11-21 23:55:19.000000000 +0100 @@ -1,5 +1,10 @@ (defpackage :cl-smoke.qt.core - (:use :cl :smoke :cffi :bordeaux-threads :cxx-support :alexandria)) + (:use :cl :smoke :cffi :bordeaux-threads :cxx-support :alexandria) + (:export #:define-qvector-translations + #:with-application + #:delete-app + #:ensure-app + #:kill-app)) (defpackage :cl-smoke.qt (:use) ;; do not use :cl to prevent collision with TIME and CHAR diff -rN -u old-qt.core/src/qt.core.lisp new-qt.core/src/qt.core.lisp --- old-qt.core/src/qt.core.lisp 2014-11-21 23:55:19.000000000 +0100 +++ new-qt.core/src/qt.core.lisp 2014-11-21 23:55:19.000000000 +0100 @@ -33,6 +33,7 @@ (init-qt-smoke "init_qtcore_Smoke")) (define-foreign-library libclsmokeqtcore - (:unix "libclsmokeqtcore.so") + (:darwin "libclsmokeqtcore.dylib") + (:unix "libclsmokeqtcore.so") (t (:default "libclsmokeqtcore"))) (use-foreign-library libclsmokeqtcore)) diff -rN -u old-qt.core/src/signal-slot/connect.lisp new-qt.core/src/signal-slot/connect.lisp --- old-qt.core/src/signal-slot/connect.lisp 2014-11-21 23:55:19.000000000 +0100 +++ new-qt.core/src/signal-slot/connect.lisp 2014-11-21 23:55:19.000000000 +0100 @@ -13,7 +13,7 @@ (assert (= (length signal-arguments) (length slot-arguments))) (loop for signal-arg in signal-arguments for slot-arg in slot-arguments do - (if (typep signal-arg 'smoke::smoke-type) + (if (typep signal-arg 'smoke-type) (assert (smoke-type= signal-arg slot-arg)) (assert (subtypep signal-arg slot-arg))))) @@ -115,20 +115,23 @@ (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." + (cerror "Ignore" + "Failed to connect ~A ~A to ~A ~A." (qsender qt-signal) (name qt-signal) (receiver qt-slot) (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) (qt:qslot (name qt-slot))) + (cerror "Ignore" + "Failed to disconnect ~A ~A from ~A ~A." (receiver qt-slot) (name qt-slot) (qsender qt-signal) (name qt-signal)))) (defmethod qt:disconnect-all ((sender qt:object)) (unless (qt:object.disconnect sender 0 0 0) - (cerror "Failed to disconnect everything connected to ~A." + (cerror "Ignore" + "Failed to disconnect everything connected to ~A." sender))) diff -rN -u old-qt.core/src/signal-slot/signal.lisp new-qt.core/src/signal-slot/signal.lisp --- old-qt.core/src/signal-slot/signal.lisp 2014-11-21 23:55:19.000000000 +0100 +++ new-qt.core/src/signal-slot/signal.lisp 2014-11-21 23:55:19.000000000 +0100 @@ -68,15 +68,15 @@ (defun make-lisp-object (object) - (smoke:make-cleanup-pointer (make-cxx-lisp-object object) - #'cl-smoke-free-lisp-object)) + (make-cleanup-pointer (make-cxx-lisp-object object) + #'cl-smoke-free-lisp-object)) (defun convert-arguments (arguments types) "Returns a list of ARGUMENTS converted to TYPES." (mapcar #'(lambda (argument type) - (if (typep type 'smoke::smoke-type) - (smoke::convert-argument argument type) + (if (typep type 'smoke-type) + (smoke:convert-argument argument type) (progn (assert (typep argument type) () "The argument ~S is not of type ~S." @@ -95,13 +95,13 @@ (smoke::with-stack (stack (convert-arguments arguments types) types) (with-foreign-object (args :pointer (1+ (length arguments))) - (loop for i from 1 to (smoke::size stack) + (loop for i from 1 to (smoke:size stack) for type in types do (setf (mem-aref args :pointer i) - (if (or (not (typep type (find-class 'smoke::smoke-type))) - (= 0 (smoke::type-id type)) - (= 13 (smoke::type-id type))) + (if (or (not (typep type (find-class 'smoke-type))) + (= 0 (type-id type)) + (= 13 (type-id type))) (foreign-slot-value (mem-aref (smoke::call-stack-pointer stack) 'smoke::smoke-stack-item diff -rN -u old-qt.core/src/signal-slot/translate.lisp new-qt.core/src/signal-slot/translate.lisp --- old-qt.core/src/signal-slot/translate.lisp 2014-11-21 23:55:19.000000000 +0100 +++ new-qt.core/src/signal-slot/translate.lisp 2014-11-21 23:55:19.000000000 +0100 @@ -1,7 +1,7 @@ (in-package :cl-smoke.qt.core) (defun find-type (smoke-module name &optional start end) - (let ((type (smoke::make-smoke-type smoke-module (subseq name start end)))) + (let ((type (make-smoke-type smoke-module (subseq name start end)))) (assert (not (zerop (id type))) () "No type named ~S found in ~A." @@ -16,7 +16,7 @@ (position #\) signature :from-end t))) (argument-types ()) (last-pos (length arguments)) - (smoke-module (smoke::smoke (class-of object)))) + (smoke-module (smoke (class-of object)))) (loop as pos = (position #\, arguments :from-end t :end last-pos) while pos do @@ -34,7 +34,7 @@ (nconc values (list (typecase (first types) - (smoke::smoke-type + (smoke-type (pointer-to-lisp (mem-ref argument :pointer) (first types))) @@ -44,22 +44,22 @@ (defun disown-object (object) (tg:cancel-finalization object) - (unless (smoke::virtual-destructor-p (class-of object)) - (smoke::remove-object (pointer object))) + (unless (virtual-destructor-p (class-of object)) + (remove-object (pointer object))) object) (defun pointer-to-lisp (pointer type) "Returns the lisp value or object at POINTER of type TYPE." - (if (smoke::class-p type) - (if (smoke::pointer-p type) - (smoke::object-to-lisp (mem-ref pointer :pointer) type) + (if (class-p type) + (if (pointer-p type) + (object-to-lisp (mem-ref pointer :pointer) type) ;; 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 (if-let ((translation (gethash (name type) smoke::*to-lisp-translations*))) + (disown-object (object-to-lisp pointer type))) + (ecase (type-id type) + (0 (if-let ((translation (gethash (name type) *to-lisp-translations*))) ;; Do not free stack allocated stuff (e.g.: QString); that is the callers ;; responisbility. (funcall (car translation) pointer) @@ -91,14 +91,14 @@ (defun get-type (smoke-type) "Returns the QMetaType ID for SMOKE-TYPE." (typecase smoke-type - (smoke::smoke-standard-object - (if (smoke::pointer-p smoke-type) + (smoke-standard-object + (if (pointer-p smoke-type) (error "Not implemented: pointer type.") ;;qmetatype.+voidstar+ - (let ((type (qt:meta-type.type (smoke::name smoke-type)))) + (let ((type (qt:meta-type.type (name smoke-type)))) (assert (/= 0 type) (type) "The type ~S has no QMetaType." - (smoke::name smoke-type)) + (name smoke-type)) type))) (t *cxx-lisp-object-metatype*))) diff -rN -u old-qt.core/src/variant.lisp new-qt.core/src/variant.lisp --- old-qt.core/src/variant.lisp 2014-11-21 23:55:19.000000000 +0100 +++ new-qt.core/src/variant.lisp 2014-11-21 23:55:19.000000000 +0100 @@ -73,41 +73,62 @@ "Returns true when VARIANT is valid (has a value) and false otherwise." (cxx:is-valid variant)) -(defmacro variant-conversions ((variant) &body types) - `(ecase (cxx:user-type ,variant) - - ,@(loop for type in types collect - (if (symbolp 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 copy-object-from-pointer (class pointer) + (make-instance class :arg0 (make-instance class :pointer pointer))) -(defun qt:from-variant (variant) - "Returns the value of VARIANT." - (variant-conversions (variant) - (#.(value qt:variant.+invalid+) - (cerror "Return (VALUES)" "Type of variant ~A is invalid." variant) - (values)) - bit-array bool byte-array - char - date date-time double - int - line line-f list locale long-long - point point-f - rect rect-f reg-exp - size size-f string string-list - time - uint - ulong-long - url - (#.*cxx-lisp-object-metatype* - (let* ((lisp-object (cl-smoke-lisp-object-value (smoke::pointer variant))) - (value)) - (setf value (translate-cxx-lisp-object lisp-object)) - (free-cxx-lisp-object lisp-object) - value)))) +(eval-startup () +;; *cxx-lisp-object-metatype* can change when loading an image +(eval ' + (macrolet + ((variant-conversions ((variant) &body types) + (let* ((special-types '(long-long ulong-long map list hash)) + (exclude-types + (append '(63) ;; ColorGroup + (mapcar #'(lambda (s) + (value + (symbol-value + (intern (format nil "VARIANT.+~A+" s) + :qt)))) + special-types))) + (qt-types (loop for i from 1 to (value qt:variant.+user-type+) + when (and (qt:variant.type-to-name i) + ;; type-to-name returns longlong but + ;; should be LongLong + (not (member i exclude-types))) + collect + (smoke::lispify (qt:variant.type-to-name i) + :qt)))) + `(ecase (cxx:user-type ,variant) + ,@(loop for type in (append special-types + (remove nil qt-types)) + collect + `(,(value (symbol-value + (let ((*package* + (find-package :cl-smoke.qt))) + (symbolicate 'variant.+ type '+)))) + ,(if (fboundp (intern (format nil "TO-~A" type) :cxx)) + `(,(intern (format nil "TO-~A" type) :cxx) ,variant) + `(copy-object-from-pointer + ;; intern since these types are in + ;; qt.gui not qt.core + (intern ,(symbol-name type) :qt) + (cxx:const-data ,variant))))) + ,@(loop for type in types + collect + `(,(eval (first type)) + ,@(rest type))))))) + (defun qt:from-variant (variant) + "Returns the value of VARIANT." + (variant-conversions (variant) + ((value qt:variant.+invalid+) + (cerror "Return (VALUES)" "Type of variant ~A is invalid." variant) + (values)) + (*cxx-lisp-object-metatype* + (let* ((lisp-object (cl-smoke-lisp-object-value (pointer variant))) + (value)) + (setf value (translate-cxx-lisp-object lisp-object)) + (free-cxx-lisp-object lisp-object) + value))))))) (defmethod qt:value ((variant qt:variant)) "Returns the value of VARIANT." diff -rN -u old-qt.core/src/vector.lisp new-qt.core/src/vector.lisp --- old-qt.core/src/vector.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-qt.core/src/vector.lisp 2014-11-21 23:55:19.000000000 +0100 @@ -0,0 +1,123 @@ +;; see: "Inside the Qt 4 Containers" +;; http://doc.trolltech.com/qq/qq19-containers.html#sequentialcontainers + +(in-package :cl-smoke.qt.core) + +(defcfun cl-smoke-make-qvector :pointer) +(defcfun cl-smoke-delete-qvector :void + (vector :pointer)) + +(defbitfield qvector-data-flags + :sharable + :capacity) + +(defcstruct qvector-data + (ref :char :count #.(class-size (find-class 'qt:basic-atomic-int))) + (alloc :int) + (size :int) + (flags qvector-data-flags)) + +(defcstruct qvector-type-data + (ref :char :count #.(class-size (find-class 'qt:basic-atomic-int))) + (alloc :int) + (size :int) + (flags qvector-data-flags) + (array :pointer)) + +;; FIXME We assume QVector to be a POD struct, which is not +;; neccesarily the case. +(defcstruct qvector + (data (:pointer qvector-data))) + +(defun qvector-size (qvector) + (foreign-slot-value (foreign-slot-value qvector 'qvector 'data) + 'qvector-data 'size)) + +(defun qvector-elt (qvector index element-type) + (pointer-to-lisp + (cffi:inc-pointer + (foreign-slot-pointer (foreign-slot-value qvector 'qvector 'data) + 'qvector-type-data 'array) + (* index (type-size element-type))) + element-type)) + +(defun from-qvector (qvector element-type) + (let ((result (make-array (qvector-size qvector)))) + (dotimes (i (length result) result) + (setf (elt result i) + (qvector-elt qvector i element-type))))) + +(defcfun memcpy :pointer + (destination :pointer) + (source :pointer) + (size :unsigned-int)) + +(defun make-qvector (element-type elements) + (let* ((length (length elements)) + (element-size (type-size element-type)) + (data (foreign-alloc :char :count (+ (foreign-type-size 'qvector-data) + (* length element-size)))) + (darray (foreign-slot-pointer data 'qvector-type-data 'array)) + (vector (cl-smoke-make-qvector))) + (unless (stack-p element-type) + (error "FIXME: TODO")) + (if (class-p element-type) + (dotimes (i length) + (memcpy (inc-pointer darray (* i element-size)) + (pointer (elt elements i)) + element-size)) + (dotimes (i length) + (setf (mem-aref darray (type-foreign-keyword element-type) i) + (elt elements i)))) + (setf (mem-ref data :int) 1) ;; ref count + (with-foreign-slots ((ref alloc size flags) + data qvector-data) + (setf alloc length ;; allocated size + size length + flags :sharable) + (setf (foreign-slot-value vector 'qvector 'data) + data)) + vector)) + +(defun deref (basic-atomic-int-pointer) + ;; decrement and return true when the new value is non-zero + (cxx:deref + (make-instance 'qt:basic-atomic-int :pointer basic-atomic-int-pointer))) + +(defun free-qvector (vector) + (unless (null-pointer-p (foreign-slot-value vector 'qvector 'data)) + (let ((data (foreign-slot-value vector 'qvector 'data))) + (unless (deref (foreign-slot-pointer data 'qvector-type-data 'ref)) + (foreign-free data))) + (setf (foreign-slot-value vector 'qvector 'data) + (null-pointer))) + (cl-smoke-delete-qvector vector)) + +(defmacro define-qvector-translations (element-type lisp-type) + `(progn + (defun ,(symbolicate 'from-vector- element-type) (elements) + (make-cleanup-pointer + (make-qvector (make-smoke-type *smoke-module* ,element-type) + elements) + #'free-qvector)) + (defun ,(symbolicate 'vector- element-type '-p) (sequence) + (every #'(lambda (element) + (typep element ',lisp-type)) + sequence)) + (defun ,(symbolicate 'to-vector- element-type) (pointer) + (from-qvector pointer (make-smoke-type *smoke-module* ,element-type))) + (define-from-lisp-translation (,(format nil "QVector<~A>" element-type) + ;; FIXME QImage::setColorTable + ;; has an "const QVector" + ;; argument! + ,(format nil "const QVector<~A>" element-type) + ,(format nil "const QVector<~A>&" element-type)) + (and vector + (satisfies ,(symbolicate 'vector- element-type '-p))) + ,(symbolicate 'from-vector- element-type)) + (define-to-lisp-translation (,(format nil "QVector<~A>" element-type) + ,(format nil "const QVector<~A>&" element-type)) + ,(symbolicate 'to-vector- element-type) + free-qvector))) + +(define-qvector-translations "double" double-float) diff -rN -u old-qt.core/test.lisp new-qt.core/test.lisp --- old-qt.core/test.lisp 2014-11-21 23:55:19.000000000 +0100 +++ new-qt.core/test.lisp 2014-11-21 23:55:19.000000000 +0100 @@ -1,4 +1,11 @@ #| +v v v v v v v +cmake ./ +make +************* +cmake ./ || exit 1 +make || exit 1 +^ ^ ^ ^ ^ ^ ^ exec -a "$0" sbcl --noinform --noprint --disable-debugger --load $0 --end-toplevel-options "$@" # Used for testing on darcs record. |#