Moved object user data from gtk to glib

diff --git a/glib/gobject.lisp b/glib/gobject.lisp
index 015f29b09753b00ce5808080459402c07f56f078..09b7cf7850a846940e64f92032c751bcd9682bf8 100644 (file)
--- a/glib/gobject.lisp
+++ b/glib/gobject.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: gobject.lisp,v 1.1 2000-08-14 16:44:30 espen Exp $
+;; $Id: gobject.lisp,v 1.2 2000-08-23 21:40:38 espen Exp $
 
 (in-package "GLIB")
 
@@ -29,7 +29,7 @@   (defclass gobject (gtype)
   (defclass gobject-class (gtype-class)))
 
 
-;;;; Methods for gobject
+;;;; Reference counting for gobject
 
 ;; Specializing reference-instance and unreference-instance on gobject
 ;; is not really necessary but done for efficiency
@@ -73,6 +73,59 @@ (define-foreign %object-unref () nil
 ;   (name string))
 
 
+;;;; User data mechanism
+
+(declaim (fixnum *user-data-count*))
+
+(defvar *user-data* (make-hash-table))
+(defvar *user-data-count* 0)
+
+;; Until the callback mechanism is moved to glib, the value of
+;; *destroy-marshal* is set in gtkobject.lisp
+(defvar *destroy-marshal* nil)
+
+(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)
+  (id quark)
+  (data unsigned-long)
+  (destroy-marshal pointer))
+
+(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*)
+  data)
+
+(define-foreign %object-get-qdata () unsigned-long
+  (object gobject)              
+  (id quark))
+
+(defun object-data (object key &key (test #'eq))
+  (find-user-data
+   (%object-get-qdata object (quark-from-object key :test test))))
+
+
 
 ;;;; Methods for gobject-class
 

diff --git a/gtk/gtkobject.lisp b/gtk/gtkobject.lisp
index f56f5a60f5b07f56076d12ef639ffb3de6c6b0a1..541efdec87fc0de650d9043e8a7c73a7fe7274f7 100644 (file)
--- a/gtk/gtkobject.lisp
+++ b/gtk/gtkobject.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: gtkobject.lisp,v 1.4 2000-08-16 22:16:23 espen Exp $
+;; $Id: gtkobject.lisp,v 1.5 2000-08-23 21:41:10 espen Exp $
 
 
 (in-package "GTK")
@@ -165,35 +165,13 @@ (defun (setf object-arg) (value object name)
   value)
 
 
-;;;; Callback and user data mechanism
-
-(declaim (fixnum *user-data-count*))
-
-(defvar *user-data* (make-hash-table))
-(defvar *user-data-count* 0)
-
-(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)))
-
+;;;; 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)
@@ -228,17 +206,8 @@ (defun callback-trampoline (callback-id nargs arg-array)
                  (invoke-callback)))))
       (invoke-callback))))
 
-
-(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*))
-
-
 (defvar *callback-marshal* (system:foreign-symbol-address "callback_marshal"))
-(defvar *destroy-marshal* (system:foreign-symbol-address "destroy_marshal"))
+(setq *destroy-marshal* (system:foreign-symbol-address "destroy_marshal"))
 
 (defun after-gc-hook ()
   (setf