Bug fix

[clg] / glib / proxy.lisp

diff --git a/glib/proxy.lisp b/glib/proxy.lisp
index 5f0e5cf..36fbb58 100644 (file)
--- a/glib/proxy.lisp
+++ b/glib/proxy.lisp
@@ -20,7 +20,7 @@
 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 

-;; $Id: proxy.lisp,v 1.25 2006-02-05 15:38:57 espen Exp $
+;; $Id: proxy.lisp,v 1.37 2006-02-26 16:12:25 espen Exp $

 
 (in-package "GLIB")
 
 
 (in-package "GLIB")
 


@@ -43,10 +43,10 @@
      (boundp :reader slot-definition-boundp :initarg :boundp)))
 
   (defclass direct-special-slot-definition (standard-direct-slot-definition)
      (boundp :reader slot-definition-boundp :initarg :boundp)))
 
   (defclass direct-special-slot-definition (standard-direct-slot-definition)

-    ())
+    ((special :initarg :special :accessor slot-definition-special)))

   
   (defclass effective-special-slot-definition (standard-effective-slot-definition)
   
   (defclass effective-special-slot-definition (standard-effective-slot-definition)

-    ()))
+    ((special :initarg :special :accessor slot-definition-special))))

 
 (defvar *unbound-marker* (gensym "UNBOUND-MARKER-"))
 
 
 (defvar *unbound-marker* (gensym "UNBOUND-MARKER-"))
 


@@ -59,23 +59,22 @@
        (slot-value object slot)
       default)))
 
        (slot-value object slot)
       default)))
 

