New file gtkselection.lisp

[clg] / glib / proxy.lisp

diff --git a/glib/proxy.lisp b/glib/proxy.lisp
index 994e880df7a2ff7728a5bb0274532a3a9179db51..ff08b84900ce8df8736615ee638c49253a0b8e1a 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.
 
-;; $Id: proxy.lisp,v 1.24 2006-02-04 12:15:32 espen Exp $
+;; $Id: proxy.lisp,v 1.26 2006-02-06 11:52:24 espen Exp $
 
 (in-package "GLIB")
 
@@ -270,6 +270,7 @@ (defun list-cached-instances ()
 
 ;;;; Proxy for alien instances
 
+;; TODO: add a ref-counted-proxy subclass
 (defclass proxy ()
   ((location :allocation :special :reader foreign-location :type pointer))
   (:metaclass virtual-slots-class))
@@ -277,6 +278,7 @@ (defclass proxy ()
 (defgeneric instance-finalizer (object))
 (defgeneric reference-foreign (class location))
 (defgeneric unreference-foreign (class location))
+(defgeneric invalidate-instance (object))
 
 (defmethod reference-foreign ((name symbol) location)
   (reference-foreign (find-class name) location))
@@ -294,13 +296,12 @@ (defmethod print-object ((instance proxy) stream)
        (format stream "at 0x~X" (sap-int (foreign-location instance)))
       (write-string "at \"unbound\"" stream))))
 
-(defmethod initialize-instance :around ((instance proxy) &key location)
-  (if location
-      (setf (slot-value instance 'location) location)      
-    (call-next-method))
-  (cache-instance instance)
-  (finalize instance (instance-finalizer instance))
-  instance)
+(defmethod initialize-instance :around ((instance proxy) &rest initargs)
+  (declare (ignore initargs))
+  (prog1
+      (call-next-method)
+    (cache-instance instance)
+    (finalize instance (instance-finalizer instance))))
 
 (defmethod instance-finalizer ((instance proxy))
   (let ((location (foreign-location instance))
@@ -311,6 +312,10 @@ (defmethod instance-finalizer ((instance proxy))
        (remove-cached-instance location)
        (unreference-foreign class location))))
 
+(defmethod invalidate-instance ((instance proxy))
+  (remove-cached-instance (foreign-location instance))
+  (slot-makunbound instance 'location))
+
 
 ;;;; Metaclass used for subclasses of proxy
 
@@ -504,20 +509,34 @@ (defmethod unbound-value ((class proxy-class) &rest args)
   (declare (ignore args))
   (values t nil))
 
-(defgeneric ensure-proxy-instance (class location)
-  (:documentation "Returns a proxy object representing the foreign object at the give location."))
-
-(defmethod ensure-proxy-instance :around (class location)
+(defun ensure-proxy-instance (class location &rest initargs)
+  "Returns a proxy object representing the foreign object at the give
+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 
-     (find-cached-instance location)
-     (call-next-method))))
-  
-(defmethod ensure-proxy-instance ((class symbol) location)
-  (ensure-proxy-instance (find-class class) location))
-
-(defmethod ensure-proxy-instance ((class proxy-class) location)
-  (make-instance class :location location))
+     (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))))
+
+(defgeneric make-proxy-instance (class location &key weak)
+  (:documentation "Creates a new proxy object representing the foreign
+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 &rest initargs)
+  (apply #'make-proxy-instance (find-class class) location initargs))
+
+(defmethod make-proxy-instance ((class proxy-class) location &key weak)
+  (let ((instance (allocate-instance class)))
+    (setf (slot-value instance 'location) location)
+    (unless weak
+      (finalize instance (instance-finalizer instance)))
+    instance))
 
 
 ;;;; Superclasses for wrapping of C structures
@@ -562,6 +581,13 @@ (defmethod compute-foreign-size ((class struct-class))
                         (size-of (slot-definition-type slotd))))))
     (+ size (mod size +struct-alignmen+))))
 
+(defmethod weak-reader-function ((class struct-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 instance :weak t)))))
+
 
 (defclass static-struct-class (struct-class)
   ())
@@ -588,6 +614,12 @@ (defmethod reader-function ((type (eql 'inlined)) &rest args)
        (ensure-proxy-instance class 
         (reference-foreign class (sap+ location offset))))))
 
+(defmethod writer-function ((type (eql 'inlined)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (class) args
+    #'(lambda (instance location &optional (offset 0))
+       (copy-memory (foreign-location instance) (foreign-size class) (sap+ location offset)))))
+
 (defmethod destroy-function ((type (eql 'inlined)) &rest args)
   (declare (ignore args))
   #'(lambda (location &optional (offset 0))