+(defbinding (closure-new "g_cclosure_new") () gclosure
+ ((make-pointer #xFFFFFFFF) pointer)
+ (callback-id unsigned-int)
+ (destroy-notify callback))
+
+(defbinding closure-set-meta-marshal () nil
+ (gclosure gclosure)
+ (callback-id unsigned-int)
+ (callback callback))
+
+(defun callback-closure-new (callback-id callback destroy-notify)
+ (let ((gclosure (closure-new callback-id destroy-notify)))
+ (closure-set-meta-marshal gclosure callback-id callback)
+ gclosure))
+
+(defun make-callback-closure (function &optional (marshaller signal-handler-marshal))
+ (let ((callback-id (register-callback-function function)))
+ (values
+ (callback-closure-new callback-id marshaller user-data-destroy-callback)
+ callback-id)))
+
+(defgeneric compute-signal-function (gobject signal function object args))
+
+(defmethod compute-signal-function ((gobject gobject) signal function object args)
+ (declare (ignore signal))
+ (cond
+ ((or (eq object t) (eq object gobject))
+ (if args
+ #'(lambda (&rest emission-args)
+ (apply function (nconc emission-args args)))
+ function))
+ (object
+ (if args
+ #'(lambda (&rest emission-args)
+ (apply function object (nconc (rest emission-args) args)))
+ #'(lambda (&rest emission-args)
+ (apply function object (rest emission-args)))))
+ (args
+ #'(lambda (&rest emission-args)
+ (apply function (nconc (rest emission-args) args))))
+ (t
+ #'(lambda (&rest emission-args)
+ (apply function (rest emission-args))))))
+
+(defgeneric compute-signal-id (gobject signal))
+
+(defmethod compute-signal-id ((gobject gobject) signal)
+ (ensure-signal-id signal gobject))
+
+
+(defgeneric signal-connect (gobject signal function &key detail after object remove args))
+
+(defmethod signal-connect :around ((gobject gobject) signal function &rest args)
+ (declare (ignore gobject signal args))
+ (when function
+ (call-next-method)))
+
+
+(defmethod signal-connect ((gobject gobject) signal function
+ &key detail after object remove args)
+"Connects a callback function to a signal for a particular object. If
+:OBJECT is T, the object connected to is passed as the first argument
+to the callback function, or if :OBJECT is any other non NIL value, it
+is passed as the first argument instead. If :AFTER is non NIL, the
+handler will be called after the default handler for the signal. If
+:REMOVE is non NIL, the handler will be removed after beeing invoked
+once. ARGS is a list of additional arguments passed to the callback
+function."
+(let* ((signal-id (compute-signal-id gobject signal))
+ (detail-quark (if detail (quark-intern detail) 0))
+ (signal-stop-emission
+ #'(lambda ()
+ (%signal-stop-emission gobject signal-id detail-quark)))
+ (callback (compute-signal-function gobject signal function object args))
+ (wrapper #'(lambda (&rest args)
+ (let ((*signal-stop-emission* signal-stop-emission))
+ (apply callback args)))))
+ (multiple-value-bind (closure-id callback-id)
+ (make-callback-closure wrapper signal-handler-marshal)
+ (let ((handler-id (%signal-connect-closure-by-id
+ gobject signal-id detail-quark closure-id after)))
+ (when remove
+ (update-user-data callback-id
+ #'(lambda (&rest args)
+ (unwind-protect
+ (let ((*signal-stop-emission* signal-stop-emission))
+ (apply callback args))
+ (when (signal-handler-is-connected-p gobject handler-id)
+ (signal-handler-disconnect gobject handler-id))))))
+ handler-id))))
+
+
+;;;; Signal emission
+
+(defbinding %signal-emitv () nil
+ (gvalues pointer)
+ (signal-id unsigned-int)
+ (detail quark)
+ (return-value gvalue))
+
+(defvar *signal-emit-functions* (make-hash-table))
+
+(defun create-signal-emit-function (signal-id)
+ (let ((info (signal-query signal-id)))
+ (let* ((type (type-from-number (slot-value info 'type)))
+ (param-types (cons type (signal-param-types info)))
+ (return-type (type-from-number (slot-value info 'return-type)))
+ (n-params (1+ (slot-value info 'n-params)))
+ (params (allocate-memory (* n-params +gvalue-size+))))
+ #'(lambda (detail object &rest args)
+ (unless (= (length args) (1- n-params))
+ (error "Invalid number of arguments in emmision of signal ~A: ~A" signal-id (length args)))
+ (unwind-protect
+ (loop
+ for arg in (cons object args)
+ for type in param-types
+ as tmp = params then (pointer+ tmp +gvalue-size+)
+ do (gvalue-init tmp type arg)
+ finally
+ (if return-type
+ (return
+ (with-gvalue (return-value)
+ (%signal-emitv params signal-id detail return-value)))
+ (%signal-emitv params signal-id detail (make-pointer 0))))
+ (loop
+ repeat n-params
+ as tmp = params then (pointer+ tmp +gvalue-size+)
+ while (gvalue-p tmp)
+ do (gvalue-unset tmp)))))))
+
+(defun signal-emit-with-detail (object signal detail &rest args)
+ (let* ((signal-id (ensure-signal-id signal object))
+ (function (or
+ (gethash signal-id *signal-emit-functions*)
+ (setf
+ (gethash signal-id *signal-emit-functions*)
+ (create-signal-emit-function signal-id)))))
+ (apply function detail object args)))
+
+(defun signal-emit (object signal &rest args)
+ (apply #'signal-emit-with-detail object signal 0 args))
+
+
+;;;; Signal registration
+
+(defbinding %signal-newv (name itype flags return-type param-types)
+ unsigned-int
+ ((signal-name-to-string name) string)
+ (itype gtype)
+ (flags signal-flags)
+ (nil null) ; class closure
+ (nil null) ; accumulator
+ (nil null) ; accumulator data
+ (nil null) ; c marshaller
+ (return-type gtype)
+ ((length param-types) unsigned-int)
+ (param-types (vector gtype)))
+
+(defun signal-new (name itype flags return-type param-types)
+ (when (zerop (signal-lookup name itype))
+ (%signal-newv name itype flags return-type param-types)))
~mdw / clg / blobdiff