+(define-flags-type connect-flags :after :swapped)
+
+(defvar *signal-override-closures* (make-hash-table :test 'equalp))
+
+(defbinding %%signal-override-class-closure () nil
+ (signal-id unsigned-int)
+ (type-number type-number)
+ (callback-closure pointer))
+
+
+(defun %signal-override-class-closure (type name function)
+ (multiple-value-bind (callback-closure callback-id)
+ (make-callback-closure function class-handler-marshal)
+ (let ((signal-id (ensure-signal-id-from-type name type)))
+ (%%signal-override-class-closure signal-id (find-type-number type t) callback-closure))
+ (setf
+ (gethash (list type name) *signal-override-closures*)
+ (list callback-id function))))
+
+(defun signal-override-class-closure (name type function)
+ (let ((callback-id
+ (first (gethash (list type name) *signal-override-closures*))))
+ (if callback-id
+ (update-user-data callback-id function)
+ (%signal-override-class-closure type name function))))
+
+(defun reinitialize-signal-override-class-closures ()
+ (maphash
+ #'(lambda (key value)
+ (destructuring-bind (type name) key
+ (destructuring-bind (callback-id function) value
+ (declare (ignore callback-id))
+ (%signal-override-class-closure type name function))))
+ *signal-override-closures*))
+
+(defbinding %signal-chain-from-overridden () nil
+ (args pointer)
+ (return-value (or null gvalue)))
+
+
+(defun %call-next-handler (n-params types args return-type)
+ (let ((params (allocate-memory (* n-params +gvalue-size+))))
+ (loop
+ for arg in args
+ for type in types
+ for offset from 0 by +gvalue-size+
+ do (gvalue-init (pointer+ params offset) type arg))
+
+ (unwind-protect
+ (if return-type
+ (with-gvalue (return-value return-type)
+ (%signal-chain-from-overridden params return-value))
+ (%signal-chain-from-overridden params nil))
+ (progn
+ (loop
+ repeat n-params
+ for offset from 0 by +gvalue-size+
+ do (gvalue-unset (pointer+ params offset)))
+ (deallocate-memory params)))))
+
+(defmacro define-signal-handler (name ((object class) &rest args) &body body)
+ (let* ((info (signal-query (ensure-signal-id-from-type name class)))
+ (types (cons class (signal-param-types info)))
+ (n-params (1+ (slot-value info 'n-params)))
+ (return-type (type-from-number (slot-value info 'return-type)))
+ (vars (loop
+ for arg in args
+ until (eq arg '&rest)
+ collect arg))
+ (rest (cadr (member '&rest args)))
+ (next (make-symbol "ARGS"))
+ (default (make-symbol "DEFAULT")))
+
+ `(progn
+ (signal-override-class-closure ',name ',class
+ #'(lambda (,object ,@args)
+ (let ((,default (list* ,object ,@vars ,rest)))
+ (flet ((call-next-handler (&rest ,next)
+ (%call-next-handler
+ ,n-params ',types (or ,next ,default) ',return-type)))
+ ,@body))))
+ ',name)))
+
+