+(defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
+ (callback-id unsigned-int)
+ (callback callback)
+ (destroy-notify callback))
+
+(defun make-callback-closure (function)
+ (let ((callback-id (register-callback-function function)))
+ (values
+ (callback-closure-new callback-id closure-marshal user-data-destroy-callback)
+ callback-id)))
+
+(defgeneric compute-signal-function (gobject signal function object))
+
+(defmethod compute-signal-function ((gobject gobject) signal function object)
+ (declare (ignore signal))
+ (cond
+ ((or (eq object t) (eq object gobject)) function)
+ ((not object)
+ #'(lambda (&rest args) (apply function (rest args))))
+ (t
+ #'(lambda (&rest args) (apply function object (rest 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))
+
+(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)
+"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."
+(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))
+ (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)
+ (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))
+ (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: ~A" (+ 2 (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))
+
+
+;;;; Convenient macros
+
+(defmacro define-callback-marshal (name return-type args &key (callback-id :last))
+ (let* ((ignore ())
+ (params ())
+ (names (loop
+ for arg in args
+ collect (if (or
+ (eq arg :ignore)
+ (and (consp arg) (eq (first arg) :ignore)))
+ (let ((name (gensym "IGNORE")))
+ (push name ignore)
+ name)
+ (let ((name (if (atom arg)
+ (gensym (string arg))
+ (first arg))))
+ (push name params)
+ name))))
+ (types (loop
+ for arg in args
+ collect (cond
+ ((eq arg :ignore) 'pointer)
+ ((atom arg) arg)
+ (t (second arg))))))
+ `(define-callback ,name ,return-type
+ ,(ecase callback-id
+ (:first `((callback-id unsigned-int) ,@(mapcar #'list names types)))
+ (:last `(,@(mapcar #'list names types) (callback-id unsigned-int))))
+ (declare (ignore ,@ignore))
+ (invoke-callback callback-id ',return-type ,@(nreverse params)))))
+
+(defmacro with-callback-function ((id function) &body body)
+ `(let ((,id (register-callback-function ,function)))
+ (unwind-protect
+ (progn ,@body)
+ (destroy-user-data ,id))))
~mdw / clg / blobdiff