repos
/
qt.gui
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
filehistory
normal
|
plain
|
shade
|
zebra
support packages for symbols as property names.
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
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 the object at POINTER is allocated by
22:21:01 '
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.
2010-01-10 tobias
53
(disown-object (smoke::object-to-lisp pointer type)))
08:52:49 '
54
(ecase (smoke::type-id type)
2009-08-02 tobias
55
(0 (let ((cffi-type (smoke::get-type (name type))))
11:15:21 '
56
(if (null cffi-type)
'
57
(progn
'
58
pointer)
'
59
(convert-from-foreign pointer
'
60
cffi-type))))
2010-01-10 tobias
61
(1 (mem-ref pointer 'cxx-bool))
08:52:49 '
62
(2 (code-char (mem-ref pointer :char)))
'
63
(3 (code-char (mem-ref pointer :unsigned-char)))
'
64
(4 (code-char (mem-ref pointer :short)))
'
65
(5 (code-char (mem-ref pointer :unsigned-short)))
'
66
(6 (mem-ref pointer :int))
'
67
(7 (mem-ref pointer :unsigned-int))
'
68
(8 (mem-ref pointer :long))
'
69
(9 (mem-ref pointer :unsigned-long))
'
70
(10 (mem-ref pointer :float))
'
71
(11 (mem-ref pointer :double))
'
72
(12 (make-instance 'enum
'
73
:value (mem-ref pointer :long)
'
74
:type type)))))
'
75
'
76
'
77
(defun arguments-to-lisp (arguments types)
'
78
"Returns ARGUMENTS for a slot invocation as lisp objects."
2009-07-22 tobias
79
(arguments-to-lisp2
22:21:01 '
80
(inc-pointer arguments ;; index 0 is for the return value
'
81
(foreign-type-size :pointer))
'
82
types ()))
2010-01-10 tobias
83
08:52:49 '
84
'
85
(defun get-type (smoke-type)
'
86
"Returns the QMetaType ID for SMOKE-TYPE."
'
87
(typecase smoke-type
'
88
(smoke::smoke-standard-object
'
89
(if (smoke::pointer-p smoke-type)
2009-07-22 tobias
90
(error "Not implemented: pointer type.") ;;qmetatype.+voidstar+
2010-01-10 tobias
91
(let ((type (qt:meta-type.type (smoke::name smoke-type))))
08:52:49 '
92
(assert (/= 0 type)
'
93
(type)
'
94
"The type ~S has no QMetaType."
'
95
(smoke::name smoke-type))
'
96
type)))
'
97
(t
'
98
*cxx-lisp-object-metatype*)))
'
99
'
100
'
101
(defun types (smoke-types)
'
102
"Returns a newly allocated array of QMetaType IDs of SMOKE-TYPES."
2009-07-22 tobias
103
;; FIXME free TYPES on error.
2010-01-10 tobias
104
(let ((types (cffi:foreign-alloc :int :count (1+ (length smoke-types))))
08:52:49 '
105
(index 0))
'
106
(dolist (type smoke-types)
'
107
(setf (cffi:mem-aref types :int index)
'
108
(get-type type))
'
109
(incf index))
'
110
(setf (cffi:mem-aref types :int index)
'
111
0)
'
112
types))