From 34f9e1d49c0b952ab3042362c54d85520992927f Mon Sep 17 00:00:00 2001 Message-Id: <34f9e1d49c0b952ab3042362c54d85520992927f.1715232243.git.mdw@distorted.org.uk> From: Mark Wooding Date: Mon, 1 Nov 2004 00:08:49 +0000 Subject: [PATCH] Callbacks from C done properly Organization: Straylight/Edgeware From: espen --- TODO | 2 +- glib/alien/callback.c | 81 ++++------------------------------ glib/gcallback.lisp | 100 +++++++++++++++++++----------------------- glib/glib.lisp | 3 +- gtk/alien/glue.c | 29 +----------- gtk/gtkcontainer.lisp | 9 ++-- 6 files changed, 62 insertions(+), 162 deletions(-) diff --git a/TODO b/TODO index 247f58e..2204dab 100644 --- a/TODO +++ b/TODO @@ -4,7 +4,7 @@ * Clean up code in glib module -* Use CMUCL's native mechanism for callbacks from C +* Use CMUCL's native mechanism for callbacks from C -- done * Create all foreign function bindings at compile time (necessary for CLisp port and to improve startup time) diff --git a/glib/alien/callback.c b/glib/alien/callback.c index 65ab690..e9db3ce 100644 --- a/glib/alien/callback.c +++ b/glib/alien/callback.c @@ -16,94 +16,32 @@ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA */ -/* $Id: callback.c,v 1.2 2004-10-31 11:34:47 espen Exp $ */ +/* $Id: callback.c,v 1.3 2004-11-01 00:08:50 espen Exp $ */ #include #ifdef CMUCL #include "lisp.h" -#include "alloc.h" -#include "arch.h" -lispobj callback_trampoline; -lispobj destroy_user_data; -lispobj log_handler; +void (*log_handler) (gchar*, guint, gchar*); #endif -void callback_marshal (guint callback_id, GValue *return_value, - guint n_params, const GValue *param_values) -{ -#ifdef CMUCL - funcall3 (callback_trampoline, alloc_number ((unsigned int)callback_id), - alloc_cons (alloc_number (n_params), alloc_sap (param_values)), - alloc_sap (return_value)); -#elif defined(CLISP) - callback_trampoline ((unsigned long)callback_id, - n_params, (unsigned int)param_values, - (unsigned int)return_value); -#endif -} - -void destroy_notify (gpointer data) -{ -#ifdef CMUCL - funcall1 (destroy_user_data, alloc_number ((unsigned long)data)); -#elif defined(CLISP) - destroy_user_data ((unsigned long)data); -#endif -} - -/* #ifndef CMUCL */ -/* void* */ -/* destroy_notify_address () */ -/* { */ -/* return (void*)destroy_notify; */ -/* } */ -/* #endif */ - - - -void closure_callback_marshal (GClosure *closure, - GValue *return_value, - guint n_params, - const GValue *param_values, - gpointer invocation_hint, - gpointer marshal_data) -{ - callback_marshal ((guint)closure->data, return_value, n_params, param_values); -} - -void closure_destroy_notify (gpointer data, GClosure *closure) -{ - destroy_notify (data); -} GClosure* -g_lisp_callback_closure_new (guint callback_id) +clg_callback_closure_new (gpointer callback_id, gpointer callback, + gpointer destroy_notify) { GClosure *closure; closure = g_closure_new_simple (sizeof (GClosure), (gpointer)callback_id); - g_closure_set_marshal (closure, closure_callback_marshal); - g_closure_add_finalize_notifier (closure, (gpointer)callback_id, closure_destroy_notify); + g_closure_set_meta_marshal (closure, callback_id, callback); + g_closure_add_finalize_notifier (closure, callback_id, destroy_notify); return closure; } -/* Callback function used for idle and timeout */ -gboolean source_callback_marshal (gpointer data) -{ - GValue return_value; - - memset (&return_value, 0, sizeof (GValue)); - g_value_init (&return_value, G_TYPE_BOOLEAN); - callback_marshal ((guint)data, &return_value, 0, NULL); - - return g_value_get_boolean (&return_value); -} - void g_logv (const gchar *log_domain, GLogLevelFlags log_level, @@ -111,9 +49,8 @@ g_logv (const gchar *log_domain, va_list args1) { gchar *msg = g_strdup_vprintf (format, args1); - lispobj lisp_msg = alloc_string (msg); + log_handler (log_domain, log_level, msg); + + /* Normally log_handler won't return, so we will be leaking this memory */ g_free (msg); - - funcall3 (log_handler, alloc_string (log_domain), - alloc_number ((unsigned int)log_level), lisp_msg); } diff --git a/glib/gcallback.lisp b/glib/gcallback.lisp index 28acd48..ee11387 100644 --- a/glib/gcallback.lisp +++ b/glib/gcallback.lisp @@ -15,66 +15,68 @@ ;; 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.11 2004-11-01 00:08:49 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)) -(defun make-callback-closure (function) - (lisp-callback-closure-new (register-callback-function 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)) +(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))) -;;;; 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 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)))) ;;;; Timeouts and idle functions -(defvar *source-callback-marshal* - (system:foreign-symbol-address "source_callback_marshal")) -(defvar *destroy-notify* - (system:foreign-symbol-address "destroy_notify")) +(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 @@ -82,14 +84,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 +171,9 @@ (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 (void (domain c-string) (log-level int) + (message c-string)) (error "~A: ~A" domain message)) - -;;; - -(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) +(setf (extern-alien "log_handler" system-area-pointer) (callback log-handler)) diff --git a/glib/glib.lisp b/glib/glib.lisp index 1827205..f949d17 100644 --- a/glib/glib.lisp +++ b/glib/glib.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: glib.lisp,v 1.14 2004-10-31 11:37:11 espen Exp $ +;; $Id: glib.lisp,v 1.15 2004-11-01 00:08:49 espen Exp $ (in-package "GLIB") @@ -48,7 +48,6 @@ (internal *user-data* *user-data-count*) (declaim (fixnum *user-data-count*)) -(defvar *destroy-notify* (system:foreign-symbol-address "destroy_notify")) (defvar *user-data* (make-hash-table)) (defvar *user-data-count* 0) diff --git a/gtk/alien/glue.c b/gtk/alien/glue.c index 6cd334c..bcdbb34 100644 --- a/gtk/alien/glue.c +++ b/gtk/alien/glue.c @@ -16,7 +16,7 @@ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA */ -/* $Id: glue.c,v 1.1 2004-10-31 12:14:47 espen Exp $ */ +/* $Id: glue.c,v 1.2 2004-11-01 00:08:50 espen Exp $ */ #include @@ -37,33 +37,6 @@ gtk_query_version (guint *major, guint *minor, guint *micro) } -void gtk_callback_marshal (GtkWidget *widget, gpointer data) -{ - GValue arg; - - memset (&arg, 0, sizeof (GValue)); - g_value_init (&arg, gtk_widget_get_type ()); - g_value_set_object (&arg, widget); - callback_marshal ((guint)data, NULL, 1, &arg); -} - -void gtk_menu_position_callback_marshal (GtkMenu *menu, gint x, gint y, - gboolean push_in, gpointer data) -{ - GValue args[3]; - - memset (args, 0, 3 * sizeof (GValue)); - g_value_init (&args[0], G_TYPE_INT); - g_value_set_int (&args[0], x); - g_value_init (&args[1], G_TYPE_INT); - g_value_set_int (&args[1], y); - g_value_init (&args[2], G_TYPE_BOOLEAN); - g_value_set_boolean (&args[2], push_in); - - callback_marshal ((guint)data, NULL, 3, args); -} - - /* Widget */ GdkWindow* diff --git a/gtk/gtkcontainer.lisp b/gtk/gtkcontainer.lisp index a31a49d..530b1b4 100644 --- a/gtk/gtkcontainer.lisp +++ b/gtk/gtkcontainer.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: gtkcontainer.lisp,v 1.9 2004-10-31 12:05:52 espen Exp $ +;; $Id: gtkcontainer.lisp,v 1.10 2004-11-01 00:08:50 espen Exp $ (in-package "GTK") @@ -67,12 +67,13 @@ (defbinding %container-child-set-property () nil (defbinding container-check-resize () nil (container container)) -(defvar *callback-marshal* - (system:foreign-symbol-address "gtk_callback_marshal")) +(def-callback %foreach-callback (c-call:void (widget system-area-pointer) + (callback-id c-call:unsigned-int)) + (invoke-callback callback-id nil (ensure-proxy-instance 'widget widget nil))) (defbinding %container-foreach (container callback-id) nil (container container) - (*callback-marshal* pointer) + ((callback %foreach-callback) pointer) (callback-id unsigned-int)) (defun container-foreach (container function) -- [mdw]