--- /dev/null
+/* Common Lisp bindings for GTK+ v2.0
+ * Copyright (C) 1999-2000 Espen S. Johnsen <espejohn@online.no>
+ *
+ * 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 <gobject/gobject.h>
+
+#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
--- /dev/null
+;; Common Lisp bindings for GTK+ v2.0
+;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
+;;
+;; 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)))
;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 2000 Espen S. Johnsen <espejohn@online.no>
+;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms 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: 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
(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")
;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 2000 Espen S. Johnsen <espejohn@online.no>
+;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms 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: 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
(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)
(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
+
+
+
;;;; Methods for gobject-class
(defmethod shared-initialize ((class gobject-class) names &rest initargs
;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 2000 Espen S. Johnsen <espejohn@online.no>
+;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms 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: 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")
;;;; 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)|#)))
(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)
-;;;; 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)
(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)))
/* Common Lisp bindings for GTK+ v2.0
- * Copyright (C) 1999-2000 Espen S. Johnsen <espejohn@online.no>
+ * Copyright (C) 1999-2000 Espen S. Johnsen <esj@stud.cs.uit.no>
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* 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 <gtk/gtk.h>
-#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
-
/*
*
;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 1999-2000 Espen S. Johnsen <espejohn@online.no>
+;; Copyright (C) 1999-2000 Espen S. Johnsen <esj@ostud.cs.uit.no>
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms 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: 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")
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
-;;;; 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)
~mdw / clg / commitdiff