X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/c0f178d05351bd9c0521a79ed959322ae76a26f6..fd1e4a399fc26f5a40c2e7fe705aa7d9aa56e7b1:/glib/gcallback.lisp diff --git a/glib/gcallback.lisp b/glib/gcallback.lisp index 28acd48..5255221 100644 --- a/glib/gcallback.lisp +++ b/glib/gcallback.lisp @@ -15,66 +15,71 @@ ;; 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.10 2004-10-30 19:26:02 espen Exp $ +;; $Id: gcallback.lisp,v 1.14 2004-11-07 16:04:21 espen Exp $ (in-package "GLIB") (use-prefix "g") -;;;; Closures +;;;; Callback mechanism (deftype gclosure () 'pointer) -(defbinding 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)) +(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) - (lisp-callback-closure-new (register-callback-function function))) - + (callback-closure-new + (register-callback-function function) + (callback closure-callback-marshal) (callback %destroy-user-data))) -;;;; Callback mechanism -(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) (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 (reverse 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)))) + (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 -(defvar *source-callback-marshal* - (system:foreign-symbol-address "source_callback_marshal")) -(defvar *destroy-notify* - (system:foreign-symbol-address "destroy_notify")) +(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") (function interval &optional (priority 0)) unsigned-int @@ -82,14 +87,14 @@ (defbinding (timeout-add "g_timeout_add_full") (interval unsigned-int) (*source-callback-marshal* pointer) ((register-callback-function function) unsigned-long) - (*destroy-notify* pointer)) + ((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) - (*destroy-notify* pointer)) + ((callback %destroy-user-data) pointer)) @@ -169,21 +174,32 @@ (defmethod signal-connect ((gobject gobject) signal function &key after object) ;;; Message logging ;; TODO: define and signal conditions based on log-level -(defun log-handler (domain log-level message) - (declare (ignore 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)))) -(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)) - (extern-alien "log_handler" system-area-pointer) - (make-pointer (kernel:get-lisp-obj-address #'log-handler)))) -(pushnew 'after-gc-hook ext:*after-gc-hooks*) -(after-gc-hook)