Redesigned proxy initialization protocol

diff --git a/gdk/gdkevents.lisp b/gdk/gdkevents.lisp
index c4c2920..92121cc 100644 (file)
--- a/gdk/gdkevents.lisp
+++ b/gdk/gdkevents.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: gdkevents.lisp,v 1.10 2005-04-23 16:48:50 espen Exp $
+;; $Id: gdkevents.lisp,v 1.11 2006-02-05 15:39:40 espen Exp $
 
 (in-package "GDK")
 
@@ -64,7 +64,6 @@
     ;(subtypep (class-name super) 'event)
     t))
 
-
 (defmethod shared-initialize ((class event-class) names &key name type)
   (let ((class-name (or name (class-name class))))
     (unless (eq class-name 'event)
@@ -77,10 +76,10 @@
   (defun %event-class (location)
     (gethash (funcall reader location 0) *event-classes*)))
 
-(defmethod ensure-proxy-instance ((class event-class) location)
+(defmethod make-proxy-instance :around ((class event-class) location &rest initargs)
   (declare (ignore class))
   (let ((class (%event-class location)))
-    (make-instance class :location location)))
+    (apply #'call-next-method class location initargs)))
 
 
 ;;;;

diff --git a/glib/genums.lisp b/glib/genums.lisp
index 8095b90..9baa725 100644 (file)
--- a/glib/genums.lisp
+++ b/glib/genums.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: genums.lisp,v 1.15 2006-02-04 12:15:32 espen Exp $
+;; $Id: genums.lisp,v 1.16 2006-02-05 15:38:57 espen Exp $
 
 (in-package "GLIB")
   
@@ -277,7 +277,7 @@
       (funcall query-function (type-class-ref type))
     (let ((values nil)
          (size (foreign-size (find-class class)))
-         (proxy (make-instance class :location sap)))
+         (proxy (ensure-proxy-instance class sap)))
       (dotimes (i length)
        (with-slots (location nickname value) proxy
          (setf location sap)

diff --git a/glib/gobject.lisp b/glib/gobject.lisp
index b1c4351..40ef3ea 100644 (file)
--- a/glib/gobject.lisp
+++ b/glib/gobject.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: gobject.lisp,v 1.42 2006-02-04 12:15:32 espen Exp $
+;; $Id: gobject.lisp,v 1.43 2006-02-05 15:38:57 espen Exp $
 
 (in-package "GLIB")
 
@@ -224,6 +224,12 @@
               initargs key pkey))
 
 
+(defmethod make-proxy-instance ((class gobject-class) location &rest initargs)
+  (declare (ignore location initargs))
+  (if (slot-value class 'instance-slots-p)
+      (error "An object of class ~A has instance slots and should only be created with MAKE-INSTANCE" class)
+    (call-next-method)))
+
 (defmethod initialize-instance :around ((object gobject) &rest initargs)
   (declare (ignore initargs))
   (call-next-method)

diff --git a/glib/gtype.lisp b/glib/gtype.lisp
index 2a746e2..7c36892 100644 (file)
--- a/glib/gtype.lisp
+++ b/glib/gtype.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: gtype.lisp,v 1.38 2006-02-04 12:15:32 espen Exp $
+;; $Id: gtype.lisp,v 1.39 2006-02-05 15:38:57 espen Exp $
 
 (in-package "GLIB")
 
@@ -320,7 +320,7 @@
   (let ((class (sap-ref-sap location 0)))
     (sap-ref-32 class 0)))
 
-(defmethod ensure-proxy-instance ((class ginstance-class) location)
+(defmethod make-proxy-instance :around ((class ginstance-class) location &rest initargs)
   (declare (ignore class))
   (let ((class (labels ((find-known-class (type-number)
                          (or
@@ -328,10 +328,22 @@
                           (unless (zerop type-number)
                             (find-known-class (type-parent type-number))))))
                 (find-known-class (%type-number-of-ginstance location)))))
+    ;; Note that chancing the class argument must not alter "the
+    ;; ordered set of applicable methods" as specified in the
+    ;; Hyperspec
     (if class
-       (make-instance class :location (reference-foreign class location))
-      (error "Object at ~A has an unkown type number: ~A" 
-        location (%type-number-of-ginstance location)))))
+       (apply #'call-next-method class location initargs)
+      (error "Object at ~A has an unkown type number: ~A"
+       location (%type-number-of-ginstance location)))))
+
+(defmethod make-proxy-instance ((class ginstance-class) location &rest initargs)
+  (declare (ignore initargs))
+  (reference-foreign class location)
+  ;; Since we make an explicit reference to the foreign object, we
+  ;; always have to release it when the proxy is garbage collected
+  ;; and therefor ignore the weak-p argument.
+  (call-next-method class location :weak nil))
+
 
 (defmethod copy-from-alien-form (location (class ginstance-class) &rest args)
   (declare (ignore location class args))

diff --git a/glib/proxy.lisp b/glib/proxy.lisp
index 994e880..5f0e5cf 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.25 2006-02-05 15:38:57 espen Exp $
 
 (in-package "GLIB")
 
@@ -294,13 +294,12 @@
        (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))
@@ -504,20 +503,32 @@
   (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 (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 &key weak)
+  (ensure-proxy-instance (find-class class) location :weak 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)
+    (unless weak
+      (finalize instance (instance-finalizer instance)))
+    instance))
 
 
 ;;;; Superclasses for wrapping of C structures