repos
/
qt.core
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
initial import
Annotate for file src/signal-slot/signal.lisp
2009-04-05 tobias
1
(in-package :qt)
17:56:16 '
2
(declaim (optimize (debug 3)))
'
3
'
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
'
15
(defclass signal-object (object)
'
16
((argument-types :accessor argument-types
'
17
:initarg :argument-types
'
18
:documentation "List of the argument types"))
'
19
(:documentation "Qt Signal object.")
'
20
(:metaclass smoke::smoke-wrapper-class))
'
21
'
22
(defclass qsignal (qsignal-mixin closer-mop:funcallable-standard-object)
'
23
()
'
24
(:metaclass closer-mop:funcallable-standard-class)
'
25
(:documentation "A funcallable Qt signal.
'
26
The argument types can be supplied by the :METHOD-TYPES initarg.
'
27
Calling an instance emits the signal."))
'
28
'
29
(defun make-signal (&rest argument-types)
'
30
"Returns a funcallable signal. When ARGUMENT-TYPES are not
'
31
specified, they are determined when the first connection is made."
'
32
(if argument-types
'
33
(make-instance 'qsignal :argument-types argument-types)
'
34
(make-instance 'qsignal)))
'
35
'
36
(defmethod id ((qsignal signal-object))
'
37
(cxx:method-count (cxx:meta-object qsignal)))
'
38
'
39
(defmethod initialize-instance :after ((object qsignal) &rest initargs
'
40
&key (argument-types nil arg-types-p)
'
41
&allow-other-keys)
'
42
(declare (ignore initargs))
'
43
(when arg-types-p
'
44
(setf (argument-types (signal-object object))
'
45
argument-types))
'
46
(closer-mop:set-funcallable-instance-function object
'
47
#'(lambda (&rest args)
'
48
(apply #'emit (signal-object object) args)))
'
49
)
'
50
'
51
(defun find-slot-id (receiver slot)
'
52
"Returns the ID of RECEIVER from SLOT."
'
53
(let ((id (cxx:index-of-slot (cxx:meta-object receiver)
'
54
(cxx:data (meta-object.normalized-signature slot)))))
'
55
(when (< id 0)
'
56
(error "No slot ~S for class ~S.
'
57
The valid slots are: ~{~<~%~T~0,75:;~A ~>~}"
'
58
slot (class-of receiver)
'
59
(class-slots (class-of receiver))))
'
60
id))
'
61
'
62
(defun connect-signal (qsignal receiver slot &optional (type 0))
'
63
"Connects a signal to a slot. Returns T on success and NIL otherwise."
'
64
'
65
(let ((qsignal (signal-object qsignal))
'
66
(slot-id (find-slot-id receiver slot)))
'
67
(when (not (slot-boundp qsignal 'argument-types))
'
68
(setf (argument-types qsignal)
'
69
(method-arguments-type (cxx:meta-object receiver)
'
70
slot-id)))
'
71
(assert (>= slot-id 0)
'
72
()
'
73
"No slot ~S for class ~S."
'
74
slot (class-name receiver))
'
75
(assert (static-call "QMetaObject" "connect#$#$$$"
'
76
qsignal
'
77
(id qsignal)
'
78
receiver
'
79
slot-id
'
80
type
'
81
;; QMetaObject::connect is responsible for freeing
'
82
;; the types array.
'
83
(types (method-arguments-type
'
84
(cxx:meta-object receiver)
'
85
slot-id)))
'
86
()
'
87
"Failed to connect ~S to the slot ~S of ~S."
'
88
qsignal slot receiver)))
'
89
'
90
(defun disconnect-signal (qsignal receiver slot)
'
91
(let ((qsignal (signal-object qsignal))
'
92
(slot-id (cxx:index-of-slot (cxx:meta-object receiver)
'
93
(cxx:data
'
94
(meta-object.normalized-signature slot)))))
'
95
(assert (>= slot-id 0)
'
96
()
'
97
"No slot ~S for class ~S."
'
98
slot (class-name receiver))
'
99
(assert (static-call "QMetaObject" "disconnect#$#$"
'
100
qsignal
'
101
(id qsignal)
'
102
receiver
'
103
slot-id)
'
104
()
'
105
"Failed to disconnect ~S to the slot ~S of ~S."
'
106
qsignal slot receiver)))
'
107
'
108
(defmethod smoke::push-lisp-object (stack object class)
'
109
(let ((cxx-object (make-cxx-lisp-object object)))
'
110
(smoke::push-cleanup stack
'
111
'
112
#'(lambda ()
'
113
(qt-smoke-free-lisp-object cxx-object)))
'
114
(smoke::push-stack2 stack
'
115
cxx-object
'
116
0)))
'
117
'
118
'
119
(defun emit (qsignal &rest arguments)
'
120
"Emits the signal QSIGNAL."
'
121
;;; The first element of args would be used for the return value
'
122
;;; by QMetaObject::invokeMethod(), but for signal-slot connection
'
123
;;; it is ignored.
'
124
(smoke::with-stack (stack arguments
'
125
(argument-types qsignal))
'
126
(cffi:with-foreign-object (args :pointer (1+ (length arguments)))
'
127
(loop for i from 1 to (smoke::size stack)
'
128
for type in (argument-types qsignal)
'
129
do
'
130
(setf (mem-aref args :pointer i)
'
131
(if (or (not (typep type (find-class 'smoke::smoke-type)))
'
132
(= 0 (smoke::type-id type))
'
133
(= 13 (smoke::type-id type)))
'
134
(foreign-slot-value
'
135
(mem-aref (pointer stack)
'
136
'smoke::smoke-stack-item
'
137
i)
'
138
'smoke::smoke-stack-item 'smoke::voidp)
'
139
(foreign-slot-pointer
'
140
(mem-aref (pointer stack)
'
141
'smoke::smoke-stack-item
'
142
i)
'
143
'smoke::smoke-stack-item 'smoke::voidp))))
'
144
(setf (mem-aref args :pointer 0)
'
145
(null-pointer))
'
146
(smoke::static-call *qt-smoke* "QMetaObject" "activate##$?"
'
147
qsignal
'
148
(cxx:meta-object qsignal)
'
149
(id qsignal)
'
150
args))))
'
151
'
152
(defmethod disconnect-all ((qsignal qsignal))
'
153
(unless (disconnect-id (signal-object qsignal)
'
154
(id (signal-object qsignal))
'
155
0
'
156
0)))