X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/e49e135a8674f44680c3ba7649061d07057e45c6..1ff84b0665062c842c5eb53c91d69c68249c87b5:/glib/gcallback.lisp diff --git a/glib/gcallback.lisp b/glib/gcallback.lisp index 72e24a9..ca406e9 100644 --- a/glib/gcallback.lisp +++ b/glib/gcallback.lisp @@ -15,79 +15,110 @@ ;; 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.16 2004-12-05 13:54:10 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)) - - - -;;;; Callback mechanism +(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)) - (lisp-callback-closure-new (register-user-data function))) - -(defun callback-trampoline (callback-id params return-value) + (register-user-data function)) + +(defcallback closure-callback-marshal (nil + (gclosure pointer) + (return-value gvalue) + (n-params unsigned-int) + (param-values pointer) + (invocation-hint pointer) + (callback-id unsigned-int)) + (callback-trampoline callback-id n-params param-values return-value)) + +(defcallback %destroy-user-data (nil (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 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 return-type &rest args) + (restart-case + (apply (find-user-data callback-id) args) + (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*) + (eval (read *query-io*)))) + (re-invoke nil :report "Re-invoke callback function" + (apply #'invoke-callback callback-id return-type args)))) + + +;;;; Timeouts and idle functions + +(defconstant +priority-high+ -100) +(defconstant +priority-default+ 0) +(defconstant +priority-high-idle+ 100) +(defconstant +priority-default-idle+ 200) +(defconstant +priority-low+ 300) + +(defbinding source-remove () boolean + (tag unsigned-int)) + +(defcallback source-callback-marshal (nil (callback-id unsigned-int)) + (callback-trampoline callback-id 0 nil (make-pointer 0))) + +(defbinding (timeout-add "g_timeout_add_full") + (interval function &optional (priority +priority-default+)) unsigned-int + (priority int) + (interval unsigned-int) + ((callback source-callback-marshal) pointer) + ((register-callback-function function) unsigned-long) + ((callback %destroy-user-data) pointer)) + +(defun timeout-remove (timeout) + (source-remove timeout)) + +(defbinding (idle-add "g_idle_add_full") + (function &optional (priority +priority-default-idle+)) unsigned-int + (priority int) + ((callback source-callback-marshal) pointer) + ((register-callback-function function) unsigned-long) + ((callback %destroy-user-data) pointer)) + +(defun idle-remove (idle) + (source-remove idle)) ;;;; Signals -(defun signal-name-to-string (name) - (substitute #\_ #\- (string-downcase (string name)))) - -(define-foreign signal-lookup (name itype) unsigned-int +(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 +127,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 +155,66 @@ (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))) +(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 for the signal." + (when function + (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 (c-call:void (domain c-call:c-string) + (log-level c-call:int) + (message c-call:c-string)) + (error "~A: ~A" domain message)) + +(setf (extern-alien "log_handler" system-area-pointer) (callback log-handler)) + + +;;;; Convenient macros + +(defmacro def-callback-marshal (name (return-type &rest args)) + (let ((names (loop + for arg in args + collect (if (atom arg) (gensym) (first arg)))) + (types (loop + for arg in args + collect (if (atom arg) arg (second arg))))) + `(defcallback ,name (,return-type ,@(mapcar #'list names types) + (callback-id unsigned-int)) + (invoke-callback callback-id ',return-type ,@names)))) + +(defmacro with-callback-function ((id function) &body body) + `(let ((,id (register-callback-function ,function))) + (unwind-protect + (progn ,@body) + (destroy-user-data ,id)))) -;;;; Idles and timeouts - -; (defun timeout-remove (tag) -; (source-remove tag)) - -; (defun idle-remove (tag) -; (source-remove tag))