Small bugfix

[clg] / glib / proxy.lisp

diff --git a/glib/proxy.lisp b/glib/proxy.lisp
index f0705191f3097f5d506c3d4d23e353b8924dd57a..f989d637d8a83c5da6775d49ccd3966241b01edc 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
 
 ;; 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.1 2001/04/29 20:19:25 espen Exp $
+;; $Id: proxy.lisp,v 1.6 2001/10/21 16:55:39 espen Exp $

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


@@ -23,30 +23,27 @@ (in-package "GLIB")
 ;;;; Superclass for all metaclasses implementing some sort of virtual slots
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 ;;;; Superclass for all metaclasses implementing some sort of virtual slots
 
 (eval-when (:compile-toplevel :load-toplevel :execute)

-  (defclass virtual-class (pcl::standard-class))
+  (defclass virtual-slot-class (pcl::standard-class))

 
   (defclass direct-virtual-slot-definition (standard-direct-slot-definition)
 
   (defclass direct-virtual-slot-definition (standard-direct-slot-definition)

-    ((location
-      :reader slot-definition-location
-      :initarg :location)))
+    ((setter :reader slot-definition-setter :initarg :setter)
+     (getter :reader slot-definition-getter :initarg :getter)))

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

-(defmethod direct-slot-definition-class ((class virtual-class) initargs)
+(defmethod direct-slot-definition-class ((class virtual-slot-class) initargs)

   (if (eq (getf initargs :allocation) :virtual)
       (find-class 'direct-virtual-slot-definition)
     (call-next-method)))
 
   (if (eq (getf initargs :allocation) :virtual)
       (find-class 'direct-virtual-slot-definition)
     (call-next-method)))
 

-
-(defmethod effective-slot-definition-class ((class virtual-class) initargs)
+(defmethod effective-slot-definition-class ((class virtual-slot-class) initargs)

   (if (eq (getf initargs :allocation) :virtual)
       (find-class 'effective-virtual-slot-definition)
     (call-next-method)))
 
   (if (eq (getf initargs :allocation) :virtual)
       (find-class 'effective-virtual-slot-definition)
     (call-next-method)))
 

-
-(defun %direct-slot-definitions-slot-value (slotds slot &optional default)
+(defun %most-specific-slot-value (slotds slot &optional default)

   (let ((slotd
         (find-if
          #'(lambda (slotd)
   (let ((slotd
         (find-if
          #'(lambda (slotd)


@@ -57,67 +54,58 @@ (defun %direct-slot-definitions-slot-value (slotds slot &optional default)
     (if slotd
        (slot-value slotd slot)
       default)))
     (if slotd
        (slot-value slotd slot)
       default)))

-  
-
-(defgeneric compute-virtual-slot-location (class slotd direct-slotds))
+ 
+(defgeneric compute-virtual-slot-accessors (class slotd direct-slotds))

 
 

-(defmethod compute-virtual-slot-location
-    ((class virtual-class)
+(defmethod compute-virtual-slot-accessors
+    ((class virtual-slot-class)

      (slotd effective-virtual-slot-definition)
      direct-slotds)
      (slotd effective-virtual-slot-definition)
      direct-slotds)

-    (let ((location
-          (%direct-slot-definitions-slot-value direct-slotds 'location)))
-      (if (and location (symbolp location))
-         (list location `(setf ,location))
-       location)))
-
+    (let ((getter (%most-specific-slot-value direct-slotds 'getter))
+         (setter (%most-specific-slot-value direct-slotds 'setter)))
+      (list getter setter)))

 
 (defmethod compute-effective-slot-definition
 
 (defmethod compute-effective-slot-definition

-    ((class virtual-class) direct-slotds)
+    ((class virtual-slot-class) direct-slotds)

   (let ((slotd (call-next-method)))
     (when (typep slotd 'effective-virtual-slot-definition)
       (setf
        (slot-value slotd 'pcl::location)
   (let ((slotd (call-next-method)))
     (when (typep slotd 'effective-virtual-slot-definition)
       (setf
        (slot-value slotd 'pcl::location)

-       (compute-virtual-slot-location class slotd direct-slotds)))
+       (compute-virtual-slot-accessors class slotd direct-slotds)))

     slotd))
 
     slotd))
 

-

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

-    ((class virtual-class) (object standard-object)
+    ((class virtual-slot-class) (object standard-object)

      (slotd effective-virtual-slot-definition))
   (let ((reader (first (slot-definition-location slotd))))
     (if reader
        (funcall reader object)
       (slot-unbound class object (slot-definition-name slotd)))))
 
      (slotd effective-virtual-slot-definition))
   (let ((reader (first (slot-definition-location slotd))))
     (if reader
        (funcall reader object)
       (slot-unbound class object (slot-definition-name slotd)))))
 

-

 (defmethod slot-boundp-using-class
 (defmethod slot-boundp-using-class

-    ((class virtual-class) (object standard-object)
+    ((class virtual-slot-class) (object standard-object)

      (slotd effective-virtual-slot-definition))
    (and (first (slot-definition-location slotd)) t))
     
      (slotd effective-virtual-slot-definition))
    (and (first (slot-definition-location slotd)) t))
     

-
-

 (defmethod (setf slot-value-using-class)
 (defmethod (setf slot-value-using-class)

-    (value (class virtual-class) (object standard-object)
+    (value (class virtual-slot-class) (object standard-object)

      (slotd effective-virtual-slot-definition))
      (slotd effective-virtual-slot-definition))

-  (let ((writer (second (slot-definition-location slotd))))
+  (let ((setter (second (slot-definition-location slotd))))

     (cond
     (cond

-     ((null writer)
+     ((null setter)

       (error
        "Can't set read-only slot ~A in ~A"
        (slot-definition-name slotd)
        object))
       (error
        "Can't set read-only slot ~A in ~A"
        (slot-definition-name slotd)
        object))

-     ((or (functionp writer) (symbolp writer))
-      (funcall writer value object)
+     ((or (functionp setter) (symbolp setter))
+      (funcall setter value object)

       value)
      (t
       value)
      (t

-      (funcall (fdefinition writer) value object)
+      (funcall (fdefinition setter) value object)

       value))))
        
       value))))
        

-

 (defmethod validate-superclass
 (defmethod validate-superclass

-    ((class virtual-class) (super pcl::standard-class))
+    ((class virtual-slot-class) (super pcl::standard-class))

   t)
 
 
   t)
 
 


@@ -145,9 +133,7 @@ (defun remove-cached-instance (location)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defclass proxy ()
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defclass proxy ()

-    ((location
-      :reader proxy-location
-      :type system-area-pointer)))
+    ((location :reader proxy-location :type system-area-pointer)))

 
   (defgeneric initialize-proxy (object &rest initargs))
   (defgeneric instance-finalizer (object)))
 
   (defgeneric initialize-proxy (object &rest initargs))
   (defgeneric instance-finalizer (object)))


@@ -159,16 +145,28 @@ (defmethod initialize-instance :after ((instance proxy)
   (cache-instance instance)
   (ext:finalize instance (instance-finalizer instance)))
 
   (cache-instance instance)
   (ext:finalize instance (instance-finalizer instance)))
 

-

 (defmethod initialize-proxy ((instance proxy)
 (defmethod initialize-proxy ((instance proxy)

-                            &rest initargs)
+                            &rest initargs &key location weak-ref)

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

-  (cache-instance instance))
-
+  (setf 
+   (slot-value instance 'location)
+   (if weak-ref
+       (funcall
+       (proxy-class-copy (class-of instance))
+       (type-of instance) location)
+     location))
+  (cache-instance instance)
+  (ext:finalize instance (instance-finalizer instance)))

 
 (defmethod instance-finalizer ((instance proxy))
 
 (defmethod instance-finalizer ((instance proxy))

-  (let ((location (proxy-location instance)))
+  (let ((free (proxy-class-free (class-of instance)))
+       (type (type-of instance))
+       (location (proxy-location instance)))
+    (declare
+     (type symbol type)
+     (type system-area-pointer location))

     #'(lambda ()
     #'(lambda ()

+       (funcall free type location)

        (remove-cached-instance location))))
 
 
        (remove-cached-instance location))))
 
 


@@ -186,28 +184,38 @@ (deftype-method translate-from-alien
      (unless (null-pointer-p location)
        (ensure-proxy-instance ',type-spec location ,weak-ref))))
 
      (unless (null-pointer-p location)
        (ensure-proxy-instance ',type-spec location ,weak-ref))))
 

+(deftype-method translate-to-alien
+    proxy (type-spec instance &optional weak-ref)
+  (if weak-ref
+      `(proxy-location ,instance)
+    `(funcall
+      ',(proxy-class-copy (find-class type-spec))
+      ',type-spec (proxy-location ,instance))))

 
 

+(deftype-method unreference-alien proxy (type-spec location)
+  `(funcall ',(proxy-class-free (find-class type-spec)) ',type-spec ,location))
+
+(defun proxy-instance-size (proxy)
+  (proxy-class-size (class-of proxy)))

 
 ;;;; Metaclass used for subclasses of proxy
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 
 ;;;; Metaclass used for subclasses of proxy
 
 (eval-when (:compile-toplevel :load-toplevel :execute)

-  (defclass proxy-class (virtual-class)
-    ((size :reader proxy-class-instance-size)))
+  (defclass proxy-class (virtual-slot-class)
+    ((size :reader proxy-class-size)
+     (copy :reader proxy-class-copy)
+     (free :reader proxy-class-free)))

 
   (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
 
   (defclass direct-alien-slot-definition (direct-virtual-slot-definition)

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

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

- 
+

 
   (defmethod most-specific-proxy-superclass ((class proxy-class))
     (find-if
 
   (defmethod most-specific-proxy-superclass ((class proxy-class))
     (find-if


@@ -215,33 +223,34 @@   (defmethod most-specific-proxy-superclass ((class proxy-class))
         (subtypep (class-name class) 'proxy))
      (cdr (pcl::compute-class-precedence-list class))))
 
         (subtypep (class-name class) 'proxy))
      (cdr (pcl::compute-class-precedence-list class))))
 

+  (defmethod direct-proxy-superclass ((class proxy-class))
+    (find-if
+     #'(lambda (class)
+        (subtypep (class-name class) 'proxy))
+     (pcl::class-direct-superclasses class)))

 
   (defmethod shared-initialize ((class proxy-class) names
 
   (defmethod shared-initialize ((class proxy-class) names

-                               &rest initargs &key size name)
+                               &rest initargs &key size copy free)

     (declare (ignore initargs))
     (call-next-method)
     (declare (ignore initargs))
     (call-next-method)

-    (when size
-      (setf (slot-value class 'size) (first size))))
-    
-
-  (defmethod shared-initialize :after ((class proxy-class) names
-                                      &rest initargs &key)
-    (declare (ignore initargs names))
-    (let* ((super (most-specific-proxy-superclass class))
-          (actual-size
-           (if (eq (class-name super) 'proxy)
-               0
-             (proxy-class-instance-size super))))
-      (dolist (slotd (class-slots class))
-       (when (eq (slot-definition-allocation slotd) :alien)
-         (with-slots (offset type) slotd
-           (setq actual-size (max actual-size (+ offset (size-of type)))))))
-      (cond
-       ((not (slot-boundp class 'size))
-       (setf (slot-value class 'size) actual-size))
-       ((> actual-size (slot-value class 'size))
-       (warn "The actual size of class ~A is lager than specified" class)))))
+    (cond
+     (size (setf (slot-value class 'size) (first size)))
+     ((slot-boundp class 'size) (slot-makunbound class 'size)))
+    (cond
+     (copy (setf (slot-value class 'copy) (first copy)))
+     ((slot-boundp class 'copy) (slot-makunbound class 'copy)))
+    (cond
+     (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)
+    (let ((super (most-specific-proxy-superclass class)))
+      (unless (or (not super) (eq super (find-class 'proxy)))
+       (unless (or (slot-boundp class 'copy) (not (slot-boundp super 'copy)))
+         (setf (slot-value class 'copy) (proxy-class-copy super)))
+       (unless (or (slot-boundp class 'free) (not (slot-boundp super 'free)))
+         (setf (slot-value class 'free) (proxy-class-free super))))))

 
   (defmethod direct-slot-definition-class ((class proxy-class) initargs)
     (case (getf initargs :allocation)
 
   (defmethod direct-slot-definition-class ((class proxy-class) initargs)
     (case (getf initargs :allocation)


@@ -249,22 +258,20 @@   (defmethod direct-slot-definition-class ((class proxy-class) initargs)
 ;      (:instance (error "Allocation :instance not allowed in class ~A" class))
       (t (call-next-method))))
 
 ;      (:instance (error "Allocation :instance not allowed in class ~A" class))
       (t (call-next-method))))
 

-

   (defmethod effective-slot-definition-class ((class proxy-class) initargs)
     (case (getf initargs :allocation)
       (:alien (find-class 'effective-alien-slot-definition))
       (:virtual (find-class 'effective-virtual-alien-slot-definition))
       (t (call-next-method))))
   
   (defmethod effective-slot-definition-class ((class proxy-class) initargs)
     (case (getf initargs :allocation)
       (:alien (find-class 'effective-alien-slot-definition))
       (:virtual (find-class 'effective-virtual-alien-slot-definition))
       (t (call-next-method))))
   

-  
-  (defmethod compute-virtual-slot-location
+  (defmethod compute-virtual-slot-accessors

       ((class proxy-class) (slotd effective-alien-slot-definition)
        direct-slotds)
     (with-slots (offset type) slotd
       ((class proxy-class) (slotd effective-alien-slot-definition)
        direct-slotds)
     (with-slots (offset type) slotd

-      (setf offset (%direct-slot-definitions-slot-value direct-slotds 'offset))

       (let ((reader (intern-reader-function type))
            (writer (intern-writer-function type))
            (destroy (intern-destroy-function type)))
       (let ((reader (intern-reader-function type))
            (writer (intern-writer-function type))
            (destroy (intern-destroy-function type)))

+       (setf offset (slot-definition-offset (first direct-slotds)))

        (list
         #'(lambda (object)
             (funcall reader (proxy-location object) offset))
        (list
         #'(lambda (object)
             (funcall reader (proxy-location object) offset))


@@ -272,86 +279,52 @@   (defmethod compute-virtual-slot-location
             (let ((location (proxy-location object)))
               (funcall destroy location offset)
               (funcall writer value location offset)))))))
             (let ((location (proxy-location object)))
               (funcall destroy location offset)
               (funcall writer value location offset)))))))

-            
-  
-  (defmethod compute-virtual-slot-location
+ 
+  (defmethod compute-virtual-slot-accessors

       ((class proxy-class)
        (slotd effective-virtual-alien-slot-definition)
        direct-slotds)
       ((class proxy-class)
        (slotd effective-virtual-alien-slot-definition)
        direct-slotds)

-    (let ((location (call-next-method)))
-      (if (or (stringp location) (consp location))
-         (destructuring-bind (reader &optional writer) (mklist location)
-           (with-slots (type) slotd
-              (list
-              (if (stringp reader)
-                  (let* ((alien-type (translate-type-spec type))
-                         (alien
-                          (alien::%heap-alien
-                           (alien::make-heap-alien-info
-                            :type (alien::parse-alien-type
-                                   `(function ,alien-type system-area-pointer))
-                            :sap-form (system:foreign-symbol-address reader))))
-                         (translate-return-value
-                          (intern-return-value-translator type)))
-                    #'(lambda (object)
-                        (funcall
-                         translate-return-value
-                         (alien-funcall
-                          alien (proxy-location object)))))
-                reader)
-              (if (stringp writer)
-                  (let* ((alien-type (translate-type-spec type))
-                         (alien
-                          (alien::%heap-alien
-                           (alien::make-heap-alien-info
-                            :type (alien::parse-alien-type
-                                   `(function
-                                     void system-area-pointer ,alien-type))
-                            :sap-form (system:foreign-symbol-address writer))))
-                         (translate-argument (intern-argument-translator type))
-                         (cleanup (intern-cleanup-function type)))
-                    #'(lambda (value object)
-                        (let ((tmp (funcall translate-argument value))
-                              (location (proxy-location object)))
-                          (alien-funcall alien location tmp)
-                          (funcall cleanup tmp))))
-                writer))))
-       location)))
-
+    (destructuring-bind (getter setter) (call-next-method)
+      (let ((class-name (class-name class)))
+       (with-slots (type) slotd
+         (list
+          (if (stringp getter)
+              (let ((getter (mkbinding-late getter type 'pointer)))
+                #'(lambda (object)
+                    (funcall getter (proxy-location object))))
+            getter)
+          (if (stringp setter)
+              (let ((setter (mkbinding-late setter 'nil 'pointer type)))
+                #'(lambda (value object)
+                    (funcall setter (proxy-location object) value)))
+            setter))))))

 
   (defmethod compute-slots ((class proxy-class))
 
   (defmethod compute-slots ((class proxy-class))

-    ;; Translating the user supplied relative (to previous slot) offsets
-    ;; to absolute offsets.
-    ;; This code is broken and have to be fixed.
-    (with-slots (direct-slots) class
-      (let* ((super (most-specific-proxy-superclass class))
-            (slot-offset
-             (if (eq (class-name super) 'proxy)
-                 0
-               (proxy-class-instance-size super))))
+    (with-slots (direct-slots size) class
+      (let ((current-offset
+            (proxy-class-size (most-specific-proxy-superclass class)))
+           (max-size 0))

        (dolist (slotd direct-slots)
          (when (eq (slot-definition-allocation slotd) :alien)
            (with-slots (offset type) slotd
        (dolist (slotd direct-slots)
          (when (eq (slot-definition-allocation slotd) :alien)
            (with-slots (offset type) slotd

-             (setf
-              offset (+ slot-offset offset)
-              slot-offset (+ offset (size-of type)))))))
-    
-      ;; Reverse the direct slot definitions so the effective slots
-      ;; will be in correct order.
-      (setf direct-slots (reverse direct-slots))
-      ;; This nreverse caused me so much frustration that I leave it
-      ;; here just as a reminder of what not to do.
-;      (setf direct-slots (nreverse direct-slots))
-      )
+             (unless (slot-boundp slotd 'offset)
+               (setf offset current-offset))
+             (setq current-offset (+ offset (size-of type)))
+             (setq max-size (max max-size current-offset)))))
+       (unless (slot-boundp class 'size)
+         (setf size max-size))))

     (call-next-method))
     (call-next-method))

-
-
+   

   (defmethod validate-superclass ((class proxy-class)
                                  (super pcl::standard-class))
   (defmethod validate-superclass ((class proxy-class)
                                  (super pcl::standard-class))

-     (subtypep (class-name super) 'proxy))
+    (subtypep (class-name super) 'proxy))

 
 

-  (defgeneric make-proxy-instance (class location weak-ref &rest initargs &key)))
+  (defmethod proxy-class-size (class)
+    (declare (ignore class))
+    0)

 
 

+  (defgeneric make-proxy-instance (class location weak-ref
+                                  &rest initargs &key)))

 
 (defmethod make-proxy-instance ((class symbol) location weak-ref
                                &rest initargs &key)
 
 (defmethod make-proxy-instance ((class symbol) location weak-ref
                                &rest initargs &key)


@@ -371,52 +344,44 @@ (defun ensure-proxy-instance (class location weak-ref &rest initargs)
    (apply #'make-proxy-instance class location weak-ref initargs)))
 
 
    (apply #'make-proxy-instance class location weak-ref initargs)))
 
 

-;;;; Superclass for wrapping of C structures
+
+;;;; Superclasses for wrapping of C structures

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

-  (defclass alien-structure (proxy)
+  (defclass struct (proxy)

     ()
     (:metaclass proxy-class)
     ()
     (:metaclass proxy-class)

-    (:size 0)))
-
+    (:copy %copy-struct)
+    (:free %free-struct)))

 
 

-(defmethod initialize-instance ((structure alien-structure)
+(defmethod initialize-instance ((structure struct)

                                &rest initargs)
   (declare (ignore initargs))
   (setf 
    (slot-value structure 'location)
                                &rest initargs)
   (declare (ignore initargs))
   (setf 
    (slot-value structure 'location)

-   (allocate-memory (proxy-class-instance-size (class-of structure))))
+   (allocate-memory (proxy-class-size (class-of structure))))

   (call-next-method))
 
 
   (call-next-method))
 
 

-(defmethod initialize-proxy ((structure alien-structure)
-                            &rest initargs &key location weak-ref)
-  (declare (ignore initargs))
-  (setf
-   (slot-value structure 'location)
-   (if weak-ref
-       (copy-memory location (proxy-class-instance-size (class-of structure)))
-     location))
-  (call-next-method))
-
+(defun %copy-struct (type location)
+  (copy-memory location (proxy-class-size (find-class type))))

 
 

-(defmethod instance-finalizer ((structure alien-structure))
-  (let ((location (proxy-location structure)))
-    (declare (type system-area-pointer location))
-    #'(lambda ()
-       (deallocate-memory location)
-       (remove-cached-instance location))))
+(defun %free-struct (type location)
+  (declare (ignore type))
+  (deallocate-memory location))

 
 
 
 

-(deftype-method translate-to-alien
-     alien-structure (type-spec object &optional weak-ref)
-  (if weak-ref
-      `(proxy-location ,object)
-    `(copy-memory
-      (proxy-location ,object)
-      ,(proxy-class-instance-size (find-class type-spec)))))
+;(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defclass static (struct)
+    ()
+    (:metaclass proxy-class)
+    (:copy %copy-static)
+    (:free %free-static));)

 
 

+(defun %copy-static (type location)
+  (declare (ignore type))
+  location)

 
 

-(deftype-method unreference-alien alien-structure (type-spec c-struct)
-  (declare (ignore type-spec))
-  `(deallocate-memory ,c-struct))
+(defun %free-static (type location)
+  (declare (ignore type location))
+  nil)