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