Sat Jan 23 23:17:35 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* QVector<T> 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-10-30 06:58:15.000000000 +0100
+++ new-qt.core/cl-smoke.qt.core.asd 2014-10-30 06:58:15.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/event.lisp new-qt.core/src/event.lisp
--- old-qt.core/src/event.lisp 2014-10-30 06:58:15.000000000 +0100
+++ new-qt.core/src/event.lisp 2014-10-30 06:58:15.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-10-30 06:58:15.000000000 +0100
+++ new-qt.core/src/lib/CMakeLists.txt 2014-10-30 06:58:15.000000000 +0100
@@ -8,7 +8,9 @@
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)
+set(QT_SMOKE_SOURCES qt_smoke.cpp
+ qstring.cpp qstringlist.cpp lisp_object.cpp qlist.cpp qvector.cpp)
+
add_library(clsmokeqtcore MODULE ${QT_SMOKE_SOURCES})
target_link_libraries(clsmokeqtcore ${QT_LIBRARIES})
set_target_properties(clsmokeqtcore
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-10-30 06:58:15.000000000 +0100
+++ new-qt.core/src/lib/qlist.cpp 2014-10-30 06:58:15.000000000 +0100
@@ -12,5 +12,4 @@
DEFINE_QLIST_WRAPPER_PTR(void)
DEFINE_QLIST_WRAPPER(QByteArray)
-
} // extern "C"
diff -rN -u old-qt.core/src/operator.lisp new-qt.core/src/operator.lisp
--- old-qt.core/src/operator.lisp 2014-10-30 06:58:15.000000000 +0100
+++ new-qt.core/src/operator.lisp 2014-10-30 06:58:15.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-10-30 06:58:15.000000000 +0100
+++ new-qt.core/src/package.lisp 2014-10-30 06:58:15.000000000 +0100
@@ -1,5 +1,9 @@
(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
+ #: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/signal-slot/connect.lisp new-qt.core/src/signal-slot/connect.lisp
--- old-qt.core/src/signal-slot/connect.lisp 2014-10-30 06:58:15.000000000 +0100
+++ new-qt.core/src/signal-slot/connect.lisp 2014-10-30 06:58:15.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)))))
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-10-30 06:58:15.000000000 +0100
+++ new-qt.core/src/signal-slot/signal.lisp 2014-10-30 06:58:15.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-10-30 06:58:15.000000000 +0100
+++ new-qt.core/src/signal-slot/translate.lisp 2014-10-30 06:58:15.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-10-30 06:58:15.000000000 +0100
+++ new-qt.core/src/variant.lisp 2014-10-30 06:58:15.000000000 +0100
@@ -103,7 +103,7 @@
ulong-long
url
(#.*cxx-lisp-object-metatype*
- (let* ((lisp-object (cl-smoke-lisp-object-value (smoke::pointer variant)))
+ (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)
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-10-30 06:58:15.000000000 +0100
@@ -0,0 +1,133 @@
+;; 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-aref (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 (aref result i)
+ (qvector-aref 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 (aref elements i))
+ element-size))
+ (dotimes (i length)
+ (setf (mem-aref darray (type-foreign-keyword element-type) i)
+ (aref 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))
+
+(defun from-vector-point (elements)
+ (make-cleanup-pointer
+ (make-qvector (make-smoke-type *smoke-module* "QPoint")
+ elements)
+ #'free-qvector))
+
+(defun vector-point-p (sequence)
+ (every #'(lambda (element) (typep element 'qt:point))
+ sequence))
+
+(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<QRgb>"
+ ;; 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)