Correct reference counting of gobjects

[clg] / glib / proxy.lisp

diff --git a/glib/proxy.lisp b/glib/proxy.lisp
index fa1e518775409484238c1d6cabf68a629d18c7e8..e9a0f13d44caa1b2eacb330cd87fdde016e87960 100644 (file)
--- a/glib/proxy.lisp
+++ b/glib/proxy.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: proxy.lisp,v 1.8 2004-10-27 14:59:00 espen Exp $
+;; $Id: proxy.lisp,v 1.10 2004-11-03 16:18:16 espen Exp $
 
 (in-package "GLIB")
 
@@ -75,7 +75,12 @@ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-def
                   (declare (ignore object))
                   (error "Can't read slot: ~A" (slot-definition-name slotd))))
         (symbol #'(lambda (object)
-                    (funcall getter object))))))
+                    (funcall getter object)))
+        (string (let ((reader (mkbinding-late getter 
+                               (slot-definition-type slotd) 'pointer)))
+                  (setf (slot-value slotd 'reader-function)
+                        #'(lambda (object)
+                            (funcall reader (proxy-location object)))))))))
 
     (unless (slot-boundp slotd 'writer-function)
       (setf 
@@ -86,7 +91,13 @@ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-def
                   (declare (ignore object))
                   (error "Can't set slot: ~A" (slot-definition-name slotd))))
         ((or symbol cons) #'(lambda (value object)
-                              (funcall (fdefinition setter) value object))))))
+                              (funcall (fdefinition setter) value object)))
+        (string
+         (let ((writer (mkbinding-late setter 'nil 'pointer 
+                        (slot-definition-type slotd))))
+           (setf (slot-value slotd 'writer-function)
+                 #'(lambda (value object)
+                     (funcall writer (proxy-location object) value))))))))
 
     (unless (slot-boundp slotd 'boundp-function)
       (setf 
@@ -154,6 +165,9 @@ (defun find-cached-instance (location)
     (when ref
       (ext:weak-pointer-value ref))))
 
+(defun instance-cached-p (location)
+  (gethash (system:sap-int location) *instance-cache*))
+
 (defun remove-cached-instance (location)
   (remhash (system:sap-int location) *instance-cache*))
 
@@ -168,6 +182,10 @@   (defclass proxy ()
   (defgeneric initialize-proxy (object &rest initargs))
   (defgeneric instance-finalizer (object)))
 
+(defmethod print-object ((instance proxy) stream)
+  (print-unreadable-object (instance stream :type t :identity nil)
+    (format stream "at 0x~X" (sap-int (proxy-location instance)))))
+
 
 (defmethod initialize-instance :after ((instance proxy)
                                       &rest initargs &key)
@@ -195,8 +213,9 @@ (defmethod instance-finalizer ((instance proxy))
     (declare (type symbol type) (type system-area-pointer location))
     (let ((free (proxy-class-free class)))
       #'(lambda ()
-         (funcall free type location)
-         (remove-cached-instance location)))))
+         (when (instance-cached-p location)
+            (remove-cached-instance location)
+            (funcall free type location))))))
 
 
 (deftype-method translate-type-spec proxy (type-spec)
@@ -228,8 +247,6 @@ (deftype-method unreference-alien proxy (type-spec location)
        `(,free ',type-spec ,location)
     `(funcall ',free ',type-spec ,location))))
 
-;; (defun proxy-instance-size (proxy)
-;;   (proxy-class-size (class-of proxy)))
 
 ;;;; Metaclass used for subclasses of proxy
 
@@ -245,9 +262,6 @@   (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
   
   (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
     ((offset :reader slot-definition-offset :initarg :offset)))
-  
-  (defclass effective-virtual-alien-slot-definition (effective-virtual-slot-definition)
-    ())
 
 
   (defmethod most-specific-proxy-superclass ((class proxy-class))
@@ -276,8 +290,6 @@   (defmethod shared-initialize ((class proxy-class) names
       (free (setf (slot-value class 'free) (first free)))
       ((slot-boundp class 'free) (slot-makunbound class 'free))))
   
-;;   (defmethod finalize-inheritance ((class proxy-class))
-;;     (call-next-method)
   (defmethod shared-initialize :after ((class proxy-class) names &rest initargs)
     (let ((super (most-specific-proxy-superclass class)))
       (unless (or (not super) (eq super (find-class 'proxy)))
@@ -294,7 +306,6 @@   (defmethod direct-slot-definition-class ((class proxy-class) &rest initargs)
   (defmethod effective-slot-definition-class ((class proxy-class) &rest initargs)
     (case (getf initargs :allocation)
       (:alien (find-class 'effective-alien-slot-definition))
-      (:virtual (find-class 'effective-virtual-alien-slot-definition))
       (t (call-next-method))))
   
   
@@ -335,21 +346,6 @@   (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-def
     (call-next-method))
   
 
-  (defmethod initialize-internal-slot-functions ((slotd effective-virtual-alien-slot-definition))
-    (with-slots (getter setter type) slotd
-      (when (and (not (slot-boundp slotd 'reader-function)) (stringp getter))
-       (let ((reader (mkbinding-late getter type 'pointer)))
-         (setf (slot-value slotd 'reader-function)
-               #'(lambda (object)
-                   (funcall reader (proxy-location object))))))
-      
-      (when (and (not (slot-boundp slotd 'writer-function)) (stringp setter))
-       (let ((writer (mkbinding-late setter 'nil 'pointer type)))
-         (setf (slot-value slotd 'writer-function)
-               #'(lambda (value object)
-                   (funcall writer (proxy-location object) value))))))
-    (call-next-method))
-
   ;; TODO: call some C code to detect this a compile time
   (defconstant +struct-alignmen+ 4)