repos
/
qt.gui
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
filehistory
normal
|
plain
|
shade
|
zebra
*SMOKE-MODULE* must be passed instead of *QT-SMOKE*.
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)
2009-06-21 tobias
4
(smoke::make-smoke-type *smoke-module* (subseq name start end)))
2009-07-08 tobias
5
2010-01-10 tobias
6
(defun method-arguments-type (metaobject index)
08:52:49 '
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
2009-07-22 tobias
16
(push (find-type arguments (1+ pos) last-pos) argument-types)
22:21:01 '
17
(setf last-pos pos))
2010-01-10 tobias
18
(when (> last-pos 0)
08:52:49 '
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)
2009-07-22 tobias
49
;; By value means that they are allocated by the C++ signal
2009-07-01 tobias
50
;; code and have dynamic extend in the slot. The C++ singal code
2009-07-22 tobias
51
;; frees the object when the slot returns.
2010-01-10 tobias
52
(disown-object (smoke::object-to-lisp pointer type)))
08:52:49 '
53
(ecase (smoke::type-id type)
2009-08-02 tobias
54
(0 (let ((cffi-type (smoke::get-type (name type))))
11:15:21 '
55
(if (null cffi-type)
'
56
(progn
'
57
pointer)
'
58
(convert-from-foreign pointer
'
59
cffi-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."
2009-07-22 tobias
78
(arguments-to-lisp2 (inc-pointer arguments ;; index 0 is for the return value
22:21:01 '
79
(foreign-type-size :pointer))
'
80
types ()))
2010-01-10 tobias
81
08:52:49 '
82
'
83
(defun get-type (smoke-type)
'
84
"Returns the QMetaType ID for SMOKE-TYPE."
'
85
(typecase smoke-type
'
86
(smoke::smoke-standard-object
'
87
(if (smoke::pointer-p smoke-type)
2009-07-22 tobias
88
(error "FOO");;qmetatype.+voidstar+
2009-06-21 tobias
89
(let ((type (qt:meta-type.type (smoke::name smoke-type))))
2010-01-10 tobias
90
(assert (/= 0 type)
08:52:49 '
91
(type)
'
92
"The type ~S has no QMetaType."
'
93
(smoke::name smoke-type))
'
94
type)))
'
95
(t
'
96
*cxx-lisp-object-metatype*)))
'
97
'
98
'
99
(defun types (smoke-types)
'
100
"Returns a newly allocated array of QMetaType IDs of SMOKE-TYPES."
2009-07-22 tobias
101
;;FIXME free TYPES on error.
2010-01-10 tobias
102
(let ((types (cffi:foreign-alloc :int :count (1+ (length smoke-types))))
08:52:49 '
103
(index 0))
'
104
(dolist (type smoke-types)
'
105
(setf (cffi:mem-aref types :int index)
'
106
(get-type type))
'
107
(incf index))
'
108
(setf (cffi:mem-aref types :int index)
'
109
0)
'
110
types))