repos
/
commonqt
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Cleanup
Annotate for file src/commonqt.lisp
2009-07-24 tobias
1
;;; Copyright (C) 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
13:39:55 '
2
;;;
'
3
;;; This program is free software: you can redistribute it and/or modify
'
4
;;; it under the terms of the GNU General Public License as published by
'
5
;;; the Free Software Foundation, either version 3 of the License, or
'
6
;;; (at your option) any later version.
'
7
;;;
'
8
;;; This program is distributed in the hope that it will be useful,
'
9
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
'
10
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
'
11
;;; GNU General Public License for more details.
'
12
;;;
'
13
;;; You should have received a copy of the GNU General Public License
'
14
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
'
15
;;;
'
16
;;; As a special exception, the copyright holders of this library give you
'
17
;;; permission to link this library with independent modules to produce an
'
18
;;; executable, regardless of the license terms of these independent
'
19
;;; modules, and to copy and distribute the resulting executable under
'
20
;;; terms of your choice, provided that you also meet, for each linked
'
21
;;; independent module, the terms and conditions of the license of that
'
22
;;; module. An independent module is a module which is not derived from or
'
23
;;; based on this library. If you modify this library, you may extend this
'
24
;;; exception to your version of the library, but you are not obligated to
'
25
;;; do so. If you do not wish to do so, delete this exception statement
'
26
;;; from your version.
'
27
2009-07-02 tobias
28
(in-package :cl-smoke.commonqt)
17:34:07 '
29
2009-07-24 tobias
30
;;; initialization
13:39:55 '
31
(defun ensure-smoke ())
'
32
(defun enable-syntax ())
'
33
2009-07-02 tobias
34
;;; calling methods
2009-07-24 tobias
35
;;;
13:39:55 '
36
;;; #_ reader macro
'
37
;;;
'
38
;;; FIXME: Return reference arguments using multiple return values.
2009-07-02 tobias
39
;;;
17:34:07 '
40
(eval-when (:load-toplevel :compile-toplevel :execute)
2009-07-24 tobias
41
(defun read-perserving-case (stream)
13:39:55 '
42
(let ((*readtable* (copy-readtable nil)))
'
43
(setf (readtable-case *readtable*) :preserve)
'
44
(read stream)))
2009-07-02 tobias
45
2009-07-24 tobias
46
(defun cl-smoke-funcall-form (stream subchar arg)
13:39:55 '
47
(declare (ignore subchar arg))
'
48
(let ((method (read-perserving-case stream)))
'
49
(if (string= "new" (symbol-name method))
'
50
`(lambda (&rest args)
'
51
(make-instance
'
52
',(smoke::lispify (symbol-name (read-perserving-case stream)) :cl-smoke.qt)
'
53
:args args))
'
54
(let ((object (read stream)))
'
55
(if (stringp object)
'
56
(if (upper-case-p (char (symbol-name method) 0))
'
57
`(lambda ()
'
58
,(smoke::lispify
'
59
(concatenate 'string
'
60
(if (string= "Qt" object)
'
61
"+"
'
62
(concatenate 'string
'
63
object
'
64
".+"))
'
65
(symbol-name method) "+")
'
66
:cl-smoke.qt))
'
67
`(lambda (&rest args)
'
68
(apply (symbol-function ',(smoke::lispify (symbol-name method) :cxx))
'
69
(find-class ',(smoke::lispify object :cl-smoke.qt))
'
70
args)))
'
71
`(lambda (&rest args)
'
72
(apply (symbol-function ',(smoke::lispify (symbol-name method) :cxx))
'
73
,object
'
74
args))))))))
2009-07-02 tobias
75
17:34:07 '
76
(eval-when (:load-toplevel :compile-toplevel)
'
77
(set-dispatch-macro-character #\# #\_ #'cl-smoke-funcall-form))
'
78
'
79
;;; Instantiating
'
80
;;;
'
81
(defun new (instance &rest arguments)
'
82
"Calls the C++ construor for INSTANCE with ARGUMENTS."
2009-07-24 tobias
83
(assert (null-pointer-p (smoke:pointer instance))
13:39:55 '
84
(instance)
'
85
"The instance ~A is already constructed." instance)
2009-07-02 tobias
86
(setf (slot-value instance 'smoke:pointer)
2010-01-10 tobias
87
(smoke::call-constructor instance arguments))
2009-07-02 tobias
88
(smoke::set-binding instance)
17:34:07 '
89
(smoke::take-ownership instance)
'
90
(smoke::add-object instance)
'
91
instance)
'
92
'
93
;;; Connecting signals and slots
'
94
;;;
'
95
(defun qsignal (name)
'
96
(cl-smoke.qt:qsignal name))
'
97
(defun qslot (name)
'
98
(cl-smoke.qt:qslot name))
'
99
'
100
;;; QApplication
'
101
;;;
'
102
(defun make-qapplication (&rest arguments)
'
103
"Returns a new QApplication instance with ARGUMENTS as command line
'
104
arguments argv. argv[0] is set to (LISP-IMPLEMNTATION-TYPE)."
2009-07-24 tobias
105
(let* ((argc (smoke:make-auto-pointer
2009-07-02 tobias
106
(cffi:foreign-alloc :int
2009-07-02 tobias
107
:initial-element (1+ (length arguments)))))
2009-07-24 tobias
108
(argv (smoke:make-auto-pointer
2009-07-02 tobias
109
(cffi:foreign-alloc :string
17:34:07 '
110
:initial-contents
'
111
(cons (lisp-implementation-type) ;; arg0
2009-07-02 tobias
112
arguments))))
2009-07-02 tobias
113
(application (make-instance 'cl-smoke.qt:application :args
17:34:07 '
114
(list argc argv))))
'
115
;; argc & argv must remain valid during the lifetime of application.
'
116
(setf (cl-smoke.qt:property application 'arguments)
'
117
(cl-smoke.qt:make-lisp-variant (cons argc argv)))
'
118
application))
'
119
'
120
;;; Overriding C++ methods
'
121
(defclass override-gf (standard-generic-function)
'
122
((cxx-gf :initarg :cxx-gf
'
123
:reader cxx-gf))
'
124
(:metaclass closer-mop:funcallable-standard-class)
'
125
(:documentation "Redirects its methods to CXX-GF."))
'
126
'
127
(defmethod add-method ((gf override-gf) method)
'
128
(add-method (cxx-gf gf) method))
'
129
'
130
(defmethod remove-method ((gf override-gf) method)
'
131
(remove-method (cxx-gf gf) method))
'
132
'
133
;;; Subclassing C++ & defining signals and slots
'
134
;;;
'
135
(defclass qt-class (cxx:class)
2009-07-24 tobias
136
((method-functions :accessor method-functions
13:39:55 '
137
:documentation "The signals and slots.")
'
138
(meta-object :reader class-meta-object))
'
139
(:documentation "Metaclass for a class derived from QObject, that allows
'
140
adding signals and slots to the class."))
2009-07-02 tobias
141
2009-07-02 tobias
142
(defclass signal-slot-mixin ()
2009-07-24 tobias
143
()
13:39:55 '
144
(:documentation "Mixin for a class with metaclass QT-CLASS, that overwrites
'
145
the metaObject and qtMetacall methods."))
2009-07-02 tobias
146
2009-07-24 tobias
147
(defun setup-meta-object (class qt-superclass signals slots)
13:39:55 '
148
(let ((methods (make-array (+ (length signals)
'
149
(length slots))
2009-07-02 tobias
150
:element-type 'function
17:34:07 '
151
:initial-element #'identity))
'
152
(index 0))
2009-07-24 tobias
153
(dolist (signal-name signals)
2009-07-02 tobias
154
(setf (aref methods index)
2009-07-02 tobias
155
(let ((signal-name (first signal-name)))
21:49:43 '
156
#'(lambda (this &rest args)
'
157
(apply #'emit-signal this signal-name args))))
2009-07-02 tobias
158
(incf index))
2009-07-24 tobias
159
(dolist (slot slots)
2009-07-02 tobias
160
(setf (aref methods index)
17:34:07 '
161
(if (symbolp (second slot))
'
162
(second slot)
'
163
(eval `(function ,(second slot)))))
'
164
(incf index))
2009-07-24 tobias
165
(setf (method-functions class) methods))
2009-07-02 tobias
166
(let ((signals (mapcar #'(lambda (s) (make-slot-or-signal (first s)))
2009-07-24 tobias
167
signals))
2009-07-02 tobias
168
(slots (mapcar #'(lambda (s) (make-slot-or-signal (first s)))
2009-07-24 tobias
169
slots))
2009-07-02 tobias
170
(class-name (class-name class)))
17:34:07 '
171
(setf (slot-value class 'meta-object)
'
172
(make-metaobject qt-superclass
'
173
(format nil "~A::~A"
'
174
(package-name (symbol-package class-name))
'
175
(symbol-name class-name))
'
176
nil
'
177
signals
'
178
slots))))
'
179
'
180
(defun setup-qt-class (qt-class next-method &rest args &key qt-superclass
'
181
direct-superclasses direct-default-initargs
2009-07-24 tobias
182
slots signals
2009-07-02 tobias
183
override &allow-other-keys)
17:34:07 '
184
(dolist (method override)
'
185
(ensure-generic-function
'
186
(second method)
'
187
:generic-function-class (find-class 'override-gf)
'
188
:lambda-list '(this &rest args)
'
189
:cxx-gf (fdefinition (smoke::lispify (first method) :cxx))))
'
190
(apply next-method qt-class
'
191
:direct-default-initargs ;; the C++ instance is constructed with #'NEW
'
192
(cons `(:pointer (null-pointer) ,#'null-pointer)
'
193
direct-default-initargs)
'
194
:direct-superclasses
2009-07-24 tobias
195
(append (list (find-qclass (first qt-superclass))
13:39:55 '
196
(find-class 'signal-slot-mixin))
'
197
direct-superclasses)
2009-07-02 tobias
198
args)
2009-07-24 tobias
199
(setup-meta-object qt-class (find-qclass (first qt-superclass))
13:39:55 '
200
signals slots))
2009-07-02 tobias
201
2009-07-02 tobias
202
(defmethod cxx:meta-object ((this signal-slot-mixin))
2009-07-24 tobias
203
(class-meta-object (class-of this)))
2009-07-02 tobias
204
20:48:38 '
205
(defmethod cxx:qt-metacall ((this signal-slot-mixin) call id arguments)
'
206
(let ((m-id (call-next-method)))
'
207
(if (< m-id 0)
'
208
m-id
'
209
(if (enum= call cl-smoke.qt:meta-object.+invoke-meta-method+)
'
210
(progn
2009-07-24 tobias
211
(when (< m-id (length (method-functions (class-of this))))
2009-07-02 tobias
212
(with-simple-restart
20:48:38 '
213
(continue "Skip the method ~A of ~A."
'
214
(cxx:signature
'
215
(cxx:method (cxx:meta-object this) id))
'
216
this)
2009-07-24 tobias
217
(apply (aref (method-functions (class-of this)) m-id)
2009-07-02 tobias
218
this
2010-01-10 tobias
219
(cl-smoke.qt-impl::arguments-to-lisp
2009-07-02 tobias
220
arguments
2010-01-10 tobias
221
(cl-smoke.qt-impl::method-arguments-type
08:53:29 '
222
(cxx:meta-object this) id)))))
2009-07-02 tobias
223
(- m-id
2009-07-24 tobias
224
(length (method-functions (class-of this)))))
2009-07-02 tobias
225
m-id))))
20:48:38 '
226
2009-07-02 tobias
227
(defmethod initialize-instance :around ((class qt-class)
2009-08-27 tobias
228
&rest args)
2009-07-02 tobias
229
(apply #'setup-qt-class class #'call-next-method args))
2009-07-02 tobias
230
2009-08-27 tobias
231
(defmethod reinitialize-instance :around ((qt-class qt-class) &rest args)
2009-07-02 tobias
232
(apply #'setup-qt-class qt-class #'call-next-method args))
17:34:07 '
233
'
234
(defun emit-signal (object signal-name &rest arguments)
'
235
"Emits the signal SIGNAL-NAME of OBJECT using ARGUMENTS."
2009-07-02 tobias
236
(declare (string signal-name))
2009-07-24 tobias
237
(let* ((meta-object (class-meta-object (class-of object)))
13:39:55 '
238
(id (#_indexOfSignal meta-object
'
239
(#_normalizedSignature "QMetaObject"
'
240
signal-name))))
2009-07-02 tobias
241
(assert (>= id 0)
17:34:07 '
242
()
'
243
"No signal ~A of ~A." signal-name object)
2010-01-10 tobias
244
(cl-smoke.qt-impl::activate
08:53:29 '
245
object id (cl-smoke.qt-impl::method-arguments-type meta-object id)
2009-07-02 tobias
246
arguments)))
17:34:07 '
247
'
248
(defmacro call-next-qmethod ()
'
249
"Calls the next method."
'
250
'(call-next-method))
'
251
'
252
;;; Enum values
'
253
;;;
'
254
(defun primitive-value (enum)
'
255
"Returns the integer value of ENUM."
'
256
(cxx-support:value enum))
'
257
'
258
;;; Type disambiguation
'
259
;;;
2009-07-02 tobias
260
(defun bool (value)
2009-07-24 tobias
261
"Returns true when VALUE is not 0 and false when it is 0."
13:39:55 '
262
(not (zerop value)))
2009-07-02 tobias
263
2009-07-02 tobias
264
;; No-op since we have overload resolution.
17:34:07 '
265
(setf (fdefinition 'uint) #'identity
2009-07-02 tobias
266
(fdefinition 'int) #'identity
20:48:38 '
267
(fdefinition 'qstring) #'identity)
2009-07-02 tobias
268
17:34:07 '
269
(defun find-qclass (class-name)
'
270
"Returns the CLOS class for the C++ CLASS-NAME string."
'
271
(find-class (smoke::lispify class-name :cl-smoke.qt)))
2009-07-24 tobias
272
13:39:55 '
273
;;; Documentation
'
274
;;;
'
275
'
276
(defun qapropos (name)
'
277
(smoke::fgrep-classes cl-smoke.qt-impl::*smoke-module* name)
'
278
(smoke::fgrep-methods cl-smoke.qt-impl::*smoke-module* name))
'
279
'
280
;; FIXME: implement QDESCRIBE
'
281
(defun qdescribe (name)
'
282
(declare (ignore name))
'
283
(warn "QDESCRIBE not implemented."))