From 8958fa4a2ce3f4163fe4798e6d29da534f96075a Mon Sep 17 00:00:00 2001 From: espen Date: Sun, 5 Feb 2006 15:38:57 +0000 Subject: [PATCH] Redesigned proxy initialization protocol --- gdk/gdkevents.lisp | 7 +++---- glib/genums.lisp | 4 ++-- glib/gobject.lisp | 8 +++++++- glib/gtype.lisp | 22 +++++++++++++++++----- glib/proxy.lisp | 49 ++++++++++++++++++++++++++++++------------------- 5 files changed, 59 insertions(+), 31 deletions(-) diff --git a/gdk/gdkevents.lisp b/gdk/gdkevents.lisp index c4c2920..92121cc 100644 --- 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 --- 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 --- 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 --- 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 --- 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 -- 2.11.0