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