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