repos
/
qt.core
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
QVector<T> translation
Annotate for file /src/signal-slot/translate.lisp
2010-01-10 tobias
1
(in-package :cl-smoke.qt.core)
2009-04-05 tobias
2
2010-01-10 tobias
3
(defun find-type (smoke-module name &optional start end)
2010-01-23 tobias
4
(let ((type (make-smoke-type smoke-module (subseq name start end))))
2010-01-10 tobias
5
(assert (not (zerop (id type)))
08:52:09 '
6
()
'
7
"No type named ~S found in ~A."
'
8
(subseq name start end) smoke-module)
'
9
type))
2009-07-08 tobias
10
2010-01-10 tobias
11
(defun method-arguments-type (object index)
08:52:09 '
12
"Returns a type name list for the arguments of method INDEX of OBJECTs metaobject."
'
13
(let* ((metaobject (cxx:meta-object object))
'
14
(signature (cxx:signature (cxx:method metaobject index)))
2009-04-05 tobias
15
(arguments (subseq signature (1+ (position #\( signature))
17:56:16 '
16
(position #\) signature :from-end t)))
'
17
(argument-types ())
2010-01-10 tobias
18
(last-pos (length arguments))
2010-01-23 tobias
19
(smoke-module (smoke (class-of object))))
2009-04-05 tobias
20
(loop as pos = (position #\, arguments :from-end t :end last-pos)
17:56:16 '
21
while pos
'
22
do
2010-01-10 tobias
23
(push (find-type smoke-module arguments (1+ pos) last-pos) argument-types)
2009-07-22 tobias
24
(setf last-pos pos))
2009-04-05 tobias
25
(when (> last-pos 0)
2010-01-10 tobias
26
(push (find-type smoke-module arguments 0 last-pos) argument-types))))
2009-04-05 tobias
27
17:56:16 '
28
'
29
(defun arguments-to-lisp2 (argument types values)
'
30
(if (null types)
'
31
values
2009-04-08 tobias
32
(arguments-to-lisp2 (inc-pointer argument (foreign-type-size :pointer))
15:16:04 '
33
(rest types)
'
34
(nconc values
'
35
(list
'
36
(typecase (first types)
2010-01-23 tobias
37
(smoke-type
2009-04-08 tobias
38
(pointer-to-lisp (mem-ref argument :pointer)
15:16:04 '
39
(first types)))
'
40
'
41
(t
'
42
(translate-cxx-lisp-object
'
43
(mem-ref argument :pointer)))))))))
'
44
2009-05-24 tobias
45
(defun disown-object (object)
11:42:39 '
46
(tg:cancel-finalization object)
2010-01-23 tobias
47
(unless (virtual-destructor-p (class-of object))
22:17:35 '
48
(remove-object (pointer object)))
2009-05-24 tobias
49
object)
11:42:39 '
50
2009-04-08 tobias
51
(defun pointer-to-lisp (pointer type)
2009-05-24 tobias
52
"Returns the lisp value or object at POINTER of type TYPE."
2010-01-23 tobias
53
(if (class-p type)
22:17:35 '
54
(if (pointer-p type)
'
55
(object-to-lisp (mem-ref pointer :pointer) type)
2009-07-22 tobias
56
;; By-value means that the object at POINTER is allocated by
22:21:01 '
57
;; the C++ signal code and has dynamic extend in the
'
58
;; slot. The C++ signal code frees the object when the slot
'
59
;; returns.
2010-01-23 tobias
60
(disown-object (object-to-lisp pointer type)))
22:17:35 '
61
(ecase (type-id type)
'
62
(0 (if-let ((translation (gethash (name type) *to-lisp-translations*)))
2009-08-02 tobias
63
;; Do not free stack allocated stuff (e.g.: QString); that is the callers
11:15:21 '
64
;; responisbility.
'
65
(funcall (car translation) pointer)
'
66
(error "Do not know how to convert the type ~A to Lisp." type)))
2009-04-08 tobias
67
(1 (mem-ref pointer 'cxx-bool))
15:16:04 '
68
(2 (code-char (mem-ref pointer :char)))
'
69
(3 (code-char (mem-ref pointer :unsigned-char)))
'
70
(4 (code-char (mem-ref pointer :short)))
'
71
(5 (code-char (mem-ref pointer :unsigned-short)))
'
72
(6 (mem-ref pointer :int))
'
73
(7 (mem-ref pointer :unsigned-int))
'
74
(8 (mem-ref pointer :long))
'
75
(9 (mem-ref pointer :unsigned-long))
'
76
(10 (mem-ref pointer :float))
'
77
(11 (mem-ref pointer :double))
'
78
(12 (make-instance 'enum
'
79
:value (mem-ref pointer :long)
'
80
:type type)))))
'
81
2009-04-05 tobias
82
17:56:16 '
83
(defun arguments-to-lisp (arguments types)
2009-05-24 tobias
84
"Returns ARGUMENTS for a slot invocation as lisp objects."
2009-07-22 tobias
85
(arguments-to-lisp2
22:21:01 '
86
(inc-pointer arguments ;; index 0 is for the return value
'
87
(foreign-type-size :pointer))
'
88
types ()))
2009-04-05 tobias
89
17:56:16 '
90
'
91
(defun get-type (smoke-type)
2009-05-24 tobias
92
"Returns the QMetaType ID for SMOKE-TYPE."
2009-04-05 tobias
93
(typecase smoke-type
2010-01-23 tobias
94
(smoke-standard-object
22:17:35 '
95
(if (pointer-p smoke-type)
2009-07-22 tobias
96
(error "Not implemented: pointer type.") ;;qmetatype.+voidstar+
2010-01-23 tobias
97
(let ((type (qt:meta-type.type (name smoke-type))))
2009-04-05 tobias
98
(assert (/= 0 type)
17:56:16 '
99
(type)
'
100
"The type ~S has no QMetaType."
2010-01-23 tobias
101
(name smoke-type))
2009-04-05 tobias
102
type)))
17:56:16 '
103
(t
'
104
*cxx-lisp-object-metatype*)))
'
105
'
106
'
107
(defun types (smoke-types)
2009-05-24 tobias
108
"Returns a newly allocated array of QMetaType IDs of SMOKE-TYPES."
2009-07-22 tobias
109
;; FIXME free TYPES on error.
2009-04-05 tobias
110
(let ((types (cffi:foreign-alloc :int :count (1+ (length smoke-types))))
17:56:16 '
111
(index 0))
'
112
(dolist (type smoke-types)
'
113
(setf (cffi:mem-aref types :int index)
'
114
(get-type type))
'
115
(incf index))
'
116
(setf (cffi:mem-aref types :int index)
'
117
0)
'
118
types))