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