Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 633 lines (576 sloc) 25.0 kb
3fedc2b @lichtblau initial commit
lichtblau authored
1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
2
3 ;;; Copyright (c) 2009 David Lichteblau. All rights reserved.
4
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
7 ;;; are met:
8 ;;;
9 ;;; * Redistributions of source code must retain the above copyright
10 ;;; notice, this list of conditions and the following disclaimer.
11 ;;;
12 ;;; * Redistributions in binary form must reproduce the above
13 ;;; copyright notice, this list of conditions and the following
14 ;;; disclaimer in the documentation and/or other materials
15 ;;; provided with the distribution.
16 ;;;
17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28
29 (in-package :qt)
30 (named-readtables:in-readtable :qt)
31
17679a0 @lichtblau Method lookup caching
lichtblau authored
32 (defun interpret-delete (object)
33 (cond
34 ((typep object 'null-qobject)
35 (error "cannot delete null object: ~A" object))
36 ((qobject-deleted object)
37 (warn "not deleting dead object: ~A" object))
38 (t
39 (optimized-call nil object (resolve-delete object))
40 (note-deleted object))))
41
42 #+nil
43 (defun resolve-delete (object)
44 (let ((dtor (format nil "~~~A" (qclass-name (qobject-class object)))))
45 (lambda (object)
46 (cond
47 ((typep object 'null-qobject)
48 (error "cannot delete null object: ~A" object))
49 ((qobject-deleted object)
50 (warn "not deleting dead object: ~A" object))
51 (t
52 (optimized-call nil object dtor)
53 (note-deleted object))))))
54
55 (defun resolve-delete (object)
56 ;; (format *trace-output* "cache miss for #_delete ~A~%" object)
57 (format nil "~~~A" (qclass-name (qobject-class object))))
58
59 (defmacro optimized-delete (object)
60 `(let ((object ,object))
be1100d @stassats Simplify and document cached-values-bind macro.
stassats authored
61 (cached-values-bind (dtor) (resolve-delete object)
62 (((qobject-class object) :hash t))
17679a0 @lichtblau Method lookup caching
lichtblau authored
63 (cond
64 ((typep object 'null-qobject)
65 (error "cannot delete null object: ~A" object))
66 ((qobject-deleted object)
67 (warn "not deleting dead object: ~A" object))
68 (t
69 (optimized-call nil object dtor)
70 (note-deleted object))))))
71
72 (defun postmortem (ptr class description qobjectp dynamicp)
73 (declare (ignore ptr class))
74 (format t "Finalizer called for ~A (~{~A~^, ~}), possible memory leak.~%"
75 description
76 (append (when dynamicp '("Lisp"))
77 (when qobjectp '("QObject"))))
78 (force-output)
79 #+(or)
80 (let* ((object (%qobject class ptr))
81 (parent (and qobjectp (#_parent object))))
82 (cond
83 ((or (not qobjectp)
84 (and parent (null-qobject-p parent)))
85 (format t "deleting ~A (~A)~%" object qobjectp)
86 (force-output)
87 (handler-case
88 (if qobjectp
89 (#_deleteLater object)
90 (call object (format nil "~~~A" (qclass-name class))))
91 (error (c)
92 (format t "Error in finalizer: ~A, for object: ~A~%"
93 c description))))
94 (dynamicp
95 (warn "Bug in CommonQt? previously dynamic object ~A still has parent ~A, but has been GCed"
96 object parent))
97 (t
98 (warn "Bug in CommonQt? ~A still has parent ~A; not deleting"
99 object parent)))))
100
e02e9ea @stassats Slightly reorganize file structure.
stassats authored
101 (defvar *report-memory-leaks* nil)
102
17679a0 @lichtblau Method lookup caching
lichtblau authored
103 (defun cache! (object)
782982a @lichtblau Strongly reference live dynamic objects
lichtblau authored
104 (let ((ptr (qobject-pointer object)))
37002cf @stassats Add QVariant marshalling.
stassats authored
105 ; (assert (null (pointer->cached-object ptr)))
782982a @lichtblau Strongly reference live dynamic objects
lichtblau authored
106 (setf (pointer->cached-object ptr) object)
0b84399 @lichtblau Quick hack to cache objects under their pointers for MI superclasses, to...
lichtblau authored
107 (map-cpl (lambda (super)
108 (setf (pointer->cached-object (%cast object super))
109 object))
110 (qobject-class object))
782982a @lichtblau Strongly reference live dynamic objects
lichtblau authored
111 (when (typep object 'dynamic-object)
112 (setf (gethash (cffi:pointer-address ptr) *strongly-cached-objects*)
113 object)))
17679a0 @lichtblau Method lookup caching
lichtblau authored
114 (when (and *report-memory-leaks*
115 (or (not (qtypep object (find-qclass "QObject")))
116 (typep (#_parent object) 'null-qobject)))
117 (tg:finalize object
118 (let* ((ptr (qobject-pointer object))
119 (class (qobject-class object))
120 (str (princ-to-string object))
121 (qobjectp (qsubclassp class (find-qclass "QObject")))
122 (dynamicp (typep object 'dynamic-object)))
123 (lambda ()
124 (postmortem ptr class str qobjectp dynamicp)))))
125 object)
126
3fedc2b @lichtblau initial commit
lichtblau authored
127 (defclass dynamic-member ()
128 ((name :initarg :name
129 :accessor dynamic-member-name)
130 (cached-arg-types :accessor dynamic-member-cached-arg-types)))
131
132 (defclass signal-member (dynamic-member)
133 ((name :initarg :name
134 :accessor dynamic-member-name)))
135
136 (defclass slot-member (dynamic-member)
137 ((function :initarg :function
138 :accessor dynamic-member-function)))
139
140 (defmethod print-object ((instance dynamic-object) stream)
141 (print-unreadable-object (instance stream :type t :identity nil)
142 (cond
143 ((not (slot-boundp instance 'class))
144 (format stream "uninitialized"))
145 ((cffi:pointerp (qobject-pointer instance))
146 (format stream "~A 0x~8,'0X"
147 (qclass-name (qobject-class instance))
148 (cffi:pointer-address (qobject-pointer instance))))
149 (t
150 (format stream "~A ~A"
151 (qclass-name (qobject-class instance))
152 (qobject-pointer instance))))))
153
154 (defmethod initialize-instance ((instance dynamic-object) &key)
155 (multiple-value-prog1
156 (call-next-method)
157 (let ((class (class-of instance)))
158 (ensure-qt-class-caches class)
159 (setf (qobject-class instance) (class-effective-class class)))))
160
161 (defmethod initialize-instance :around ((instance dynamic-object) &key)
162 (multiple-value-prog1
163 (call-next-method)
164 (unless (cffi:pointerp (qobject-pointer instance))
165 (error "INITIALIZE-INSTANCE of ~A failed to call Qt constructor"
166 instance))))
167
168 (defclass qt-class (standard-class)
169 ((qt-superclass :initarg :qt-superclass
170 :accessor class-qt-superclass)
171 (signals :initarg :signals
172 :accessor class-signals)
173 (qt-slots :initarg :slots
174 :accessor class-slots)
175 (override-specs :initarg :override-specs
176 :accessor class-override-specs)
177 (class-infos :initarg :class-infos
178 :accessor class-class-infos)
179 (effective-class :initform nil)
180 (qmetaobject :initform nil)
181 (smoke-generation :initform nil
182 :accessor class-smoke-generation)
17679a0 @lichtblau Method lookup caching
lichtblau authored
183 (generation :initform nil
184 :accessor class-generation)
3fedc2b @lichtblau initial commit
lichtblau authored
185 (member-table :accessor class-member-table)
186 (overrides :accessor class-overrides)))
187
188 (defun default-overrides ()
189 (let ((overrides (make-hash-table :test 'equal)))
190 (setf (gethash "metaObject" overrides) 'metaobject-override)
191 (setf (gethash "qt_metacall" overrides) 'qt_metacall-override)
192 overrides))
193
194 (defmethod c2mop:validate-superclass
195 ((class qt-class) (superclass t))
196 nil)
197
198 (defmethod c2mop:validate-superclass
199 ((class standard-class) (superclass qt-class))
200 nil)
201
202 (defmethod c2mop:validate-superclass
203 ((class qt-class) (superclass standard-class))
204 (eq superclass (find-class 'dynamic-object)))
205
206 (defmethod c2mop:validate-superclass
207 ((class qt-class) (superclass qt-class))
208 t)
209
210 (defun parse-function (form)
211 ;; this run-time use of COMPILE is a huge kludge. We'd just want to hook
212 ;; into the DEFCLASS expansion like slots and init functions can, but
213 ;; those are special built-in features of DEFCLASS which meta classes
214 ;; cannot implement for their own options. Big oversight in the MOP IMNSHO.
fbede38 @lichtblau Bugfix: Signal an error on invalid function specifications (with test ca...
lichtblau authored
215 (etypecase (macroexpand form)
3fedc2b @lichtblau initial commit
lichtblau authored
216 ((or symbol function)
217 form)
218 ((cons (eql lambda) t)
219 (compile nil form))
220 ((cons (eql function) t)
221 (eval form))))
222
223 (defun initialize-qt-class
224 (class next-method &rest args
225 &key qt-superclass direct-superclasses slots signals info override
226 &allow-other-keys)
227 (let* ((qt-superclass
228 (if qt-superclass
229 (destructuring-bind (name) qt-superclass
230 (check-type name string)
231 name)
232 nil))
233 (direct-superclasses
234 (let ((qt-class (find-class 'qt-class))
235 (standard-object (find-class 'standard-object))
236 (dynamic-object (find-class 'dynamic-object)))
237 (if (some (lambda (c) (typep c qt-class))
238 direct-superclasses)
239 direct-superclasses
240 (append (if (equal direct-superclasses (list standard-object))
241 nil
242 direct-superclasses)
243 (list dynamic-object)))))
244 (slots
245 (iter (for (name value) in slots)
246 (collect (make-instance 'slot-member
247 :name name
248 :function (parse-function value)))))
249 (signals
250 (iter (for (name) in signals)
251 (collect (make-instance 'signal-member
252 :name name))))
253 (class-infos
254 (iter (for (name value) in info)
255 (collect (make-class-info name value))))
256 (override-specs
257 (iter (for (method fun) in override)
258 (collect (make-instance 'override-spec
259 :method-name method
6bccde5 @lichtblau Merged fixes
lichtblau authored
260 :target-function
261 (parse-function fun))))))
3fedc2b @lichtblau initial commit
lichtblau authored
262 (apply next-method
263 class
264 :allow-other-keys t
265 :direct-superclasses direct-superclasses
266 :qt-superclass qt-superclass
267 :slots slots
268 :signals signals
269 :class-infos class-infos
270 :override-specs override-specs
271 args)))
272
273 (defmethod initialize-instance ((instance qt-class) &rest args
274 &key &allow-other-keys)
275 (apply #'initialize-qt-class instance #'call-next-method args))
276
277 (defmethod reinitialize-instance ((instance qt-class) &rest args)
278 (apply #'initialize-qt-class instance #'call-next-method args))
279
280 (defun get-qt-class-member (qt-class id)
c77a5f3 @ivan4th Implemented dynamic slot connections, added DWIMish CONNECT and DISCONNE...
ivan4th authored
281 (let ((table (class-member-table qt-class)))
282 (when (< id (length table))
283 (elt table id))))
3fedc2b @lichtblau initial commit
lichtblau authored
284
285 (defun make-override-table (specs)
286 (let ((table (make-hash-table :test 'equal)))
287 (dolist (spec specs)
288 (setf (gethash (override-spec-method-name spec) table)
289 (override-spec-target-function spec)))
290 table))
291
292 (defclass override-spec ()
293 ((method-name :initarg :method-name
294 :accessor override-spec-method-name)
295 (target-function :initarg :target-function
296 :accessor override-spec-target-function)))
297
298 (defun merge-overrides (a b)
299 (let ((c (make-hash-table :test 'equal)))
300 (maphash (lambda (k v) (setf (gethash k c) v )) a)
301 (maphash (lambda (k v) (unless (gethash k c) (setf (gethash k c) v))) b)
302 c))
303
304 (defmethod c2mop:finalize-inheritance :after ((object qt-class))
305 (dolist (super (c2mop:class-direct-superclasses object))
306 (unless (c2mop:class-finalized-p super)
307 (c2mop:finalize-inheritance super)))
308 (with-slots (qmetaobject qt-superclass member-table signals qt-slots
309 overrides)
310 object
311 (setf qmetaobject
312 ;; clear out any old QMetaObject, so that ensure-metaobject will
313 ;; set up a new one
314 nil)
315 (setf qt-superclass
316 (or qt-superclass
317 (class-qt-superclass
318 (or (find-if (lambda (x) (typep x 'qt-class))
319 (c2mop:class-direct-superclasses object))
320 (error "No effective Qt class name declared for ~A"
321 object)))))
322 (setf overrides (make-override-table (class-override-specs object)))
323 (let ((supers (remove-if-not (lambda (super)
324 (typep super 'qt-class))
325 (c2mop:class-direct-superclasses object))))
326 (if supers
327 (dolist (super supers)
328 (setf overrides
329 (merge-overrides overrides (class-overrides super))))
330 (setf overrides (merge-overrides overrides (default-overrides)))))
331 (setf member-table (concatenate 'vector signals qt-slots))))
332
9bd4637 @lichtblau flush %qobject-metaobject cache in init-smoke
lichtblau authored
333 (defun %qobject-metaobject ()
334 (or *qobject-metaobject*
335 (setf *qobject-metaobject*
17679a0 @lichtblau Method lookup caching
lichtblau authored
336 (let ((qobj (optimized-new (find-qclass "QObject"))))
337 (prog1
338 (#_metaObject qobj)
339 (#_delete qobj))))))
9e228ea @ivan4th Fixed handling of QObject-derived classes and signals with zero index.
ivan4th authored
340
3fedc2b @lichtblau initial commit
lichtblau authored
341 (defun ensure-qt-class-caches (qt-class)
342 (check-type qt-class qt-class)
17679a0 @lichtblau Method lookup caching
lichtblau authored
343 (with-slots (effective-class qmetaobject smoke-generation generation)
344 qt-class
7b34040 @lichtblau Use manual memory management
lichtblau authored
345 (unless (and qmetaobject
d05ea28 @lichtblau Query smoke dynamically instead of building CLOS object tables
lichtblau authored
346 effective-class
782982a @lichtblau Strongly reference live dynamic objects
lichtblau authored
347 (eq smoke-generation *weakly-cached-objects*))
3fedc2b @lichtblau initial commit
lichtblau authored
348 ;; clear everything out to ensure a clean state in case of errors
349 ;; in the following forms
350 (setf effective-class nil)
351 (setf qmetaobject nil)
352 (setf smoke-generation nil)
353 ;; reinitialize things
354 (setf effective-class (find-qclass
355 (class-qt-superclass qt-class)))
356 (setf qmetaobject
357 (let* ((class (find-qclass
358 (class-qt-superclass qt-class)))
d05ea28 @lichtblau Query smoke dynamically instead of building CLOS object tables
lichtblau authored
359 (qobject-class (find-qclass "QObject"))
89651bb @lichtblau avoid calling _staticMetaObject on mixins; they don't have a metaobject
lichtblau authored
360 (parent (cond
d05ea28 @lichtblau Query smoke dynamically instead of building CLOS object tables
lichtblau authored
361 ((eq class qobject-class)
89651bb @lichtblau avoid calling _staticMetaObject on mixins; they don't have a metaobject
lichtblau authored
362 (%qobject-metaobject))
d05ea28 @lichtblau Query smoke dynamically instead of building CLOS object tables
lichtblau authored
363 ((qsubclassp class qobject-class)
89651bb @lichtblau avoid calling _staticMetaObject on mixins; they don't have a metaobject
lichtblau authored
364 (#_staticMetaObject class))
365 (t
366 (null-qobject (find-qclass "QMetaObject"))))))
3fedc2b @lichtblau initial commit
lichtblau authored
367 (make-metaobject parent
368 (let ((name (class-name qt-class)))
369 (format nil "~A::~A"
370 (package-name (symbol-package name))
371 (symbol-name name)))
372 (class-class-infos qt-class)
373 (mapcar #'convert-dynamic-member
374 (class-signals qt-class))
375 (mapcar #'convert-dynamic-member
376 (class-slots qt-class)))))
17679a0 @lichtblau Method lookup caching
lichtblau authored
377 ;; invalidate call site caches
378 (setf generation (gensym))
3fedc2b @lichtblau initial commit
lichtblau authored
379 ;; mark as fresh
782982a @lichtblau Strongly reference live dynamic objects
lichtblau authored
380 (setf (class-smoke-generation qt-class) *weakly-cached-objects*))))
3fedc2b @lichtblau initial commit
lichtblau authored
381
382 (defun convert-dynamic-member (member)
383 (make-slot-or-signal (dynamic-member-name member)))
384
17679a0 @lichtblau Method lookup caching
lichtblau authored
385 (defun class-effective-class (qt-class &optional (errorp t))
3fedc2b @lichtblau initial commit
lichtblau authored
386 (ensure-qt-class-caches qt-class)
17679a0 @lichtblau Method lookup caching
lichtblau authored
387 (or (slot-value qt-class 'effective-class)
388 (when errorp
389 (error "effective-class not cached?"))))
3fedc2b @lichtblau initial commit
lichtblau authored
390
391 (defun class-qmetaobject (qt-class)
392 (ensure-qt-class-caches qt-class)
393 (slot-value qt-class 'qmetaobject))
394
17679a0 @lichtblau Method lookup caching
lichtblau authored
395 (defun find-method-override (object method)
396 (if (typep object 'dynamic-object)
397 (find-method-override-using-class (class-of object) method)
398 nil))
3fedc2b @lichtblau initial commit
lichtblau authored
399
17679a0 @lichtblau Method lookup caching
lichtblau authored
400 (defun find-method-override-using-class (class method)
401 (gethash (qmethod-name method) (class-overrides class)))
3fedc2b @lichtblau initial commit
lichtblau authored
402
403 (defvar *next-qmethod-trampoline* nil)
404 (defvar *next-qmethod* nil)
405
406 (defun call-next-qmethod (&rest args)
407 (unless *next-qmethod-trampoline*
408 (error "call-next-qmethod used outside of overriding method"))
409 (funcall *next-qmethod-trampoline* args))
410
411 (defun get-next-qmethod ()
412 (or *next-qmethod*
413 (error "get-next-qmethod used outside of overriding method")))
414
7b34040 @lichtblau Use manual memory management
lichtblau authored
415 (defun override (fun object <method> args)
17679a0 @lichtblau Method lookup caching
lichtblau authored
416 (let* ((method-name
7b34040 @lichtblau Use manual memory management
lichtblau authored
417 ;; dispatch on the method name rather than method index,
418 ;; because the index sometimes points to a superclass method
419 ;; rather than the specific class we want. Don't know why.
420 ;; Run-time lookup of the name ensures that we get the most
421 ;; specific method that OBJECT has.
422 (qmethod-name <method>))
423 (*next-qmethod* method-name)
424 (*next-qmethod-trampoline*
425 (lambda (new-args)
17679a0 @lichtblau Method lookup caching
lichtblau authored
426 (apply #'interpret-call-without-override
7b34040 @lichtblau Use manual memory management
lichtblau authored
427 object
428 method-name
429 (or new-args args)))))
3fedc2b @lichtblau initial commit
lichtblau authored
430 (apply fun object args)))
431
432 (defun metaobject-override (object)
433 (class-qmetaobject (class-of object)))
434
c77a5f3 @ivan4th Implemented dynamic slot connections, added DWIMish CONNECT and DISCONNE...
ivan4th authored
435 (defgeneric dynamic-object-member (object id)
436 (:method (object id)
437 (declare (ignore object id))
438 nil))
439
3fedc2b @lichtblau initial commit
lichtblau authored
440 (defun qt_metacall-override (object call id stack)
441 (let ((new-id (call-next-qmethod)))
442 (cond
d05ea28 @lichtblau Query smoke dynamically instead of building CLOS object tables
lichtblau authored
443 ((or (minusp new-id)
3fedc2b @lichtblau initial commit
lichtblau authored
444 (not (eql (primitive-value call)
17679a0 @lichtblau Method lookup caching
lichtblau authored
445 (primitive-value (#_QMetaObject::InvokeMetaMethod)))))
3fedc2b @lichtblau initial commit
lichtblau authored
446 id)
447 (t
448 (let ((member
c77a5f3 @ivan4th Implemented dynamic slot connections, added DWIMish CONNECT and DISCONNE...
ivan4th authored
449 (or
450 (get-qt-class-member (class-of object) new-id)
451 (dynamic-object-member object new-id)
452 (error "QT_METACALL-OVERRIDE: invalid member id ~A" id))))
3fedc2b @lichtblau initial commit
lichtblau authored
453 (etypecase member
454 (signal-member
455 (#_activate (class-qmetaobject (class-of object))
456 object
457 id
458 stack)
17679a0 @lichtblau Method lookup caching
lichtblau authored
459 -1)
3fedc2b @lichtblau initial commit
lichtblau authored
460 (slot-member
461 (apply (dynamic-member-function member)
462 object
17679a0 @lichtblau Method lookup caching
lichtblau authored
463 (unmarshal-slot-args member stack))
464 -1)))))))
3fedc2b @lichtblau initial commit
lichtblau authored
465
466 (defun guess-stack-item-slot (x)
467 (case x
468 (:|int| 'int)
469 (:|uint| 'uint)
470 (:|bool| 'bool)
8cceb87 @lichtblau Handle QString in slot args
lichtblau authored
471 (:|QString| 'ptr)
3fedc2b @lichtblau initial commit
lichtblau authored
472 (t (error "don't know how to unmarshal slot argument ~A" x))))
473
474 (defun ensure-dynamic-member-types (member)
475 (with-slots (cached-arg-types) member
476 (unless (slot-boundp member 'cached-arg-types)
477 (setf cached-arg-types
478 (mapcar (lambda (name)
d05ea28 @lichtblau Query smoke dynamically instead of building CLOS object tables
lichtblau authored
479 (or (find-qtype name)
17679a0 @lichtblau Method lookup caching
lichtblau authored
480 (error "no smoke type found for dynamic member arg type ~A. Giving up."
d05ea28 @lichtblau Query smoke dynamically instead of building CLOS object tables
lichtblau authored
481 name)))
3fedc2b @lichtblau initial commit
lichtblau authored
482 (cl-ppcre:split
483 ","
484 (entry-arg-types (convert-dynamic-member member))))))
485 cached-arg-types))
486
487 (defun unmarshal-slot-args (member argv)
488 (iter (for type in (ensure-dynamic-member-types member))
489 (for i from 1)
276136b @stassats Try to treat class objects allocated on the stack. Though I'm not really...
stassats authored
490 (collect (cond ((eq (qtype-interned-name type) ':|QString|)
491 (qstring-pointer-to-lisp
492 (cffi:mem-aref argv :pointer i)))
493 ((and
494 (eq (qtype-kind type) :stack)
495 (eq (qtype-stack-item-slot type) 'class))
496 (unmarshal type (cffi:inc-pointer argv
497 (* i
498 (cffi:foreign-type-size :pointer)))))
499 (t
500 (unmarshal type (cffi:mem-aref argv :pointer i)))))))
3fedc2b @lichtblau initial commit
lichtblau authored
501
502 (defclass class-info ()
503 ((key :initarg :key
504 :accessor entry-key)
505 (value :initarg :value
506 :accessor entry-value)))
507
508 (defclass slot-or-signal ()
509 ((name :initarg :name
510 :accessor entry-name)
511 (full-name :initarg :full-name
512 :accessor entry-full-name)
513 (arg-types :initarg :arg-types
514 :accessor entry-arg-types)
515 (reply-type :initarg :reply-type
516 :accessor entry-reply-type)))
517
518 (defun make-class-info (key value)
519 (make-instance 'class-info :key key :value value))
520
521 (defun make-slot-or-signal (str)
56f99b2 @lichtblau Regression fix and test case for QByteArray unmarshalling
lichtblau authored
522 (let ((str (#_data (#_QMetaObject::normalizedSignature str))))
a471b1f @ivan4th Signal an error when invalid signal / slot signatures are encountered.
ivan4th authored
523 (or
524 (cl-ppcre:register-groups-bind (a b c d)
525 ("^(([\\w,<>:]*)\\s+)?([^\\s]*)\\((.*)\\)" str)
526 (declare (ignore a))
527 (make-instance 'slot-or-signal
528 :name c
529 :full-name (concatenate 'string c "(" d ")")
530 :arg-types d
531 :reply-type (if (or (null b) (equal b "void")) "" b)))
532 (error "invalid slot or signal signature: ~s" str))))
3fedc2b @lichtblau initial commit
lichtblau authored
533
534 (defconstant +AccessPrivate+ #x00)
535 (defconstant +AccessProtected+ #x01)
536 (defconstant +AccessPublic+ #x02)
537 (defconstant +MethodMethod+ #x00)
538 (defconstant +MethodSignal+ #x04)
539 (defconstant +MethodSlot+ #x08)
540 (defconstant +MethodCompatibility+ #x10)
541 (defconstant +MethodCloned+ #x20)
542 (defconstant +MethodScriptable+ #x40)
543
544 (defun make-metaobject (parent class-name class-infos signals slots)
545 (let ((data (make-array 0 :fill-pointer 0 :adjustable t))
546 (table (make-hash-table))
547 (stream (make-string-output-stream)))
548 (labels ((intern-string (s)
549 (or (gethash s table)
550 (setf (gethash s table)
551 (prog1
552 (file-position stream)
553 (write-string s stream)
554 (write-char (code-char 0) stream)))))
555 (add (x) (vector-push-extend x data))
556 (add-string (s) (add (intern-string s))))
557 (add 1) ;revision
558 (add (intern-string class-name)) ;class name
559 (add (length class-infos)) ;classinfo
560 (add (if (plusp (length class-infos)) 10 0))
561 (add (+ (length signals) (length slots)))
562 (add (+ 10 (* 2 (length class-infos)))) ;methods
563 (add 0) ;properties
564 (add 0)
565 (add 0) ;enums/sets
566 (add 0)
567 (dolist (entry class-infos)
568 (add-string (entry-key entry))
569 (add-string (entry-value entry)))
570 (dolist (entry signals)
571 (add-string (entry-full-name entry))
572 (add-string (remove #\, (entry-full-name entry) :test-not #'eql))
573 (add-string (entry-reply-type entry))
574 (add-string "") ;tag
575 (add (logior +methodsignal+ +accessprotected+)))
576 (dolist (entry slots)
577 (add-string (entry-full-name entry))
578 (add-string (remove #\, (entry-full-name entry) :test-not #'eql))
579 (add-string (entry-reply-type entry))
580 (add-string "") ;tag
581 (add (logior +methodslot+ +accesspublic+)))
582 (add 0))
583 (let ((dataptr (cffi:foreign-alloc :int :count (length data))))
584 (dotimes (i (length data))
585 (setf (cffi:mem-aref dataptr :int i) (elt data i)))
586 (cache!
587 (%qobject (find-qclass "QMetaObject")
588 (sw_make_metaobject (qobject-pointer parent)
589 (cffi:foreign-string-alloc
590 (get-output-stream-string stream))
591 dataptr))))))
592
593 (defun call-with-signal-marshalling (fun types args)
baa6bd7 @stassats call-with-signal-marshalling: setup **void for arguments correctly.
stassats authored
594 (let ((arg-count (length args)))
595 (cffi:with-foreign-object (argv :pointer (1+ arg-count))
596 (cffi:with-foreign-object (stack '|union StackItem| arg-count)
597 (labels ((iterate (i rest-types rest-args)
598 (cond
599 (rest-args
95dcf55 @stassats Fix call-with-signal-marshalling for immediate objects.
stassats authored
600 (let* ((stack-item (cffi:mem-aref stack '|union StackItem| i))
601 (arg (car rest-args))
602 (type (car rest-types))
603 (slot-type (qtype-stack-item-slot type)))
604 (marshal arg type stack-item
605 (lambda ()
606 (setf (cffi:mem-aref argv :pointer (1+ i))
607 (if (or (eql slot-type 'ptr)
608 (eql slot-type 'class))
609 (cffi:mem-aref stack-item :pointer)
610 stack-item))
611 (iterate (1+ i)
612 (cdr rest-types)
613 (cdr rest-args))))))
baa6bd7 @stassats call-with-signal-marshalling: setup **void for arguments correctly.
stassats authored
614 (t
615 (funcall fun argv)))))
616 (iterate 0 types args))))))
3fedc2b @lichtblau initial commit
lichtblau authored
617
618 (defun emit-signal (object name &rest args)
619 (let* ((meta (class-qmetaobject (class-of object)))
56f99b2 @lichtblau Regression fix and test case for QByteArray unmarshalling
lichtblau authored
620 (signature (#_data (#_QMetaObject::normalizedSignature name)))
baa6bd7 @stassats call-with-signal-marshalling: setup **void for arguments correctly.
stassats authored
621 (index (#_indexOfSignal meta signature))
56f99b2 @lichtblau Regression fix and test case for QByteArray unmarshalling
lichtblau authored
622 (types (mapcar (alexandria:compose #'find-qtype
623 (lambda (x) (#_data x)))
95dcf55 @stassats Fix call-with-signal-marshalling for immediate objects.
stassats authored
624 (#_parameterTypes (#_method meta index)))))
baa6bd7 @stassats call-with-signal-marshalling: setup **void for arguments correctly.
stassats authored
625 (when (/= (length args)
626 (length types))
627 (error "Invalid number of arguments for signal ~a: ~a" signature (length args)))
40cad53 @stassats Make emit-signal work on existing signals from Qt. Not very pretty.
stassats authored
628 (call-with-signal-marshalling
629 (lambda (stack)
95dcf55 @stassats Fix call-with-signal-marshalling for immediate objects.
stassats authored
630 (list (#_QMetaObject::activate object index stack)))
baa6bd7 @stassats call-with-signal-marshalling: setup **void for arguments correctly.
stassats authored
631 types
40cad53 @stassats Make emit-signal work on existing signals from Qt. Not very pretty.
stassats authored
632 args)))
Something went wrong with that request. Please try again.