repos
/
qt.gui
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
filehistory
normal
|
plain
|
shade
|
zebra
Better Lisp vector to QList<*> conversion.
Annotate for file src/signal-slot/signal.lisp
2010-01-10 tobias
1
(in-package :cl-smoke.qt-impl)
08:52:49 '
2
'
3
(defclass qsignal-mixin ()
'
4
((signal-object :accessor signal-object
'
5
:initarg :signal-object
'
6
:initform (make-instance 'signal-object)))
'
7
(:documentation "in SB-PCL you can not have both
'
8
FUNCALLABLE-STANDARD-CLASS and STANDARD-CLASS,
'
9
thus QSIGNAL is split in three classes.
'
10
'
11
See:
'
12
http://www.sbcl.org/manual/Metaobject-Protocol.html#index-validate_002dsuperclass-164"))
'
13
'
14
(defclass signal-object (qt:object)
'
15
((argument-types :accessor argument-types
'
16
:initarg :argument-types
'
17
:documentation "List of the argument types"))
'
18
(:documentation "Qt Signal object.")
'
19
(:metaclass cxx:class))
'
20
'
21
#+cmu (defmethod closer-mop:validate-superclass ((class closer-mop:funcallable-standard-class)
'
22
(superclass standard-class))
'
23
t)
'
24
'
25
(defclass qsignal (closer-mop:funcallable-standard-object qsignal-mixin)
'
26
()
'
27
(:metaclass closer-mop:funcallable-standard-class)
'
28
(:documentation "A funcallable Qt signal.
'
29
The argument types can be supplied by the :METHOD-TYPES initarg.
'
30
Calling an instance emits the signal."))
'
31
'
32
(defun qt:make-signal (&rest argument-types)
'
33
"Returns a funcallable signal. When ARGUMENT-TYPES are not
'
34
specified, they are determined when the first connection is made."
'
35
(if argument-types
'
36
(make-instance 'qsignal :argument-types argument-types)
'
37
(make-instance 'qsignal)))
'
38
'
39
(defmethod id ((qsignal signal-object))
'
40
(cxx:method-count (cxx:meta-object qsignal)))
'
41
'
42
(defmethod initialize-instance :after ((object qsignal) &rest initargs
'
43
&key (argument-types nil arg-types-p)
'
44
&allow-other-keys)
'
45
(declare (ignore initargs))
'
46
(when arg-types-p
'
47
(setf (argument-types (signal-object object))
'
48
argument-types))
'
49
(closer-mop:set-funcallable-instance-function object
'
50
#'(lambda (&rest args)
'
51
(apply #'emit (signal-object object) args))))
'
52
'
53
(defun find-slot-id (receiver slot)
'
54
"Returns the ID of RECEIVER from SLOT."
'
55
;; For efficiency assume that SLOT is normalized and fallback to
'
56
;; normalizing when not. (Just like Qt does.)
'
57
(let ((id (cxx:index-of-slot (cxx:meta-object receiver)
'
58
slot)))
'
59
(when (< id 0)
'
60
(setf id (cxx:index-of-slot (cxx:meta-object receiver)
'
61
(qt:meta-object.normalized-signature slot))))
'
62
(when (< id 0)
'
63
(error "No slot ~S for class ~S.
'
64
The valid slots are: ~{~<~%~T~0,75:;~A ~>~}"
'
65
slot (class-of receiver)
'
66
(class-slots (class-of receiver))))
'
67
id))
'
68
'
69
'
70
(defun make-lisp-object (object)
'
71
(smoke:make-cleanup-pointer (make-cxx-lisp-object object)
'
72
#'qt-smoke-free-lisp-object))
'
73
'
74
'
75
(defun convert-arguments (arguments types)
'
76
"Returns a list of ARGUMENTS converted to TYPES."
'
77
(mapcar #'(lambda (argument type)
'
78
(if (typep type 'smoke::smoke-type)
'
79
(smoke::convert-argument argument type)
'
80
(progn (assert (typep argument type)
'
81
()
'
82
"The argument ~S is not of type ~S.")
'
83
(make-lisp-object argument))))
'
84
arguments types))
'
85
'
86
(defun emit (qsignal &rest arguments)
'
87
"Emits the signal QSIGNAL."
'
88
(activate qsignal (id qsignal) (argument-types qsignal) arguments))
'
89
'
90
(defun activate (object id types arguments)
2009-09-02 tobias
91
;;; The first element of args would be used for the return value by
12:00:35 '
92
;;; QMetaObject::invokeMethod(), but for signal-slot connection it is
'
93
;;; ignored.
2010-01-10 tobias
94
(smoke::with-stack (stack (convert-arguments arguments types)
08:52:49 '
95
types)
2009-09-02 tobias
96
(with-foreign-object (args :pointer (1+ (length arguments)))
2010-01-10 tobias
97
(loop for i from 1 to (smoke::size stack)
08:52:49 '
98
for type in types
'
99
do
'
100
(setf (mem-aref args :pointer i)
'
101
(if (or (not (typep type (find-class 'smoke::smoke-type)))
'
102
(= 0 (smoke::type-id type))
'
103
(= 13 (smoke::type-id type)))
'
104
(foreign-slot-value
'
105
(mem-aref (smoke::call-stack-pointer stack)
'
106
'smoke::smoke-stack-item
'
107
i)
'
108
'smoke::smoke-stack-item 'smoke::voidp)
'
109
(foreign-slot-pointer
'
110
(mem-aref (smoke::call-stack-pointer stack)
'
111
'smoke::smoke-stack-item
'
112
i)
'
113
'smoke::smoke-stack-item 'smoke::voidp))))
'
114
(setf (mem-aref args :pointer 0)
'
115
(null-pointer))
'
116
(qt:meta-object.activate object id args))))
'
117
'
118
(defmethod qt:disconnect-all ((qsignal qsignal))
'
119
(unless (disconnect-id (signal-object qsignal)
'
120
(id (signal-object qsignal))
'
121
0
'
122
0)))