From c8c48a4c0afa3a32f381c3f5662e34ae1874ea2c Mon Sep 17 00:00:00 2001 From: espen Date: Thu, 9 Nov 2000 20:29:19 +0000 Subject: [PATCH] Moved callback mechanism and signal system from gtk to glib --- glib/callback.c | 85 ++++++++++++++++++++++++++++ glib/gcallback.lisp | 153 ++++++++++++++++++++++++++++++++++++++++++++++++++ glib/glib-export.lisp | 6 +- glib/gobject.lisp | 69 +++++++---------------- glib/gtype.lisp | 20 +++---- gtk/gtkglue.c | 62 +------------------- gtk/gtkobject.lisp | 109 +---------------------------------- 7 files changed, 277 insertions(+), 227 deletions(-) create mode 100644 glib/callback.c create mode 100644 glib/gcallback.lisp diff --git a/glib/callback.c b/glib/callback.c new file mode 100644 index 0000000..846c5d1 --- /dev/null +++ b/glib/callback.c @@ -0,0 +1,85 @@ +/* Common Lisp bindings for GTK+ v2.0 + * Copyright (C) 1999-2000 Espen S. Johnsen + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * 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: callback.c,v 1.1 2000-11-09 20:29:19 espen Exp $ */ + +#include + +#ifdef CMUCL +#include "lisp.h" +#include "alloc.h" +#include "arch.h" + +lispobj callback_trampoline; +lispobj destroy_user_data; +#endif + +void destroy_notify (gpointer data); + + +void lisp_callback_marshal (GClosure *closure, + GValue *return_value, + guint n_params, + const GValue *param_values, + gpointer invocation_hint, + gpointer marshal_data) +{ +#ifdef CMUCL + funcall3 (callback_trampoline, alloc_number ((unsigned int)closure->data), + alloc_cons (alloc_number (n_params), alloc_sap (param_values)), + alloc_sap (return_value)); +#elif defined(CLISP) + callback_trampoline ((unsigned long)closure->data, + n_params, (unsigned int)param_values, + (unsigned int)return_value); +#endif +} + +void closure_destroy_notify (gpointer callback_id, GClosure *closure) +{ + destroy_notify (callback_id); +} + +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 +} + +GClosure* +g_lisp_callback_closure (guint callback_id) +{ + GClosure *closure; + + closure = g_closure_new_simple (sizeof (GClosure), (gpointer)callback_id); + g_closure_set_marshal (closure, lisp_callback_marshal); + g_closure_add_fnotify (closure, (gpointer)callback_id, closure_destroy_notify); + + return closure; +} + +#ifndef CMUCL +void* +destroy_notify_address () +{ + return (void*)destroy_notify; +} +#endif diff --git a/glib/gcallback.lisp b/glib/gcallback.lisp new file mode 100644 index 0000000..639a9a1 --- /dev/null +++ b/glib/gcallback.lisp @@ -0,0 +1,153 @@ +;; Common Lisp bindings for GTK+ v2.0 +;; Copyright (C) 2000 Espen S. Johnsen +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 2 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; 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.1 2000-11-09 20:29:19 espen Exp $ + +(in-package "GLIB") + +(use-prefix "g") + + +;;;; Closures + +(deftype gclosure () 'pointer) + +(define-foreign lisp-callback-closure () gclosure + (callback-id unsigned-int)) + + + + +;;;; Callback mechanism + +(defun register-callback-function (function) + (check-type function (or null symbol function)) + (lisp-callback-closure (register-user-data function))) + +(defun callback-trampoline (callback-id params 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-value (sap+ param-values (* n +gvalue-size+))) args))) + + (labels ((invoke-callback () + (restart-case + (unwind-protect + (let ((result (apply callback-function args))) + (when return-type + (setf (gvalue-value 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*) + (setf + (gvalue-value 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) + + + +;;;; Signals + +(defun signal-name-to-string (name) + (substitute #\_ #\- (string-downcase (string name)))) + +(define-foreign signal-lookup (name itype) unsigned-int + ((signal-name-to-string name) string) + (itype type-number)) + +(define-foreign signal-name () string + (signal-id unsigned-int)) + +(defun %ensure-signal-id (signal-id instance) + (etypecase signal-id + (integer signal-id) + (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 + (instance ginstance) + ((%ensure-signal-id signal-id instance) unsigned-int)) + +; (define-foreign ("g_signal_add_emission_hook_full" signal-add-emisson-hook) +; () unsigned-int +; (signal-id unsigned-int) +; (closure gclosure)) + +; (define-foreign 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) + (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) + (instance signal-id closure &key detail after) unsigned-int + (instance ginstance) + ((%ensure-signal-id signal-id instance) unsigned-int) + ((or detail 0) quark) + (closure gclosure) + (after boolean)) + +(define-foreign signal-handler-block () nil + (instance ginstance) + (handler unsigned-int)) + +(define-foreign signal-handler-unblock () nil + (instance ginstance) + (handler unsigned-int)) + +(define-foreign 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))) diff --git a/glib/glib-export.lisp b/glib/glib-export.lisp index d197ca5..3222f0f 100644 --- a/glib/glib-export.lisp +++ b/glib/glib-export.lisp @@ -1,5 +1,5 @@ ;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 2000 Espen S. Johnsen +;; Copyright (C) 2000 Espen S. Johnsen ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -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-export.lisp,v 1.2 2000-08-17 22:43:02 espen Exp $ +;; $Id: glib-export.lisp,v 1.3 2000-11-09 20:29:19 espen Exp $ ;;; Autogenerating exported symbols @@ -42,4 +42,6 @@ (export-from-file #p"clg:glib;gutils.lisp") (export-from-file #p"clg:glib;glib.lisp") (export-from-file #p"clg:glib;gtype.lisp") +(export-from-file #p"clg:glib;gparam.lisp") +(export-from-file #p"clg:glib;gcallback.lisp") (export-from-file #p"clg:glib;gobject.lisp") diff --git a/glib/gobject.lisp b/glib/gobject.lisp index 09b7cf7..ee61f96 100644 --- a/glib/gobject.lisp +++ b/glib/gobject.lisp @@ -1,5 +1,5 @@ ;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 2000 Espen S. Johnsen +;; Copyright (C) 2000 Espen S. Johnsen ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -15,18 +15,18 @@ ;; 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: gobject.lisp,v 1.2 2000-08-23 21:40:38 espen Exp $ +;; $Id: gobject.lisp,v 1.3 2000-11-09 20:29:19 espen Exp $ (in-package "GLIB") (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass gobject (gtype) + (defclass gobject (ginstance) () - (:metaclass gtype-class) + (:metaclass ginstance-class) (:alien-name "GObject")) - (defclass gobject-class (gtype-class))) + (defclass gobject-class (ginstance-class))) ;;;; Reference counting for gobject @@ -56,54 +56,24 @@ (object (or gobject pointer))) -;; Parameter stuff not yet implemented +;;;; Parameter stuff -; (define-foreign object-set-param () nil -; (object gobject) -; (name string) -; (value gvalue)) - -; (define-foreign object-get-param () nil -; (object gobject) -; (name string) -; (value gvalue :out)) - -; (define-foreign object-queue-param-changed () nil -; (object gobject) -; (name string)) - - -;;;; User data mechanism - -(declaim (fixnum *user-data-count*)) +(define-foreign %object-set-param () nil + (object gobject) + (name string) + (value gvalue)) -(defvar *user-data* (make-hash-table)) -(defvar *user-data-count* 0) +(define-foreign %object-get-param () nil + (object gobject) + (name string) + (value gvalue :out)) -;; Until the callback mechanism is moved to glib, the value of -;; *destroy-marshal* is set in gtkobject.lisp -(defvar *destroy-marshal* nil) +(define-foreign object-queue-param-changed () nil + (object gobject) + (name string)) -(defun register-user-data (object &optional destroy-function) - (check-type destroy-function (or null symbol function)) -; (incf *user-data-count*) - (setq *user-data-count* (the fixnum (1+ *user-data-count*))) - (setf - (gethash *user-data-count* *user-data*) - (cons object destroy-function)) - *user-data-count*) -(defun find-user-data (id) - (check-type id fixnum) - (multiple-value-bind (user-data p) (gethash id *user-data*) - (values (car user-data) p))) -(defun destroy-user-data (id) - (check-type id fixnum) - (let ((user-data (gethash id *user-data*))) - (when (cdr user-data) - (funcall (cdr user-data) (car user-data)))) - (remhash id *user-data*)) (define-foreign %object-set-qdata-full () nil (object gobject) @@ -114,7 +84,7 @@ (defun (setf object-data) (data object key &key (test #'eq)) (%object-set-qdata-full object (quark-from-object key :test test) - (register-user-data data) *destroy-marshal*) + (register-user-data data) *destroy-notify*) data) (define-foreign %object-get-qdata () unsigned-long @@ -127,6 +97,9 @@ + + + ;;;; Methods for gobject-class (defmethod shared-initialize ((class gobject-class) names &rest initargs diff --git a/glib/gtype.lisp b/glib/gtype.lisp index cc09744..87cae25 100644 --- a/glib/gtype.lisp +++ b/glib/gtype.lisp @@ -1,5 +1,5 @@ ;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 2000 Espen S. Johnsen +;; Copyright (C) 2000 Espen S. Johnsen ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -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: gtype.lisp,v 1.5 2000-10-01 17:20:43 espen Exp $ +;; $Id: gtype.lisp,v 1.6 2000-11-09 20:29:19 espen Exp $ (in-package "GLIB") @@ -582,7 +582,7 @@ ;;;; Superclass wrapping types in the glib type system (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass gtype (alien-object) + (defclass ginstance (alien-object) () (:metaclass alien-class) (:size 4 #|(size-of 'pointer)|#))) @@ -593,7 +593,7 @@ (sap-ref-unsigned class 0))) -(deftype-method translate-from-alien gtype (type-spec location &optional alloc) +(deftype-method translate-from-alien ginstance (type-spec location &optional alloc) (declare (ignore type-spec alloc)) `(let ((location ,location)) (unless (null-pointer-p location) @@ -603,13 +603,13 @@ -;;;; Metaclass for subclasses of gtype-class +;;;; Metaclass for subclasses of ginstance-class (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass gtype-class (alien-class))) + (defclass ginstance-class (alien-class))) -(defmethod shared-initialize ((class gtype-class) names +(defmethod shared-initialize ((class ginstance-class) names &rest initargs &key name) (declare (ignore initargs names)) (call-next-method) @@ -619,11 +619,11 @@ (defmethod validate-superclass - ((class gtype-class) (super pcl::standard-class)) - (subtypep (class-name super) 'gtype)) + ((class ginstance-class) (super pcl::standard-class)) + (subtypep (class-name super) 'ginstance)) -(defmethod allocate-alien-storage ((class gtype-class)) +(defmethod allocate-alien-storage ((class ginstance-class)) (type-create-instance (find-type-number class))) diff --git a/gtk/gtkglue.c b/gtk/gtkglue.c index b232ae2..9ca23c9 100644 --- a/gtk/gtkglue.c +++ b/gtk/gtkglue.c @@ -1,5 +1,5 @@ /* Common Lisp bindings for GTK+ v2.0 - * Copyright (C) 1999-2000 Espen S. Johnsen + * Copyright (C) 1999-2000 Espen S. Johnsen * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -16,69 +16,11 @@ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA */ -/* $Id: gtkglue.c,v 1.3 2000-10-05 17:32:34 espen Exp $ */ +/* $Id: gtkglue.c,v 1.4 2000-11-09 20:30:16 espen Exp $ */ #include -#ifdef CMUCL -#include "lisp.h" - -extern lispobj funcall1(lispobj function, lispobj arg0); -extern lispobj funcall3(lispobj function, lispobj arg0, - lispobj arg1, lispobj arg2); - -lispobj callback_trampoline; -lispobj destroy_user_data; -#endif - - -void callback_marshal (GtkObject *object, - gpointer data, - guint n_args, - GtkArg *args) -{ -#ifdef CMUCL - funcall3 (callback_trampoline, alloc_number ((unsigned long)data), - alloc_number (n_args), alloc_sap (args)); - - /* lispobj lisp_args[4]; - - lisp_args[0] = alloc_sap (object); - lisp_args[1] = alloc_number ((unsigned long)data); - lisp_args[2] = alloc_number (n_args); - lisp_args[3] = alloc_sap (args); - - call_into_lisp (callback_trampoline, lisp_args, 4);*/ -#elif defined(CLISP) - callback_trampoline ((unsigned long)data, n_args, (unsigned int) args); -#endif -} - - -void destroy_marshal (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* -callback_marshal_address () -{ - return (void*)callback_marshal; -} - -void* -destroy_marshal_address () -{ - return (void*)destroy_marshal; -} -#endif - /* * diff --git a/gtk/gtkobject.lisp b/gtk/gtkobject.lisp index 6b536e2..223dade 100644 --- a/gtk/gtkobject.lisp +++ b/gtk/gtkobject.lisp @@ -1,5 +1,5 @@ ;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 1999-2000 Espen S. Johnsen +;; Copyright (C) 1999-2000 Espen S. Johnsen ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -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: gtkobject.lisp,v 1.6 2000-09-04 22:14:54 espen Exp $ +;; $Id: gtkobject.lisp,v 1.7 2000-11-09 20:30:16 espen Exp $ (in-package "GTK") @@ -171,61 +171,6 @@ value) -;;;; Callback mechanism - -(defun register-callback-function (function) - (check-type function (or null symbol function)) - ; We treat callbacks just as ordinary user data - (register-user-data function)) - -(defun callback-trampoline (callback-id nargs arg-array) - (declare (fixnum callback-id nargs)) - (let* ((return-arg (unless (null-pointer-p arg-array) - (arg-array-ref arg-array nargs))) - (return-type (if return-arg - (type-from-number (arg-type return-arg)) - nil)) - (args nil) - (callback-function (find-user-data callback-id))) - - (dotimes (n nargs) - (push (arg-value (arg-array-ref arg-array (- nargs n 1))) args)) - - (labels ((invoke-callback () - (restart-case - (unwind-protect - (let ((return-value (apply callback-function args))) - (when return-type - (setf (return-arg-value return-arg) return-value)))) - - (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*) - (setf - (return-arg-value return-arg) - (eval (read *query-io*))))) - (re-invoke nil :report "Re-invoke callback function" - (invoke-callback))))) - (invoke-callback)))) - -(defvar *callback-marshal* (system:foreign-symbol-address "callback_marshal")) -(setq *destroy-marshal* (system:foreign-symbol-address "destroy_marshal")) - -(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) - - ;;;; Main loop, timeouts and idle functions @@ -284,56 +229,6 @@ -;;;; Signals - -(define-foreign %signal-emit-stop () nil - (object object) - (signal-id unsigned-int)) - -(define-foreign %signal-emit-stop-by-name (object signal) nil - (object object) - ((name-to-string signal) string)) - -(defun signal-emit-stop (object signal) - (if (numberp signal) - (%signal-emit-stop object signal) - (%signal-emit-stop-by-name object signal))) - -(define-foreign %signal-connect-full - (object signal function after) unsigned-int - (object object) - ((name-to-string signal) string) - (0 unsigned-long) - (*callback-marshal* pointer) - ((register-callback-function function) unsigned-long) - (*destroy-marshal* pointer) - (nil boolean) - (after boolean)) - -(defun signal-connect (object signal function - &key after ((:object callback-object))) - (let* ((callback-object (if (eq callback-object t) - object - callback-object)) - (callback-function - (if callback-object - #'(lambda (&rest args) (apply function callback-object args)) - function))) - (%signal-connect-full object signal callback-function after))) - -(define-foreign signal-disconnect () nil - (object object) - (handler unsigned-int)) - -(define-foreign signal-handler-block () nil - (object object) - (handler unsigned-int)) - -(define-foreign signal-handler-unblock () nil - (object object) - (handler unsigned-int)) - - ;;;; Metaclass used for subclasses of object (eval-when (:compile-toplevel :load-toplevel :execute) -- 2.11.0