Sat Jan 23 23:17:35 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* QVector<T> translation
hunk ./cl-smoke.qt.core.asd 22
+ (:file "vector" :depends-on ("qt.core" "signal-slot"))
hunk ./src/event.lisp 7
- (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)))
hunk ./src/lib/CMakeLists.txt 11
-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)
+
hunk ./src/lib/qlist.cpp 15
-
hunk ./src/operator.lisp 9
- (if (typep object 'smoke::smoke-standard-object)
+ (if (typep object 'smoke-standard-object)
hunk ./src/operator.lisp 11
- (smoke::no-applicable-cxx-method ()
+ (no-applicable-cxx-method ()
hunk ./src/package.lisp 2
- (: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))
hunk ./src/signal-slot/connect.lisp 16
- (if (typep signal-arg 'smoke::smoke-type)
+ (if (typep signal-arg 'smoke-type)
hunk ./src/signal-slot/signal.lisp 71
- (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))
hunk ./src/signal-slot/signal.lisp 78
- (if (typep type 'smoke::smoke-type)
- (smoke::convert-argument argument type)
+ (if (typep type 'smoke-type)
+ (smoke:convert-argument argument type)
hunk ./src/signal-slot/signal.lisp 98
- (loop for i from 1 to (smoke::size stack)
+ (loop for i from 1 to (smoke:size stack)
hunk ./src/signal-slot/signal.lisp 102
- (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)))
hunk ./src/signal-slot/translate.lisp 4
- (let ((type (smoke::make-smoke-type smoke-module (subseq name start end))))
+ (let ((type (make-smoke-type smoke-module (subseq name start end))))
hunk ./src/signal-slot/translate.lisp 19
- (smoke-module (smoke::smoke (class-of object))))
+ (smoke-module (smoke (class-of object))))
hunk ./src/signal-slot/translate.lisp 37
- (smoke::smoke-type
+ (smoke-type
hunk ./src/signal-slot/translate.lisp 47
- (unless (smoke::virtual-destructor-p (class-of object))
- (smoke::remove-object (pointer object)))
+ (unless (virtual-destructor-p (class-of object))
+ (remove-object (pointer object)))
hunk ./src/signal-slot/translate.lisp 53
- (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)
hunk ./src/signal-slot/translate.lisp 60
- (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*)))
hunk ./src/signal-slot/translate.lisp 94
- (smoke::smoke-standard-object
- (if (smoke::pointer-p smoke-type)
+ (smoke-standard-object
+ (if (pointer-p smoke-type)
hunk ./src/signal-slot/translate.lisp 97
- (let ((type (qt:meta-type.type (smoke::name smoke-type))))
+ (let ((type (qt:meta-type.type (name smoke-type))))
hunk ./src/signal-slot/translate.lisp 101
- (smoke::name smoke-type))
+ (name smoke-type))
hunk ./src/variant.lisp 106
- (let* ((lisp-object (cl-smoke-lisp-object-value (smoke::pointer variant)))
+ (let* ((lisp-object (cl-smoke-lisp-object-value (pointer variant)))
addfile ./src/vector.lisp
hunk ./src/vector.lisp 1
+;; 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)