-(defmethod initialize-instance ((slotd effective-special-slot-definition) &rest initargs)
-  (declare (ignore initargs))
-  (call-next-method)
-  (setf (slot-value slotd 'allocation) :instance))
-

 
 (defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs)
 
 (defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs)

-  (case (getf initargs :allocation)
-    (:virtual (find-class 'direct-virtual-slot-definition))
-    (:special (find-class 'direct-special-slot-definition))
-    (t (call-next-method))))
+  (cond
+   ((eq (getf initargs :allocation) :virtual)
+    (find-class 'direct-virtual-slot-definition))
+   ((getf initargs :special)
+    (find-class 'direct-special-slot-definition))
+   (t (call-next-method))))

 
 (defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs)
 
 (defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs)

-  (case (getf initargs :allocation)
-    (:virtual (find-class 'effective-virtual-slot-definition))
-    (:special (find-class 'effective-special-slot-definition))
-    (t (call-next-method))))
+  (cond
+   ((eq (getf initargs :allocation) :virtual)
+    (find-class 'effective-virtual-slot-definition))
+   ((getf initargs :special)
+    (find-class 'effective-special-slot-definition))
+   (t (call-next-method))))

 
 
 (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
 
 
 (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))


@@ -84,7 +83,7 @@
        (slot-value slotd 'reader-function)
        #'(lambda (object)
           (declare (ignore object))
        (slot-value slotd 'reader-function)
        #'(lambda (object)
           (declare (ignore object))

-          (error "Can't read slot: ~A" (slot-definition-name slotd)))
+          (error "Slot is not readable: ~A" (slot-definition-name slotd)))

        (slot-value slotd 'boundp-function)
        #'(lambda (object) (declare (ignore object)) nil))
 
        (slot-value slotd 'boundp-function)
        #'(lambda (object) (declare (ignore object)) nil))
 


@@ -125,11 +124,14 @@
                              (mkbinding boundp
                               (slot-definition-type slotd) 'pointer)))
                           (funcall reader (foreign-location object))))))))
                              (mkbinding boundp
                               (slot-definition-type slotd) 'pointer)))
                           (funcall reader (foreign-location object))))))))

-       ((multiple-value-bind (unbound-p unbound-value)
-            (unbound-value (slot-definition-type slotd))
-          (when unbound-p
-            #'(lambda (object)
-                (not (eq (funcall getter-function object) unbound-value))))))
+       ((let ((unbound-value-method
+               (find-applicable-type-method 'unbound-value 
+                (slot-definition-type slotd) nil)))
+          (when unbound-value-method
+            (let ((unbound-value 
+                   (funcall unbound-value-method (slot-definition-type slotd))))
+              #'(lambda (object)
+                  (not (eq (funcall getter-function object) unbound-value)))))))

        (#'(lambda (object) (declare (ignore object)) t))))
 
       (setf
        (#'(lambda (object) (declare (ignore object)) t))))
 
       (setf


@@ -149,10 +151,13 @@
               (and
                (funcall boundp-function object)
                (funcall getter-function object)))))
               (and
                (funcall boundp-function object)
                (funcall getter-function object)))))

-       ((multiple-value-bind (unbound-p unbound-value)
-            (unbound-value (slot-definition-type slotd))
-          (let ((slot-name (slot-definition-name slotd)))
-            (when unbound-p
+       ((let ((unbound-value-method
+               (find-applicable-type-method 'unbound-value 
+                (slot-definition-type slotd) nil)))
+          (when unbound-value-method
+            (let ((unbound-value 
+                   (funcall unbound-value-method (slot-definition-type slotd)))
+                  (slot-name (slot-definition-name slotd)))

               #'(lambda (object)
                   (let ((value (funcall getter-function object)))
                     (if (eq value unbound-value)
               #'(lambda (object)
                   (let ((value (funcall getter-function object)))
                     (if (eq value unbound-value)


@@ -163,9 +168,9 @@
   (setf 
    (slot-value slotd 'writer-function)
    (if (not (slot-boundp slotd 'setter))
   (setf 
    (slot-value slotd 'writer-function)
    (if (not (slot-boundp slotd 'setter))

-       #'(lambda (object)
-          (declare (ignore object))
-          (error "Can't set slot: ~A" (slot-definition-name slotd)))
+       #'(lambda (value object)
+          (declare (ignore value object))
+          (error "Slot is not writable: ~A" (slot-definition-name slotd)))

      (with-slots (setter) slotd
        (etypecase setter
         (function setter)
      (with-slots (setter) slotd
        (etypecase setter
         (function setter)


@@ -183,7 +188,7 @@
                     (slot-definition-type slotd))))
                 (funcall writer (foreign-location object) value)))))))))
 
                     (slot-definition-type slotd))))
                 (funcall writer (foreign-location object) value)))))))))
 

-  (initialize-internal-slot-gfs (slot-definition-name slotd)))
+  #-sbcl>=0.9.8(initialize-internal-slot-gfs (slot-definition-name slotd)))

 
 
 
 
 
 


@@ -191,22 +196,29 @@
   nil)
 
 (defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds)
   nil)
 
 (defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds)

-  (if (typep (first direct-slotds) 'direct-virtual-slot-definition)
-      (let ((initargs ()))
-       (let ((getter (most-specific-slot-value direct-slotds 'getter)))
-         (unless (eq getter *unbound-marker*)
-           (setf (getf initargs :getter) getter)))
-       (let ((setter (most-specific-slot-value direct-slotds 'setter)))
-         (unless (eq setter *unbound-marker*)
-           (setf (getf initargs :setter) setter)))
-       (let ((unbound (most-specific-slot-value direct-slotds 'unbound)))
-         (unless (eq unbound *unbound-marker*)
-           (setf (getf initargs :unbound) unbound)))
-       (let ((boundp (most-specific-slot-value direct-slotds 'boundp)))
-         (unless (eq boundp *unbound-marker*)
-           (setf (getf initargs :boundp) boundp)))
-       (nconc initargs (call-next-method)))
-    (call-next-method)))
+  (typecase (first direct-slotds)
+    (direct-virtual-slot-definition
+     (let ((initargs ()))
+       (let ((getter (most-specific-slot-value direct-slotds 'getter)))
+        (unless (eq getter *unbound-marker*)
+          (setf (getf initargs :getter) getter)))
+       (let ((setter (most-specific-slot-value direct-slotds 'setter)))
+        (unless (eq setter *unbound-marker*)
+          (setf (getf initargs :setter) setter)))
+       (let ((unbound (most-specific-slot-value direct-slotds 'unbound)))
+        (unless (eq unbound *unbound-marker*)
+          (setf (getf initargs :unbound) unbound)))
+       (let ((boundp (most-specific-slot-value direct-slotds 'boundp)))
+        (unless (eq boundp *unbound-marker*)
+          (setf (getf initargs :boundp) boundp)))
+       ;; Need this to prevent type expansion in SBCL >= 0.9.8
+       (let ((type (most-specific-slot-value direct-slotds 'type)))
+        (unless (eq type *unbound-marker*)
+          (setf (getf initargs :type) type)))
+       (nconc initargs (call-next-method))))
+    (direct-special-slot-definition
+     (append '(:special t) (call-next-method)))
+    (t (call-next-method))))

 
 
 (defmethod slot-value-using-class
 
 
 (defmethod slot-value-using-class


@@ -232,9 +244,17 @@
   t)
 
 
   t)
 
 

+(defmethod slot-definition-special ((slotd standard-direct-slot-definition))
+  (declare (ignore slotd))
+  nil)
+
+(defmethod slot-definition-special ((slotd standard-effective-slot-definition))
+  (declare (ignore slotd))
+  nil)
+
+

 ;;;; Proxy cache
 
 ;;;; Proxy cache
 

-(internal *instance-cache*)

 (defvar *instance-cache* (make-hash-table :test #'eql))
 
 (defun cache-instance (instance &optional (weak-ref t))
 (defvar *instance-cache* (make-hash-table :test #'eql))
 
 (defun cache-instance (instance &optional (weak-ref t))


@@ -266,17 +286,50 @@
             *instance-cache*)
     instances))
                        
             *instance-cache*)
     instances))
                        

+;; Instances that gets invalidated tend to be short lived, but created
+;; in large numbers. So we're keeping them in a hash table to be able
+;; to reuse them (and thus reduce consing)
+(defvar *invalidated-instance-cache* (make-hash-table :test #'eql))
+
+(defun cache-invalidated-instance (instance)
+  (push instance
+   (gethash (class-of instance) *invalidated-instance-cache*)))
+
+(defun find-invalidated-instance (class)
+  (when (gethash class *invalidated-instance-cache*)
+    (pop (gethash class *invalidated-instance-cache*))))
+
+(defun list-invalidated-instances ()
+  (let ((instances ()))
+    (maphash #'(lambda (location ref)
+                (declare (ignore location))
+                (push ref instances))
+            *invalidated-instance-cache*)
+    instances))
+

 
 
 ;;;; Proxy for alien instances
 
 
 
 ;;;; Proxy for alien instances
 

+;; TODO: add a ref-counted-proxy subclass

 (defclass proxy ()
 (defclass proxy ()

-  ((location :allocation :special :reader foreign-location :type pointer))
+  ((location :special t :type pointer))

   (:metaclass virtual-slots-class))
 
 (defgeneric instance-finalizer (object))
 (defgeneric reference-foreign (class location))
 (defgeneric unreference-foreign (class location))
   (:metaclass virtual-slots-class))
 
 (defgeneric instance-finalizer (object))
 (defgeneric reference-foreign (class location))
 (defgeneric unreference-foreign (class location))

+(defgeneric invalidate-instance (object))
+(defgeneric allocate-foreign (object &key &allow-other-keys))
+
+(defun foreign-location (instance)
+  (slot-value instance 'location))
+
+(defun (setf foreign-location) (location instance)
+  (setf (slot-value instance 'location) location))
+
+(defun proxy-valid-p (instance)
+  (slot-boundp instance 'location))

 
 (defmethod reference-foreign ((name symbol) location)
   (reference-foreign (find-class name) location))
 
 (defmethod reference-foreign ((name symbol) location)
   (reference-foreign (find-class name) location))


@@ -292,10 +345,12 @@
   (print-unreadable-object (instance stream :type t :identity nil)
     (if (slot-boundp instance 'location)
        (format stream "at 0x~X" (sap-int (foreign-location instance)))
   (print-unreadable-object (instance stream :type t :identity nil)
     (if (slot-boundp instance 'location)
        (format stream "at 0x~X" (sap-int (foreign-location instance)))

-      (write-string "at \"unbound\"" stream))))
+      (write-string "at <unbound>" stream))))

 
 

-(defmethod initialize-instance :around ((instance proxy) &rest initargs)
-  (declare (ignore initargs))
+(defmethod initialize-instance :around ((instance proxy) &rest initargs &key &allow-other-keys) 
+  (setf  
+   (foreign-location instance)
+   (apply #'allocate-foreign instance initargs))

   (prog1
       (call-next-method)
     (cache-instance instance)
   (prog1
       (call-next-method)
     (cache-instance instance)


@@ -310,12 +365,19 @@
        (remove-cached-instance location)
        (unreference-foreign class location))))
 
        (remove-cached-instance location)
        (unreference-foreign class location))))
 

+;; Any reference to the foreign object the instance may have held
+;; should be released before this method is invoked
+(defmethod invalidate-instance ((instance proxy))
+  (remove-cached-instance (foreign-location instance))
+  (slot-makunbound instance 'location)
+  (cancel-finalization instance)
+  (cache-invalidated-instance instance))
+

 
 ;;;; Metaclass used for subclasses of proxy
 
 (defgeneric most-specific-proxy-superclass (class))
 (defgeneric direct-proxy-superclass (class))
 
 ;;;; Metaclass used for subclasses of proxy
 
 (defgeneric most-specific-proxy-superclass (class))
 (defgeneric direct-proxy-superclass (class))

-(defgeneric compute-foreign-size (class))

   
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   
 
 (eval-when (:compile-toplevel :load-toplevel :execute)


@@ -323,8 +385,8 @@
     ((size :reader foreign-size)))
 
   (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
     ((size :reader foreign-size)))
 
   (defclass direct-alien-slot-definition (direct-virtual-slot-definition)

-    ((allocation :initform :alien)
-     (offset :reader slot-definition-offset :initarg :offset)))
+    ((offset :reader slot-definition-offset :initarg :offset))
+    (:default-initargs :allocation :alien))

   
   (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
     ((offset :reader slot-definition-offset :initarg :offset)))
   
   (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
     ((offset :reader slot-definition-offset :initarg :offset)))


@@ -359,7 +421,7 @@
   
   
   (defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds)
   
   
   (defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds)

-    (if (eq (most-specific-slot-value direct-slotds 'allocation) :alien)
+    (if (eq (slot-definition-allocation (first direct-slotds)) :alien)

        (nconc 
         (list :offset (most-specific-slot-value direct-slotds 'offset))
         (call-next-method))
        (nconc 
         (list :offset (most-specific-slot-value direct-slotds 'offset))
         (call-next-method))


@@ -388,11 +450,12 @@
 
     (call-next-method))
   
 
     (call-next-method))
   

-  (defmethod compute-foreign-size ((class proxy-class))
-    nil)
-
-  ;; TODO: call some C code to detect this a compile time
-  (defconstant +struct-alignmen+ 4)
+  (defconstant +struct-alignmen+
+    #+sbcl (/ (sb-alien-internals:alien-type-alignment
+               (sb-alien-internals:parse-alien-type
+               'system-area-pointer nil))
+             8)
+    #-sbcl 4)

 
   (defun align-offset (size)
     (if (zerop (mod size +struct-alignmen+))
 
   (defun align-offset (size)
     (if (zerop (mod size +struct-alignmen+))


@@ -418,12 +481,6 @@
        do (setf (slot-value slotd 'offset) offset))))
     (call-next-method))
 
        do (setf (slot-value slotd 'offset) offset))))
     (call-next-method))
 

-  (defmethod compute-slots :after ((class proxy-class))
-    (when (and (class-finalized-p class) (not (slot-boundp class 'size)))
-      (let ((size (compute-foreign-size class)))
-       (when size 
-         (setf (slot-value class 'size) size)))))
-  

   (defmethod validate-superclass ((class proxy-class) (super standard-class))
     (subtypep (class-name super) 'proxy))
   
   (defmethod validate-superclass ((class proxy-class) (super standard-class))
     (subtypep (class-name super) 'proxy))
   


@@ -434,74 +491,73 @@
   (foreign-size (class-of object)))
   
 
   (foreign-size (class-of object)))
   
 

-(defmethod alien-type ((class proxy-class) &rest args)
-  (declare (ignore class args))
+(define-type-method alien-type ((class proxy))
+  (declare (ignore class))

   (alien-type 'pointer))
 
   (alien-type 'pointer))
 

-(defmethod size-of ((class proxy-class) &rest args)
-  (declare (ignore class args))
+(define-type-method size-of ((class proxy))
+  (declare (ignore class))

   (size-of 'pointer))
 
   (size-of 'pointer))
 

-(defmethod from-alien-form (location (class proxy-class) &rest args)
-  (declare (ignore args))
-  `(ensure-proxy-instance ',(class-name class) ,location))
+(define-type-method from-alien-form ((type proxy) location)
+  (let ((class (type-expand type)))
+    `(ensure-proxy-instance ',class ,location)))

 
 

-(defmethod from-alien-function ((class proxy-class) &rest args)
-  (declare (ignore args))  
-  #'(lambda (location)
-      (ensure-proxy-instance class location)))
+(define-type-method from-alien-function ((type proxy))
+  (let ((class (type-expand type)))
+    #'(lambda (location)
+       (ensure-proxy-instance class location))))

 
 

-(defmethod to-alien-form (instance (class proxy-class) &rest args)
-  (declare (ignore class args))
+(define-type-method to-alien-form ((type proxy) instance)
+  (declare (ignore type))

   `(foreign-location ,instance))
 
   `(foreign-location ,instance))
 

-(defmethod to-alien-function ((class proxy-class) &rest args)
-  (declare (ignore class args))
+(define-type-method to-alien-function ((type proxy))
+  (declare (ignore type))

   #'foreign-location)
 
   #'foreign-location)
 

-(defmethod copy-from-alien-form (location (class proxy-class) &rest args)
-  (declare (ignore args))
-  (let ((class-name (class-name class)))
-    `(ensure-proxy-instance ',class-name
-      (reference-foreign ',class-name ,location))))
-
-(defmethod copy-from-alien-function ((class proxy-class) &rest args)
-  (declare (ignore args))  
-  #'(lambda (location)
-      (ensure-proxy-instance class (reference-foreign class location))))
-
-(defmethod copy-to-alien-form (instance (class proxy-class) &rest args)
-  (declare (ignore args))
-  `(reference-foreign ',(class-name class) (foreign-location ,instance)))
-
-(defmethod copy-to-alien-function ((class proxy-class) &rest args)
-  (declare (ignore args))
-  #'(lambda (instance)
-      (reference-foreign class (foreign-location instance))))
-
-(defmethod writer-function ((class proxy-class) &rest args)
-  (declare (ignore args))
-  #'(lambda (instance location &optional (offset 0))
-      (assert (null-pointer-p (sap-ref-sap location offset)))
-      (setf 
-       (sap-ref-sap location offset)
-       (reference-foreign class (foreign-location instance)))))
-
-(defmethod reader-function ((class proxy-class) &rest args)
-  (declare (ignore args))
-  #'(lambda (location &optional (offset 0))
-      (let ((instance (sap-ref-sap location offset)))
-       (unless (null-pointer-p instance)
-         (ensure-proxy-instance class (reference-foreign class instance))))))
-
-(defmethod destroy-function ((class proxy-class) &rest args)
-  (declare (ignore args))
-  #'(lambda (location &optional (offset 0))
-      (unreference-foreign class (sap-ref-sap location offset))))
+(define-type-method copy-from-alien-form ((type proxy) location)
+  (let ((class (type-expand type)))
+    `(ensure-proxy-instance ',class (reference-foreign ',class ,location))))
+
+(define-type-method copy-from-alien-function ((type proxy))
+  (let ((class (type-expand type)))
+    #'(lambda (location)
+       (ensure-proxy-instance class (reference-foreign class location)))))
+
+(define-type-method copy-to-alien-form ((type proxy) instance)
+  (let ((class (type-expand type)))
+    `(reference-foreign ',class (foreign-location ,instance))))
+
+(define-type-method copy-to-alien-function ((type proxy))
+  (let ((class (type-expand type)))
+    #'(lambda (instance)
+       (reference-foreign class (foreign-location instance)))))
+
+(define-type-method writer-function ((type proxy))
+  (let ((class (type-expand type)))
+    #'(lambda (instance location &optional (offset 0))
+       (assert (null-pointer-p (sap-ref-sap location offset)))
+       (setf 
+        (sap-ref-sap location offset)
+        (reference-foreign class (foreign-location instance))))))
+
+(define-type-method reader-function ((type proxy))
+  (let ((class (type-expand type)))
+    #'(lambda (location &optional (offset 0) weak-p)
+       (declare (ignore weak-p))
+       (let ((instance (sap-ref-sap location offset)))
+         (unless (null-pointer-p instance)
+           (ensure-proxy-instance class (reference-foreign class instance)))))))
+
+(define-type-method destroy-function ((type proxy))
+  (let ((class (type-expand type)))
+    #'(lambda (location &optional (offset 0))
+       (unreference-foreign class (sap-ref-sap location offset)))))

 
 

-(defmethod unbound-value ((class proxy-class) &rest args)
-  (declare (ignore args))
-  (values t nil))
+(define-type-method unbound-value ((type proxy))
+  (declare (ignore type))
+  nil)

 
 (defun ensure-proxy-instance (class location &rest initargs)
   "Returns a proxy object representing the foreign object at the give
 
 (defun ensure-proxy-instance (class location &rest initargs)
   "Returns a proxy object representing the foreign object at the give


@@ -509,7 +565,12 @@ location. If an existing object is not found in the cache
 MAKE-PROXY-INSTANCE is called to create one."
   (unless (null-pointer-p location)
     (or 
 MAKE-PROXY-INSTANCE is called to create one."
   (unless (null-pointer-p location)
     (or 

-     (find-cached-instance location)
+     #-debug-ref-counting(find-cached-instance location)
+     #+debug-ref-counting
+     (let ((instance (find-cached-instance location)))
+       (when instance
+        (format t "Object found in cache: ~A~%" instance)
+        instance))

      (let ((instance (apply #'make-proxy-instance class location initargs)))
        (cache-instance instance)
        instance))))
      (let ((instance (apply #'make-proxy-instance class location initargs)))
        (cache-instance instance)
        instance))))


@@ -519,13 +580,15 @@ MAKE-PROXY-INSTANCE is called to create one."
 object at the give location. If WEAK is non NIL the foreign memory
 will not be released when the proxy is garbage collected."))
 
 object at the give location. If WEAK is non NIL the foreign memory
 will not be released when the proxy is garbage collected."))
 

-(defmethod make-proxy-instance ((class symbol) location &key weak)
-  (ensure-proxy-instance (find-class class) location :weak weak))
+(defmethod make-proxy-instance ((class symbol) location &rest initargs)
+  (apply #'make-proxy-instance (find-class class) location initargs))

 
 (defmethod make-proxy-instance ((class proxy-class) location &key weak)
 
 (defmethod make-proxy-instance ((class proxy-class) location &key weak)

-  (declare (ignore weak-p))
-  (let ((instance (allocate-instance class)))
-    (setf (slot-value instance 'location) location)
+  (let ((instance
+        (or
+         (find-invalidated-instance class)
+         (allocate-instance class))))
+    (setf (foreign-location instance) location)

     (unless weak
       (finalize instance (instance-finalizer instance)))
     instance))
     (unless weak
       (finalize instance (instance-finalizer instance)))
     instance))


@@ -538,20 +601,19 @@ will not be released when the proxy is garbage collected."))
   (:metaclass proxy-class)
   (:size 0))
 
   (:metaclass proxy-class)
   (:size 0))
 

-(defmethod initialize-instance ((struct struct) &rest initargs)
+(defmethod allocate-foreign ((struct struct) &rest initargs)

   (declare (ignore initargs))
   (declare (ignore initargs))

-  (unless (slot-boundp struct 'location)
-    (let ((size (foreign-size (class-of struct))))
-      (if (zerop size)
-         (error "~A has zero size" (class-of struct))
-       (setf (slot-value struct 'location) (allocate-memory size)))))
-  (call-next-method))
+  (let ((size (foreign-size (class-of struct))))
+    (if (zerop size)
+       (error "~A has zero size" (class-of struct))
+      (allocate-memory size))))

 
 
 ;;;; Metaclasses used for subclasses of struct
 
 
 
 ;;;; Metaclasses used for subclasses of struct
 

-(defclass struct-class (proxy-class)
-  ())
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defclass struct-class (proxy-class)
+    ()))

 
 (defmethod direct-slot-definition-class ((class struct-class) &rest initargs)
   (if (not (getf initargs :allocation))
 
 (defmethod direct-slot-definition-class ((class struct-class) &rest initargs)
   (if (not (getf initargs :allocation))


@@ -564,14 +626,36 @@ will not be released when the proxy is garbage collected."))
 (defmethod unreference-foreign ((class struct-class) location)
   (deallocate-memory location))
 
 (defmethod unreference-foreign ((class struct-class) location)
   (deallocate-memory location))
 

-(defmethod compute-foreign-size ((class struct-class))
-  (let ((size (loop
-              for slotd in (class-slots class)
-              when (eq (slot-definition-allocation slotd) :alien)
-              maximize (+ 
-                        (slot-definition-offset slotd)
-                        (size-of (slot-definition-type slotd))))))
-    (+ size (mod size +struct-alignmen+))))
+(defmethod compute-slots :around ((class struct-class))
+    (let ((slots (call-next-method)))
+      (when (and 
+            #-sbcl>=0.9.8(class-finalized-p class)
+            (not (slot-boundp class 'size)))
+        (let ((size (loop
+                    for slotd in slots
+                    when (eq (slot-definition-allocation slotd) :alien)
+                    maximize (+ 
+                              (slot-definition-offset slotd)
+                              (size-of (slot-definition-type slotd))))))
+         (setf (slot-value class 'size) (+ size (mod size +struct-alignmen+)))))
+      slots))
+
+(define-type-method callback-from-alien-form ((type struct) form)
+  (let ((class (type-expand type)))
+    `(ensure-proxy-instance ',class ,form :weak t)))
+
+(define-type-method callback-cleanup-form ((type struct) form)
+  (declare (ignore type))
+  `(invalidate-instance ,form))
+
+(define-type-method reader-function ((type struct))
+  (let ((class (type-expand type)))
+    #'(lambda (location &optional (offset 0) weak-p)
+       (let ((instance (sap-ref-sap location offset)))
+         (unless (null-pointer-p instance)
+           (if weak-p
+               (ensure-proxy-instance class instance :weak t)
+             (ensure-proxy-instance class (reference-foreign class instance))))))))

 
 
 (defclass static-struct-class (struct-class)
 
 
 (defclass static-struct-class (struct-class)


@@ -585,23 +669,24 @@ will not be released when the proxy is garbage collected."))
   (declare (ignore class location))
   nil)
 
   (declare (ignore class location))
   nil)
 

-

 ;;; Pseudo type for structs which are inlined in other objects
 
 ;;; Pseudo type for structs which are inlined in other objects
 

-(defmethod size-of ((type (eql 'inlined)) &rest args)
-  (declare (ignore type))
-  (foreign-size (first args)))
+(deftype inlined (type) type)

 
 

-(defmethod reader-function ((type (eql 'inlined)) &rest args)
-  (declare (ignore type))
-  (destructuring-bind (class) args
-    #'(lambda (location &optional (offset 0))
+(define-type-method size-of ((type inlined))
+  (let ((class (type-expand (second type))))
+    (foreign-size class)))
+
+(define-type-method reader-function ((type inlined))
+  (let ((class (type-expand (second type))))
+    #'(lambda (location &optional (offset 0) weak-p)
+       (declare (ignore weak-p))

        (ensure-proxy-instance class 
         (reference-foreign class (sap+ location offset))))))
 
        (ensure-proxy-instance class 
         (reference-foreign class (sap+ location offset))))))
 

-(defmethod destroy-function ((type (eql 'inlined)) &rest args)
-  (declare (ignore args))
-  #'(lambda (location &optional (offset 0))
-      (declare (ignore location offset))))
+(define-type-method writer-function ((type inlined))
+  (let ((class (type-expand (second type))))
+    #'(lambda (instance location &optional (offset 0))
+       (copy-memory (foreign-location instance) (foreign-size class) (sap+ location offset)))))

 
 (export 'inlined)
 
 (export 'inlined)