+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (deftype signal-flags ()
+ '(flags :run-first :run-last :run-cleanup :no-recurse
+ :detailed :action :no-hooks))
+
+ (define-flags-type signal-match-type
+ :id :detail :closure :func :data :unblocked)
+
+ (defclass signal-query (struct)
+ ((id :allocation :alien :type unsigned-int)
+ (name :allocation :alien :type (copy-of string))
+ (type :allocation :alien :type type-number)
+ (flags :allocation :alien :type signal-flags)
+ (return-type :allocation :alien :type type-number)
+ (n-params :allocation :alien :type unsigned-int)
+ (param-types :allocation :alien :type pointer))
+ (:metaclass struct-class)))
+
+(defbinding signal-query
+ (signal-id &optional (signal-query (make-instance 'signal-query))) nil
+ (signal-id unsigned-int)
+ (signal-query signal-query :in/return))
+
+(defun signal-param-types (info)
+ (with-slots (n-params param-types) info
+ (map-c-vector 'list
+ #'(lambda (type-number)
+ (type-from-number type-number))
+ param-types 'type-number n-params)))
+
+
+(defun describe-signal (signal-id &optional type)
+ (let ((info (signal-query (ensure-signal-id-from-type signal-id type))))
+ (with-slots (id name type flags return-type n-params) info
+ (format t "The signal with id ~D is named '~A' and may be emitted on instances of type ~S." id name (type-from-number type t))
+ (when flags
+ (format t " It has the followin invocation flags: ~{~S ~}" flags))
+ (format t "~%~%Signal handlers should take ~A and return ~A~%"
+ (if (zerop n-params)
+ "no arguments"
+ (format nil "arguments with the following types: ~A"
+ (signal-param-types info)))
+ (cond
+ ((= return-type (find-type-number "void")) "no values")
+ ((not (type-from-number return-type)) "values of unknown type")
+ ((format nil "values of type ~S" (type-from-number return-type))))))))
+
+
+;;;; Signal connecting and controlling
+
+(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)))
+
+
+(defbinding %signal-stop-emission () nil