X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/e49e135a8674f44680c3ba7649061d07057e45c6..e86a5b8ff6c0865093e846993d598bcee90c96ba:/glib/gcallback.lisp diff --git a/glib/gcallback.lisp b/glib/gcallback.lisp index 72e24a9..d2a5d78 100644 --- a/glib/gcallback.lisp +++ b/glib/gcallback.lisp @@ -15,7 +15,7 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;; $Id: gcallback.lisp,v 1.2 2001-02-11 21:49:12 espen Exp $ +;; $Id: gcallback.lisp,v 1.9 2004-10-27 14:58:59 espen Exp $ (in-package "GLIB") @@ -26,20 +26,22 @@ (deftype gclosure () 'pointer) -(define-foreign lisp-callback-closure-new () gclosure +(defbinding lisp-callback-closure-new () gclosure (callback-id unsigned-int)) +(defun register-callback-function (function) + (check-type function (or null symbol function)) + (register-user-data function)) +(defun make-callback-closure (function) + (lisp-callback-closure-new (register-callback-function function))) -;;;; Callback mechanism -(defun register-callback-function (function) - (check-type function (or null symbol function)) - (lisp-callback-closure-new (register-user-data function))) +;;;; Callback mechanism (defun callback-trampoline (callback-id params return-value) (let* ((return-type (unless (null-pointer-p return-value) - (type-from-number (gvalue-type return-value)))) + (gvalue-type return-value))) (args nil) (callback-function (find-user-data callback-id))) @@ -50,7 +52,7 @@ (labels ((invoke-callback () (restart-case (unwind-protect - (let ((result (apply callback-function args))) + (let ((result (apply callback-function (reverse args)))) (when return-type (gvalue-set return-value result)))) @@ -77,17 +79,37 @@ (after-gc-hook) +;;;; Timeouts and idle functions -;;;; Signals +(defvar *source-callback-marshal* + (system:foreign-symbol-address "source_callback_marshal")) +(defvar *destroy-notify* + (system:foreign-symbol-address "destroy_notify")) + +(defbinding (timeout-add "g_timeout_add_full") + (function interval &optional (priority 0)) unsigned-int + (priority int) + (interval unsigned-int) + (*source-callback-marshal* pointer) + ((register-callback-function function) unsigned-long) + (*destroy-notify* pointer)) + +(defbinding (idle-add "g_idle_add_full") + (function &optional (priority 0)) unsigned-int + (priority int) + (*source-callback-marshal* pointer) + ((register-callback-function function) unsigned-long) + (*destroy-notify* pointer)) -(defun signal-name-to-string (name) - (substitute #\_ #\- (string-downcase (string name)))) -(define-foreign signal-lookup (name itype) unsigned-int + +;;;; Signals + +(defbinding signal-lookup (name itype) unsigned-int ((signal-name-to-string name) string) (itype type-number)) -(define-foreign signal-name () string +(defbinding signal-name () string (signal-id unsigned-int)) (defun ensure-signal-id (signal-id instance) @@ -96,27 +118,27 @@ (string (signal-lookup signal-id (type-number-of instance))) (symbol (signal-lookup signal-id (type-number-of instance))))) -(define-foreign signal-stop-emission (instance signal-id) nil +(defbinding signal-stop-emission (instance signal-id) nil (instance ginstance) ((ensure-signal-id signal-id instance) unsigned-int)) -; (define-foreign ("g_signal_add_emission_hook_full" signal-add-emisson-hook) +; (defbinding (signal-add-emisson-hook "g_signal_add_emission_hook_full") ; () unsigned-int ; (signal-id unsigned-int) ; (closure gclosure)) -; (define-foreign signal-remove-emisson-hook () nil +; (defbinding signal-remove-emisson-hook () nil ; (signal-id unsigned-int) ; (hook-id unsigned-int)) -(define-foreign ("g_signal_has_handler_pending" signal-has-handler-pending-p) +(defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending") (instance signal-id &key detail blocked) boolean (instance ginstance) ((ensure-signal-id signal-id instance) unsigned-int) ((or detail 0) quark) (blocked boolean)) -(define-foreign ("g_signal_connect_closure_by_id" signal-connect-closure) +(defbinding (signal-connect-closure "g_signal_connect_closure_by_id") (instance signal-id closure &key detail after) unsigned-int (instance ginstance) ((ensure-signal-id signal-id instance) unsigned-int) @@ -124,36 +146,31 @@ (closure gclosure) (after boolean)) -(define-foreign signal-handler-block () nil +(defbinding signal-handler-block () nil (instance ginstance) (handler unsigned-int)) -(define-foreign signal-handler-unblock () nil +(defbinding signal-handler-unblock () nil (instance ginstance) (handler unsigned-int)) -(define-foreign signal-handler-disconnect () nil +(defbinding signal-handler-disconnect () nil (instance ginstance) (handler unsigned-int)) -(defun signal-connect (instance signal function &key after object) - (let ((callback - (cond - ((or (eq object t) (eq object instance)) function) - ((not object) - #'(lambda (&rest args) (apply function (cdr args)))) - (t - #'(lambda (&rest args) (apply function object (rest args))))))) - - (signal-connect-closure - instance signal (register-callback-function callback) :after after))) - - -;;;; Idles and timeouts - -; (defun timeout-remove (tag) -; (source-remove tag)) - -; (defun idle-remove (tag) -; (source-remove tag)) +(defmethod signal-connect ((gobject gobject) signal function &key after object) +"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 of the signal." + (let ((callback-id + (make-callback-closure + (cond + ((or (eq object t) (eq object gobject)) function) + ((not object) + #'(lambda (&rest args) (apply function (cdr args)))) + (t + #'(lambda (&rest args) (apply function object (rest args)))))))) + (signal-connect-closure gobject signal callback-id :after after)))