Make dynamic-bindings for each class.
[commonqt:commonqt.git] / meta.lisp
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
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))
61      (cached-values-bind (dtor) (resolve-delete object)
62          (((qobject-class object) :hash t))
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
101 (defvar *report-memory-leaks* nil)
102
103 (defun cache! (object)
104   (let ((ptr (qobject-pointer object)))
105    ; (assert (null (pointer->cached-object ptr)))
106     (setf (pointer->cached-object ptr) object)
107     (assert (qobject-class object))
108     (map-cpl-using-result (lambda (super casted)
109                             (let ((ptr (%cast casted super)))
110                               (setf (pointer->cached-object ptr) object)
111                               (make-instance 'qobject
112                                              :class super
113                                              :pointer ptr)))
114                           (qobject-class object)
115                           object)
116     (when (typep object 'dynamic-object)
117       (setf (gethash (cffi:pointer-address ptr) *strongly-cached-objects*)
118             object)))
119   (when (and *report-memory-leaks*
120              (or (not (qtypep object (find-qclass "QObject")))
121                  (typep (#_parent object) 'null-qobject)))
122     (tg:finalize object
123                  (let* ((ptr (qobject-pointer object))
124                         (class (qobject-class object))
125                         (str (princ-to-string object))
126                         (qobjectp (qsubclassp class (find-qclass "QObject")))
127                         (dynamicp (typep object 'dynamic-object)))
128                    (lambda ()
129                      (postmortem ptr class str qobjectp dynamicp)))))
130   object)
131
132 (defclass dynamic-member ()
133   ((name :initarg :name
134          :accessor dynamic-member-name)
135    (cached-arg-types :accessor dynamic-member-cached-arg-types)))
136
137 (defclass signal-member (dynamic-member)
138   ())
139
140 (defclass slot-member (dynamic-member)
141   ((function :initarg :function
142              :accessor dynamic-member-function)))
143
144 (defmethod print-object ((instance dynamic-member) stream)
145   (print-unreadable-object (instance stream :type t :identity t)
146     (princ (dynamic-member-name instance) stream)))
147
148 (defmethod print-object ((instance dynamic-object) stream)
149   (print-unreadable-object (instance stream :type t :identity nil)
150     (cond
151       ((not (slot-boundp instance 'class))
152        (format stream "uninitialized"))
153       ((cffi:pointerp (qobject-pointer instance))
154        (format stream "~A 0x~8,'0X"
155                (qclass-name (qobject-class instance))
156                (cffi:pointer-address (qobject-pointer instance))))
157       (t
158        (format stream "~A ~A"
159                (qclass-name (qobject-class instance))
160                (qobject-pointer instance))))))
161
162 (defmethod initialize-instance ((instance dynamic-object) &key)
163   (multiple-value-prog1
164       (call-next-method)
165     (let ((class (class-of instance)))
166       (ensure-qt-class-caches class)
167       (setf (qobject-class instance) (class-effective-class class)))))
168
169 (defmethod initialize-instance :around ((instance dynamic-object) &key)
170   (multiple-value-prog1
171       (call-next-method)
172     (unless (cffi:pointerp (qobject-pointer instance))
173       (error "INITIALIZE-INSTANCE of ~A failed to call Qt constructor"
174              instance))))
175
176 (defclass qt-class (standard-class)
177   ((qt-superclass :initarg :qt-superclass
178                   :accessor class-qt-superclass)
179    (signals :initarg :signals
180             :accessor class-signals)
181    (qt-slots :initarg :slots
182              :accessor class-slots)
183    (override-specs :initarg :override
184                    :accessor class-override-specs)
185    (class-infos :initarg :info
186                 :accessor class-class-infos)
187    (effective-class :initform nil)
188    (qmetaobject :initform nil)
189    (smoke-generation :initform nil
190                      :accessor class-smoke-generation)
191    (generation :initform nil
192                :accessor class-generation)
193    (member-table :accessor class-member-table)
194    (overrides :accessor class-overrides)
195    (binding :initform nil
196             :accessor class-binding)))
197
198 (defun default-overrides ()
199   (let ((overrides (make-hash-table :test 'equal)))
200     (setf (gethash "qt_metacall" overrides) 'qt_metacall-override)
201     overrides))
202
203 (defmethod c2mop:validate-superclass
204     ((class qt-class) (superclass t))
205   nil)
206
207 (defmethod c2mop:validate-superclass
208     ((class standard-class) (superclass qt-class))
209   nil)
210
211 (defmethod c2mop:validate-superclass
212     ((class qt-class) (superclass standard-class))
213   (eq superclass (find-class 'dynamic-object)))
214
215 (defmethod c2mop:validate-superclass
216     ((class qt-class) (superclass qt-class))
217   t)
218
219 (defun parse-function (form)
220   ;; this run-time use of COMPILE is a huge kludge.  We'd just want to hook
221   ;; into the DEFCLASS expansion like slots and init functions can, but
222   ;; those are special built-in features of DEFCLASS which meta classes
223   ;; cannot implement for their own options.  Big oversight in the MOP IMNSHO.
224   (etypecase (macroexpand form)
225     ((or symbol function)
226      form)
227     ((cons (eql lambda) t)
228      (compile nil form))
229     ((cons (eql function) t)
230      (eval form))))
231
232 (defun compute-dynamic-member (description type acessor direct-superclasses)
233   (let ((result
234           (loop for (name . value) in description
235                 when (or (not value)
236                          (car value))
237                 collect
238                 (if value
239                     (make-instance type
240                                    :name name
241                                    :function (parse-function (car value)))
242                     (make-instance type :name name)))))
243     (loop for class in direct-superclasses
244           when (typep class 'qt-class)
245           do (loop for object in (funcall acessor class)
246                    unless (find (dynamic-member-name object)
247                                 description
248                                 :key #'car :test #'equal)
249                    do (pushnew object result
250                                :test #'equal
251                                :key #'dynamic-member-name)))
252     result))
253
254 (defun qt-class-compute-superclasses (direct-superclasses)
255   (let ((qt-class (find-class 'qt-class))
256         (standard-object (find-class 'standard-object))
257         (dynamic-object (find-class 'dynamic-object)))
258     (if (some (lambda (c) (typep c qt-class))
259               direct-superclasses)
260         direct-superclasses
261         (append (if (equal direct-superclasses (list standard-object))
262                     nil
263                     direct-superclasses)
264                 (list dynamic-object)))))
265
266 (defun initialize-qt-class
267     (class next-method &rest args
268      &key qt-superclass direct-superclasses slots signals info override
269      &allow-other-keys)
270   (let* ((qt-superclass
271            (if qt-superclass
272                (destructuring-bind (name) qt-superclass
273                  (check-type name string)
274                  name)
275                nil))
276          (direct-superclasses
277            (qt-class-compute-superclasses direct-superclasses))
278          (slots
279            (compute-dynamic-member slots 'slot-member
280                                    #'class-slots direct-superclasses))
281          (signals
282            (compute-dynamic-member signals 'signal-member
283                                    #'class-signals direct-superclasses))
284          (class-infos
285            (iter (for (name value) in info)
286              (collect (make-class-info name value))))
287          (override-specs
288            (iter (for (method fun) in override)
289              (collect (make-instance 'override-spec
290                                      :method-name method
291                                      :target-function
292                                      (parse-function fun))))))
293     (apply next-method
294            class
295            :allow-other-keys t
296            :direct-superclasses direct-superclasses
297            :qt-superclass qt-superclass
298            :slots slots
299            :signals signals
300            :info class-infos
301            :override override-specs
302            args)))
303
304 (defmethod initialize-instance :around ((instance qt-class) &rest args)
305   (apply #'initialize-qt-class instance #'call-next-method args))
306
307 (defmethod reinitialize-instance :around ((instance qt-class) &rest args)
308   (apply #'initialize-qt-class instance #'call-next-method args))
309
310 (defun get-qt-class-member (qt-class id)
311   (let ((table (class-member-table qt-class)))
312     (when (< id (length table))
313       (elt table id))))
314
315 (defun make-override-table (specs)
316   (let ((table (make-hash-table :test 'equal)))
317     (dolist (spec specs)
318       (setf (gethash (override-spec-method-name spec) table)
319             (override-spec-target-function spec)))
320     table))
321
322 (defclass override-spec ()
323   ((method-name :initarg :method-name
324                 :accessor override-spec-method-name)
325    (target-function :initarg :target-function
326                     :accessor override-spec-target-function)))
327
328 (defun merge-overrides (a b)
329   (let ((c (make-hash-table :test 'equal)))
330     (maphash (lambda (k v) (setf (gethash k c) v )) a)
331     (maphash (lambda (k v) (unless (gethash k c) (setf (gethash k c) v))) b)
332     c))
333
334 (defmethod c2mop:finalize-inheritance :after ((object qt-class))
335   (dolist (super (c2mop:class-direct-superclasses object))
336     (unless (c2mop:class-finalized-p super)
337       (c2mop:finalize-inheritance super)))
338   (with-slots (qmetaobject qt-superclass member-table signals qt-slots
339                            overrides)
340       object
341     (setf qmetaobject
342           ;; clear out any old QMetaObject, so that ensure-metaobject will
343           ;; set up a new one
344           nil)
345     (setf qt-superclass
346           (or qt-superclass
347               (class-qt-superclass
348                (or (find-if (lambda (x) (typep x 'qt-class))
349                             (c2mop:class-direct-superclasses object))
350                    (error "No effective Qt class name declared for ~A"
351                           object)))))
352     (setf overrides (make-override-table (class-override-specs object)))
353     (let ((supers (remove-if-not (lambda (super)
354                                    (typep super 'qt-class))
355                                  (c2mop:class-direct-superclasses object))))
356       (if supers
357           (dolist (super supers)
358             (setf overrides
359                   (merge-overrides overrides (class-overrides super))))
360           (setf overrides (merge-overrides overrides (default-overrides)))))
361     (setf member-table (concatenate 'vector signals qt-slots))))
362
363 (defun %qobject-metaobject ()
364   (or *qobject-metaobject*
365       (setf *qobject-metaobject*
366             (let ((qobj (optimized-new (find-qclass "QObject"))))
367               (prog1
368                   (#_metaObject qobj)
369                 (#_delete qobj))))))
370
371 (defun inform-cpp-about-override (qclass binding method-name)
372   (map-class-methods-named
373    (lambda (<method>)
374      (sw_override binding (unbash* <method> +method+)
375                   t))
376    qclass
377    method-name))
378
379 (defun inform-cpp-about-overrides (qt-class)
380   (let ((<class> (slot-value qt-class 'effective-class))
381         (binding (class-binding qt-class)))
382     (loop for method-name being the hash-key of (class-overrides qt-class)
383           do (inform-cpp-about-override <class> binding method-name))))
384
385 (defun meta-object-method-index (qt-class)
386   (map-class-methods-named
387    (lambda (<method>)
388      (return-from meta-object-method-index
389        (values (unbash* <method> +method+))))
390    (slot-value qt-class 'effective-class)
391    "metaObject"))
392
393 (defun set-class-binding (qt-class)
394   (multiple-value-bind (idx <module>)
395       (unbash* (slot-value qt-class 'effective-class) +class+)
396     (declare (ignore idx))
397     (setf (class-binding qt-class)
398           (sw_make_dynamic_binding (module-ref <module>)
399                                    (qobject-pointer
400                                     (slot-value qt-class 'qmetaobject))
401                                    (meta-object-method-index qt-class)
402                                    (cffi:callback deletion-callback)
403                                    (cffi:callback method-invocation-callback)
404                                    (cffi:callback child-callback)))))
405
406 (defun ensure-qt-class-caches (qt-class)
407   (check-type qt-class qt-class)
408   (with-slots (effective-class qmetaobject smoke-generation generation)
409       qt-class
410     (unless (and qmetaobject
411                  effective-class
412                  (eq smoke-generation *weakly-cached-objects*))
413       ;; clear everything out to ensure a clean state in case of errors
414       ;; in the following forms
415       (setf effective-class nil)
416       (setf qmetaobject nil)
417       (setf smoke-generation nil)
418       ;; reinitialize things
419       (setf effective-class (find-qclass
420                              (class-qt-superclass qt-class)))
421       (setf qmetaobject
422             (let* ((class (find-qclass
423                            (class-qt-superclass qt-class)))
424                    (qobject-class (find-qclass "QObject"))
425                    (parent (cond
426                              ((eq class qobject-class)
427                               (%qobject-metaobject))
428                              ((qsubclassp class qobject-class)
429                               (#_staticMetaObject class))
430                              (t
431                               (null-qobject (find-qclass "QMetaObject"))))))
432               (make-metaobject parent
433                                (let ((name (class-name qt-class)))
434                                  (format nil "~A::~A"
435                                          (package-name (symbol-package name))
436                                          (symbol-name name)))
437                                (class-class-infos qt-class)
438                                (mapcar #'convert-dynamic-member
439                                        (class-signals qt-class))
440                                (mapcar #'convert-dynamic-member
441                                        (class-slots qt-class)))))
442       (set-class-binding qt-class)
443       (inform-cpp-about-overrides qt-class)
444       ;; invalidate call site caches
445       (setf generation (gensym))
446       ;; mark as fresh
447       (setf (class-smoke-generation qt-class) *weakly-cached-objects*))))
448
449 (defun convert-dynamic-member (member)
450   (make-slot-or-signal (dynamic-member-name member)))
451
452 (defun class-effective-class (qt-class &optional (errorp t))
453   (ensure-qt-class-caches qt-class)
454   (or (slot-value qt-class 'effective-class)
455       (when errorp
456         (error "effective-class not cached?"))))
457
458 (defun class-qmetaobject (qt-class)
459   (ensure-qt-class-caches qt-class)
460   (slot-value qt-class 'qmetaobject))
461
462 (defun find-method-override (object method)
463   (if (typep object 'dynamic-object)
464       (find-method-override-using-class (class-of object) method)
465       nil))
466
467 (defun find-method-override-using-class (class method)
468   (gethash (qmethod-name method) (class-overrides class)))
469
470 (defvar *next-qmethod-trampoline* nil)
471 (defvar *next-qmethod* nil)
472
473 (defun call-next-qmethod (&rest args)
474   (unless *next-qmethod-trampoline*
475     (error "call-next-qmethod used outside of overriding method"))
476   (funcall *next-qmethod-trampoline* args))
477
478 (defun get-next-qmethod ()
479   (or *next-qmethod*
480       (error "get-next-qmethod used outside of overriding method")))
481
482 (defun override (fun object <method> args)
483   (let* ((method-name
484           ;; dispatch on the method name rather than method index,
485           ;; because the index sometimes points to a superclass method
486           ;; rather than the specific class we want.  Don't know why.
487           ;; Run-time lookup of the name ensures that we get the most
488           ;; specific method that OBJECT has.
489           (qmethod-name <method>))
490          (*next-qmethod* method-name)
491          (*next-qmethod-trampoline*
492           (lambda (new-args)
493             (apply #'interpret-call-without-override
494                    object
495                    method-name
496                    (or new-args args)))))
497     (apply fun object args)))
498
499 (defgeneric dynamic-object-member (object id)
500   (:method (object id)
501     (declare (ignore object id))
502     nil))
503
504 (defun qt_metacall-override (object call id stack)
505   (let ((new-id (call-next-qmethod)))
506     (cond
507       ((or (minusp new-id)
508            (not (eql (primitive-value call)
509                      (primitive-value (#_QMetaObject::InvokeMetaMethod)))))
510        id)
511       (t
512        (let ((member
513               (or
514                (get-qt-class-member (class-of object) new-id)
515                (dynamic-object-member object new-id)
516                (error "QT_METACALL-OVERRIDE: invalid member id ~A" id))))
517          (etypecase member
518            (signal-member
519             (#_activate (class-qmetaobject (class-of object))
520                          object
521                          id
522                          stack)
523             -1)
524            (slot-member
525             (apply (dynamic-member-function member)
526                    object
527                    (unmarshal-slot-args member stack))
528             -1)))))))
529
530 (defun guess-stack-item-slot (x)
531   (case x
532     (:|int| 'int)
533     (:|uint| 'uint)
534     (:|bool| 'bool)
535     (:|QString| 'ptr)
536     (t (error "Don't know how to unmarshal slot argument ~s" x))))
537
538 (defun ensure-dynamic-member-types (member)
539   (with-slots (cached-arg-types) member
540     (unless (slot-boundp member 'cached-arg-types)
541       (setf cached-arg-types
542             (mapcar (lambda (name)
543                       (or (find-qtype name)
544                           (error "No smoke type found for dynamic member arg type ~A.  Giving up."
545                                  name)))
546                     (cl-ppcre:split
547                      ","
548                      (entry-arg-types (convert-dynamic-member member))))))
549     cached-arg-types))
550
551 (defun unmarshal-slot-args (member argv)
552   (iter (for type in (ensure-dynamic-member-types member))
553         (for i from 1)
554         (collect (cond ((eq (qtype-interned-name type) ':|QString|)
555                         (qstring-pointer-to-lisp
556                          (cffi:mem-aref argv :pointer i)))
557                        ((and
558                          (eq (qtype-kind type) :stack)
559                          (eq (qtype-stack-item-slot type) 'class))
560                         (unmarshal type (cffi:inc-pointer argv
561                                                           (* i
562                                                              (cffi:foreign-type-size :pointer)))))
563                        (t
564                         (unmarshal type (cffi:mem-aref argv :pointer i)))))))
565
566 (defclass class-info ()
567   ((key :initarg :key
568         :accessor entry-key)
569    (value :initarg :value
570           :accessor entry-value)))
571
572 (defclass slot-or-signal ()
573   ((name :initarg :name
574          :accessor entry-name)
575    (full-name :initarg :full-name
576               :accessor entry-full-name)
577    (arg-types :initarg :arg-types
578               :accessor entry-arg-types)
579    (reply-type :initarg :reply-type
580                :accessor entry-reply-type)))
581
582 (defun make-class-info (key value)
583   (make-instance 'class-info :key key :value value))
584
585 (defun make-slot-or-signal (str)
586   (let ((str (#_data (#_QMetaObject::normalizedSignature str))))
587     (or
588      (cl-ppcre:register-groups-bind (a b c d)
589          ("^(([\\w,<>:]*)\\s+)?([^\\s]*)\\((.*)\\)" str)
590        (declare (ignore a))
591        (make-instance 'slot-or-signal
592                       :name c
593                       :full-name (concatenate 'string c "(" d ")")
594                       :arg-types d
595                       :reply-type (if (or (null b) (equal b "void")) "" b)))
596      (error "Invalid slot or signal signature: ~s" str))))
597
598 (defconstant +AccessPrivate+ #x00)
599 (defconstant +AccessProtected+ #x01)
600 (defconstant +AccessPublic+ #x02)
601 (defconstant +MethodMethod+ #x00)
602 (defconstant +MethodSignal+ #x04)
603 (defconstant +MethodSlot+ #x08)
604 (defconstant +MethodCompatibility+ #x10)
605 (defconstant +MethodCloned+ #x20)
606 (defconstant +MethodScriptable+ #x40)
607
608 (defun make-metaobject (parent class-name class-infos signals slots)
609   (let ((data (make-array 0 :fill-pointer 0 :adjustable t))
610         (table (make-hash-table))
611         (stream (make-string-output-stream)))
612     (labels ((intern-string (s)
613                (or (gethash s table)
614                    (setf (gethash s table)
615                          (prog1
616                              (file-position stream)
617                            (write-string s stream)
618                            (write-char (code-char 0) stream)))))
619              (add (x) (vector-push-extend x data))
620              (add-string (s) (add (intern-string s))))
621       (add 1)                           ;revision
622       (add (intern-string class-name))  ;class name
623       (add (length class-infos))        ;classinfo
624       (add (if (plusp (length class-infos)) 10 0))
625       (add (+ (length signals) (length slots)))
626       (add (+ 10 (* 2 (length class-infos)))) ;methods
627       (add 0)                                 ;properties
628       (add 0)
629       (add 0)                           ;enums/sets
630       (add 0)
631       (dolist (entry class-infos)
632         (add-string (entry-key entry))
633         (add-string (entry-value entry)))
634       (dolist (entry signals)
635         (add-string (entry-full-name entry))
636         (add-string (remove #\, (entry-full-name entry) :test-not #'eql))
637         (add-string (entry-reply-type entry))
638         (add-string "")                 ;tag
639         (add (logior +methodsignal+ +accessprotected+)))
640       (dolist (entry slots)
641         (add-string (entry-full-name entry))
642         (add-string (remove #\, (entry-full-name entry) :test-not #'eql))
643         (add-string (entry-reply-type entry))
644         (add-string "")                 ;tag
645         (add (logior +methodslot+ +accesspublic+)))
646       (add 0))
647     (let ((dataptr (cffi:foreign-alloc :int :count (length data))))
648       (dotimes (i (length data))
649         (setf (cffi:mem-aref dataptr :int i) (elt data i)))
650       (cache!
651        (%qobject (find-qclass "QMetaObject")
652                  (sw_make_metaobject (qobject-pointer parent)
653                                      (cffi:foreign-string-alloc
654                                       (get-output-stream-string stream))
655                                      dataptr))))))
656
657 (defun call-with-signal-marshalling (fun types args)
658   (let ((arg-count (length args)))
659     (cffi:with-foreign-object (argv :pointer (1+ arg-count))
660       (cffi:with-foreign-object (stack '|union StackItem| arg-count)
661         (labels ((iterate (i rest-types rest-args)
662                           (cond
663                             (rest-args
664                              (let* ((stack-item (cffi:mem-aref stack '|union StackItem| i))
665                                     (arg (car rest-args))
666                                     (type (car rest-types))
667                                     (slot-type (qtype-stack-item-slot type)))
668                                (marshal arg type stack-item
669                                         (lambda ()
670                                           (setf (cffi:mem-aref argv :pointer (1+ i))
671                                                 (if (or (eql slot-type 'ptr)
672                                                         (eql slot-type 'class))
673                                                     (cffi:mem-aref stack-item :pointer)
674                                                     stack-item))
675                                           (iterate (1+ i)
676                                                    (cdr rest-types)
677                                                    (cdr rest-args))))))
678                             (t
679                              (funcall fun argv)))))
680           (iterate 0 types args))))))
681
682 (defun emit-signal (object name &rest args)
683   (let* ((meta (class-qmetaobject (class-of object)))
684          (signature (#_data (#_QMetaObject::normalizedSignature name)))
685          (index (#_indexOfSignal meta signature))
686          (types (and (>= index 0)
687                      (mapcar (lambda (x) (find-qtype (#_data x)))
688                              (#_parameterTypes (#_method meta index))))))
689     (when (= index -1)
690       (error "Signal ~a doesn't exist for ~s" signature object))
691     (when (/= (length args) (length types))
692       (error "Invalid number of arguments for signal ~a: ~a"
693              signature (length args)))
694     (call-with-signal-marshalling
695      (lambda (stack)
696        (list (#_QMetaObject::activate object index stack)))
697      types
698      args)))