repos
/
qt.core
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
QVector<T> translation
Annotate for file /src/signal-slot/signal.lisp
2010-01-10 tobias
1
(in-package :cl-smoke.qt.core)
2009-04-05 tobias
2
17:56:16 '
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
2009-06-11 tobias
14
(defclass signal-object (qt:object)
2009-04-05 tobias
15
((argument-types :accessor argument-types
17:56:16 '
16
:initarg :argument-types
'
17
:documentation "List of the argument types"))
'
18
(:documentation "Qt Signal object.")
2009-04-07 tobias
19
(:metaclass cxx:class))
2009-04-05 tobias
20
2009-04-07 tobias
21
#+cmu (defmethod closer-mop:validate-superclass ((class closer-mop:funcallable-standard-class)
09:49:59 '
22
(superclass standard-class))
'
23
t)
'
24
'
25
(defclass qsignal (closer-mop:funcallable-standard-object qsignal-mixin)
2009-04-05 tobias
26
()
17:56:16 '
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
2009-06-11 tobias
32
(defun qt:make-signal (&rest argument-types)
2009-04-05 tobias
33
"Returns a funcallable signal. When ARGUMENT-TYPES are not
17:56:16 '
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)
2009-07-22 tobias
51
(apply #'emit (signal-object object) args))))
2009-04-05 tobias
52
17:56:16 '
53
(defun find-slot-id (receiver slot)
'
54
"Returns the ID of RECEIVER from SLOT."
2009-07-22 tobias
55
;; For efficiency assume that SLOT is normalized and fallback to
22:21:01 '
56
;; normalizing when not. (Just like Qt does.)
2009-04-05 tobias
57
(let ((id (cxx:index-of-slot (cxx:meta-object receiver)
2009-06-04 tobias
58
slot)))
10:58:29 '
59
(when (< id 0)
'
60
(setf id (cxx:index-of-slot (cxx:meta-object receiver)
2009-07-24 tobias
61
(qt:meta-object.normalized-signature slot))))
2009-04-05 tobias
62
(when (< id 0)
17:56:16 '
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
2009-05-26 tobias
70
(defun make-lisp-object (object)
2010-01-23 tobias
71
(make-cleanup-pointer (make-cxx-lisp-object object)
22:17:35 '
72
#'cl-smoke-free-lisp-object))
2009-04-05 tobias
73
17:56:16 '
74
2009-05-26 tobias
75
(defun convert-arguments (arguments types)
09:57:44 '
76
"Returns a list of ARGUMENTS converted to TYPES."
'
77
(mapcar #'(lambda (argument type)
2010-01-23 tobias
78
(if (typep type 'smoke-type)
22:17:35 '
79
(smoke:convert-argument argument type)
2009-05-26 tobias
80
(progn (assert (typep argument type)
09:57:44 '
81
()
2010-01-10 tobias
82
"The argument ~S is not of type ~S."
08:52:09 '
83
argument type)
2009-05-26 tobias
84
(make-lisp-object argument))))
09:57:44 '
85
arguments types))
'
86
2009-04-05 tobias
87
(defun emit (qsignal &rest arguments)
17:56:16 '
88
"Emits the signal QSIGNAL."
2009-07-02 tobias
89
(activate qsignal (id qsignal) (argument-types qsignal) arguments))
19:12:45 '
90
'
91
(defun activate (object id types arguments)
2009-09-02 tobias
92
;;; The first element of args would be used for the return value by
12:00:35 '
93
;;; QMetaObject::invokeMethod(), but for signal-slot connection it is
'
94
;;; ignored.
2009-07-02 tobias
95
(smoke::with-stack (stack (convert-arguments arguments types)
19:12:45 '
96
types)
2009-09-02 tobias
97
(with-foreign-object (args :pointer (1+ (length arguments)))
2010-01-23 tobias
98
(loop for i from 1 to (smoke:size stack)
2009-07-02 tobias
99
for type in types
19:12:45 '
100
do
2009-05-26 tobias
101
(setf (mem-aref args :pointer i)
2010-01-23 tobias
102
(if (or (not (typep type (find-class 'smoke-type)))
22:17:35 '
103
(= 0 (type-id type))
'
104
(= 13 (type-id type)))
2009-05-26 tobias
105
(foreign-slot-value
2009-07-08 tobias
106
(mem-aref (smoke::call-stack-pointer stack)
2009-05-26 tobias
107
'smoke::smoke-stack-item
09:57:44 '
108
i)
'
109
'smoke::smoke-stack-item 'smoke::voidp)
'
110
(foreign-slot-pointer
2009-07-08 tobias
111
(mem-aref (smoke::call-stack-pointer stack)
2009-05-26 tobias
112
'smoke::smoke-stack-item
09:57:44 '
113
i)
'
114
'smoke::smoke-stack-item 'smoke::voidp))))
2009-07-02 tobias
115
(setf (mem-aref args :pointer 0)
19:12:45 '
116
(null-pointer))
'
117
(qt:meta-object.activate object id args))))
2009-04-05 tobias
118
2009-06-11 tobias
119
(defmethod qt:disconnect-all ((qsignal qsignal))
2009-04-05 tobias
120
(unless (disconnect-id (signal-object qsignal)
17:56:16 '
121
(id (signal-object qsignal))
'
122
0
'
123
0)))