X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/e49e135a8674f44680c3ba7649061d07057e45c6..34f9e1d49c0b952ab3042362c54d85520992927f:/glib/gcallback.lisp?ds=sidebyside diff --git a/glib/gcallback.lisp b/glib/gcallback.lisp index 72e24a9..ee11387 100644 --- a/glib/gcallback.lisp +++ b/glib/gcallback.lisp @@ -15,79 +15,93 @@ ;; 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.11 2004-11-01 00:08:49 espen Exp $ (in-package "GLIB") (use-prefix "g") -;;;; Closures +;;;; Callback mechanism (deftype gclosure () 'pointer) -(define-foreign lisp-callback-closure-new () gclosure - (callback-id unsigned-int)) +(defbinding (callback-closure-new "clg_callback_closure_new") () gclosure + (callback-id unsigned-int) + (callback pointer) + (destroy-notify pointer)) +(defun register-callback-function (function) + (check-type function (or null symbol function)) + (register-user-data function)) +(def-callback closure-callback-marshal + (void (gclosure system-area-pointer) (return-value system-area-pointer) + (n-params unsigned-int) (param-values system-area-pointer) + (invocation-hint system-area-pointer) (callback-id unsigned-int)) + (callback-trampoline callback-id n-params param-values return-value)) -;;;; Callback mechanism +(def-callback %destroy-user-data (void (id unsigned-int)) + (destroy-user-data id)) + +(defun make-callback-closure (function) + (callback-closure-new + (register-callback-function function) + (callback closure-callback-marshal) (callback %destroy-user-data))) -(defun register-callback-function (function) - (check-type function (or null symbol function)) - (lisp-callback-closure-new (register-user-data function))) -(defun callback-trampoline (callback-id params return-value) +(defun callback-trampoline (callback-id n-params param-values return-value) (let* ((return-type (unless (null-pointer-p return-value) - (type-from-number (gvalue-type return-value)))) - (args nil) - (callback-function (find-user-data callback-id))) - - (destructuring-bind (nparams . param-values) params - (dotimes (n nparams) - (push (gvalue-get (sap+ param-values (* n +gvalue-size+))) args))) - - (labels ((invoke-callback () - (restart-case - (unwind-protect - (let ((result (apply callback-function args))) - (when return-type - (gvalue-set return-value result)))) - - (continue nil :report "Return from callback function" - (when return-type - (format - *query-io* - "Enter return value of type ~S: " - return-type) - (force-output *query-io*) - (gvalue-set return-value (eval (read *query-io*))))) - (re-invoke nil :report "Re-invoke callback function" - (invoke-callback))))) - (invoke-callback)))) - -(defun after-gc-hook () - (setf - (extern-alien "callback_trampoline" system-area-pointer) - (make-pointer (kernel:get-lisp-obj-address #'callback-trampoline)) - (extern-alien "destroy_user_data" system-area-pointer) - (make-pointer (kernel:get-lisp-obj-address #'destroy-user-data)))) - -(pushnew 'after-gc-hook ext:*after-gc-hooks*) -(after-gc-hook) + (gvalue-type return-value))) + (args (loop + for n from 0 below n-params + collect (gvalue-get (sap+ param-values (* n +gvalue-size+)))))) + (let ((result (apply #'invoke-callback callback-id return-type args))) + (when return-type + (gvalue-set return-value result))))) +(defun invoke-callback (callback-id type &rest args) + (restart-case + (apply (find-user-data callback-id) args) + (continue nil :report "Return from callback function" + (when type + (format *query-io* "Enter return value of type ~S: " type) + (force-output *query-io*) + (eval (read *query-io*)))) + (re-invoke nil :report "Re-invoke callback function" + (apply #'invoke-callback callback-id type args)))) -;;;; Signals -(defun signal-name-to-string (name) - (substitute #\_ #\- (string-downcase (string name)))) +;;;; Timeouts and idle functions + +(def-callback source-callback-marshal (void (callback-id unsigned-int)) + (callback-trampoline callback-id 0 nil (make-pointer 0))) + +(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) + ((callback %destroy-user-data) 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) + ((callback %destroy-user-data) pointer)) -(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 +110,27 @@ (defun ensure-signal-id (signal-id instance) (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 +138,42 @@ (define-foreign ("g_signal_connect_closure_by_id" signal-connect-closure) (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))) + + +;;; Message logging + +;; TODO: define and signal conditions based on log-level +;(defun log-handler (domain log-level message) +(def-callback log-handler (void (domain c-string) (log-level int) + (message c-string)) + (error "~A: ~A" domain message)) + +(setf (extern-alien "log_handler" system-area-pointer) (callback log-handler))