repos
/
qt.core
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
cleanup
Annotate for file /src/vector.lisp
2010-01-23 tobias
1
;; see: "Inside the Qt 4 Containers"
22:17:35 '
2
;; http://doc.trolltech.com/qq/qq19-containers.html#sequentialcontainers
'
3
'
4
(in-package :cl-smoke.qt.core)
'
5
'
6
(defcfun cl-smoke-make-qvector :pointer)
'
7
(defcfun cl-smoke-delete-qvector :void
'
8
(vector :pointer))
'
9
'
10
(defbitfield qvector-data-flags
'
11
:sharable
'
12
:capacity)
'
13
'
14
(defcstruct qvector-data
'
15
(ref :char :count #.(class-size (find-class 'qt:basic-atomic-int)))
'
16
(alloc :int)
'
17
(size :int)
'
18
(flags qvector-data-flags))
'
19
'
20
(defcstruct qvector-type-data
'
21
(ref :char :count #.(class-size (find-class 'qt:basic-atomic-int)))
'
22
(alloc :int)
'
23
(size :int)
'
24
(flags qvector-data-flags)
'
25
(array :pointer))
'
26
'
27
;; FIXME We assume QVector to be a POD struct, which is not
'
28
;; neccesarily the case.
'
29
(defcstruct qvector
'
30
(data (:pointer qvector-data)))
'
31
'
32
(defun qvector-size (qvector)
'
33
(foreign-slot-value (foreign-slot-value qvector 'qvector 'data)
'
34
'qvector-data 'size))
'
35
2010-01-25 tobias
36
(defun qvector-elt (qvector index element-type)
2010-01-23 tobias
37
(pointer-to-lisp
22:17:35 '
38
(cffi:inc-pointer
'
39
(foreign-slot-pointer (foreign-slot-value qvector 'qvector 'data)
'
40
'qvector-type-data 'array)
'
41
(* index (type-size element-type)))
'
42
element-type))
'
43
'
44
(defun from-qvector (qvector element-type)
'
45
(let ((result (make-array (qvector-size qvector))))
'
46
(dotimes (i (length result) result)
2010-01-25 tobias
47
(setf (elt result i)
18:53:36 '
48
(qvector-elt qvector i element-type)))))
2010-01-23 tobias
49
22:17:35 '
50
(defcfun memcpy :pointer
'
51
(destination :pointer)
'
52
(source :pointer)
'
53
(size :unsigned-int))
'
54
'
55
(defun make-qvector (element-type elements)
'
56
(let* ((length (length elements))
'
57
(element-size (type-size element-type))
'
58
(data (foreign-alloc :char :count (+ (foreign-type-size 'qvector-data)
'
59
(* length element-size))))
'
60
(darray (foreign-slot-pointer data 'qvector-type-data 'array))
'
61
(vector (cl-smoke-make-qvector)))
'
62
(unless (stack-p element-type)
'
63
(error "FIXME: TODO"))
'
64
(if (class-p element-type)
'
65
(dotimes (i length)
'
66
(memcpy (inc-pointer darray (* i element-size))
2010-01-25 tobias
67
(pointer (elt elements i))
2010-01-23 tobias
68
element-size))
22:17:35 '
69
(dotimes (i length)
'
70
(setf (mem-aref darray (type-foreign-keyword element-type) i)
2010-01-25 tobias
71
(elt elements i))))
2010-01-23 tobias
72
(setf (mem-ref data :int) 1) ;; ref count
22:17:35 '
73
(with-foreign-slots ((ref alloc size flags)
'
74
data qvector-data)
'
75
(setf alloc length ;; allocated size
'
76
size length
'
77
flags :sharable)
'
78
(setf (foreign-slot-value vector 'qvector 'data)
'
79
data))
'
80
vector))
'
81
'
82
(defun deref (basic-atomic-int-pointer)
'
83
;; decrement and return true when the new value is non-zero
'
84
(cxx:deref
'
85
(make-instance 'qt:basic-atomic-int :pointer basic-atomic-int-pointer)))
'
86
'
87
(defun free-qvector (vector)
'
88
(unless (null-pointer-p (foreign-slot-value vector 'qvector 'data))
'
89
(let ((data (foreign-slot-value vector 'qvector 'data)))
'
90
(unless (deref (foreign-slot-pointer data 'qvector-type-data 'ref))
'
91
(foreign-free data)))
'
92
(setf (foreign-slot-value vector 'qvector 'data)
'
93
(null-pointer)))
'
94
(cl-smoke-delete-qvector vector))
'
95
'
96
(defmacro define-qvector-translations (element-type lisp-type)
'
97
`(progn
'
98
(defun ,(symbolicate 'from-vector- element-type) (elements)
'
99
(make-cleanup-pointer
'
100
(make-qvector (make-smoke-type *smoke-module* ,element-type)
'
101
elements)
'
102
#'free-qvector))
'
103
(defun ,(symbolicate 'vector- element-type '-p) (sequence)
'
104
(every #'(lambda (element)
'
105
(typep element ',lisp-type))
'
106
sequence))
'
107
(defun ,(symbolicate 'to-vector- element-type) (pointer)
'
108
(from-qvector pointer (make-smoke-type *smoke-module* ,element-type)))
'
109
(define-from-lisp-translation (,(format nil "QVector<~A>" element-type)
'
110
;; FIXME QImage::setColorTable
'
111
;; has an "const QVector<QRgb>"
'
112
;; argument!
'
113
,(format nil "const QVector<~A>" element-type)
'
114
,(format nil "const QVector<~A>&" element-type))
'
115
(and vector
'
116
(satisfies ,(symbolicate 'vector- element-type '-p)))
'
117
,(symbolicate 'from-vector- element-type))
'
118
(define-to-lisp-translation (,(format nil "QVector<~A>" element-type)
'
119
,(format nil "const QVector<~A>&" element-type))
'
120
,(symbolicate 'to-vector- element-type)
'
121
free-qvector)))
'
122
'
123
(define-qvector-translations "double" double-float)