X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/112ac1d33aa8f9b7f3d2f9542d15431f152b1d35..e624bc26ef4d71c868839b403d110152cf22d714:/glib/gobject.lisp diff --git a/glib/gobject.lisp b/glib/gobject.lisp index f0b0ef1..3c67fe0 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.36 2005-04-23 16:48:51 espen Exp $ +;; $Id: gobject.lisp,v 1.46 2006-02-09 22:29:01 espen Exp $ (in-package "GLIB") @@ -28,8 +28,10 @@ (in-package "GLIB") ;;;; Metaclass used for subclasses of gobject (eval-when (:compile-toplevel :load-toplevel :execute) +;; (push :debug-ref-counting *features*) (defclass gobject-class (ginstance-class) - ()) + ((instance-slots-p :initform nil + :documentation "Non NIL if the class has slots with instance allocation"))) (defmethod validate-superclass ((class gobject-class) (super standard-class)) ; (subtypep (class-name super) 'gobject) @@ -37,15 +39,15 @@ (defmethod validate-superclass ((class gobject-class) (super standard-class)) (defclass direct-property-slot-definition (direct-virtual-slot-definition) ((pname :reader slot-definition-pname :initarg :pname) - (readable :initform t :reader slot-readable-p :initarg :readable) - (writable :initform t :reader slot-writable-p :initarg :writable) - (construct :initform nil :initarg :construct))) + (readable :reader slot-readable-p :initarg :readable) + (writable :reader slot-writable-p :initarg :writable) + (construct-only :initarg :construct-only :reader construct-only-property-p))) (defclass effective-property-slot-definition (effective-virtual-slot-definition) ((pname :reader slot-definition-pname :initarg :pname) (readable :reader slot-readable-p :initarg :readable) (writable :reader slot-writable-p :initarg :writable) - (construct :initarg :construct))) + (construct-only :initarg :construct-only :reader construct-only-property-p))) (defclass direct-user-data-slot-definition (direct-virtual-slot-definition) ()) @@ -60,6 +62,27 @@ (defbinding %object-ref () pointer (defbinding %object-unref () nil (location pointer)) +#+glib2.8 +(progn + (defcallback toggle-ref-callback (nil (data pointer) (location pointer) (last-ref-p boolean)) + #+debug-ref-counting + (if last-ref-p + (format t "Object at 0x~8,'0X has no foreign references~%" (sap-int location)) + (format t "Foreign reference added to object at 0x~8,'0X~%" (sap-int location))) + (if last-ref-p + (cache-instance (find-cached-instance location) t) + (cache-instance (find-cached-instance location) nil))) + + (defbinding %object-add-toggle-ref () pointer + (location pointer) + ((callback toggle-ref-callback) pointer) + (nil null)) + + (defbinding %object-remove-toggle-ref () pointer + (location pointer) + ((callback toggle-ref-callback) pointer) + (nil null))) + (defmethod reference-foreign ((class gobject-class) location) (declare (ignore class)) (%object-ref location)) @@ -68,6 +91,16 @@ (defmethod unreference-foreign ((class gobject-class) location) (declare (ignore class)) (%object-unref location)) +#+debug-ref-counting +(progn + (defcallback weak-ref-callback (nil (data pointer) (location pointer)) + (format t "Object at 0x~8,'0X being finalized~%" (sap-int location))) + + (defbinding %object-weak-ref () pointer + (location pointer) + ((callback weak-ref-callback) pointer) + (nil null))) + ; (defbinding object-class-install-param () nil ; (class pointer) @@ -98,14 +131,19 @@ (defmethod compute-effective-slot-definition-initargs ((class gobject-class) dir (if (typep (first direct-slotds) 'direct-property-slot-definition) (nconc (list :pname (signal-name-to-string - (most-specific-slot-value direct-slotds 'pname)) - :readable (most-specific-slot-value direct-slotds 'readable) - :writable (most-specific-slot-value direct-slotds 'writable) - :construct (most-specific-slot-value direct-slotds 'construct)) + (most-specific-slot-value direct-slotds 'pname + (slot-definition-name (first direct-slotds)))) + :readable (most-specific-slot-value direct-slotds 'readable t) + :writable (most-specific-slot-value direct-slotds 'writable t) + :construct-only (most-specific-slot-value direct-slotds + 'construct-only nil)) (call-next-method)) (call-next-method))) +(defvar *ignore-setting-construct-only-property* nil) +(declaim (special *ignore-setting-construct-only-property*)) + (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-definition)) (let ((type (slot-definition-type slotd)) (pname (slot-definition-pname slotd))) @@ -122,18 +160,28 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de (funcall reader gvalue +gvalue-value-offset+) (gvalue-free gvalue t))))))) - (when (and (not (slot-boundp slotd 'setter)) (slot-writable-p slotd)) - (setf - (slot-value slotd 'setter) - (let ((writer nil)) + (when (not (slot-boundp slotd 'setter)) + (cond + ((slot-writable-p slotd) + (setf + (slot-value slotd 'setter) + (let ((writer nil)) + #'(lambda (value object) + (unless writer + (setq writer (writer-function type))) + (let ((gvalue (gvalue-new type))) + (funcall writer value gvalue +gvalue-value-offset+) + (%object-set-property object pname gvalue) + (gvalue-free gvalue t) + value))))) + + ((construct-only-property-p slotd) + (setf + (slot-value slotd 'setter) #'(lambda (value object) - (unless writer - (setq writer (writer-function type))) - (let ((gvalue (gvalue-new type))) - (funcall writer value gvalue +gvalue-value-offset+) - (%object-set-property object pname gvalue) - (gvalue-free gvalue t) - value)))))) + (declare (ignore value object)) + (unless *ignore-setting-construct-only-property* + (error "Slot is not writable: ~A" (slot-definition-name slotd))))))))) (call-next-method)) @@ -156,15 +204,33 @@ (defmethod initialize-internal-slot-functions ((slotd effective-user-data-slot-d (user-data-p object slot-name))))) (call-next-method)) +(defmethod shared-initialize :after ((class gobject-class) names &rest initargs) + (declare (ignore initargs)) + (when (some #'(lambda (slotd) + (and + (eq (slot-definition-allocation slotd) :instance) + (not (typep slotd 'effective-special-slot-definition)))) + (class-slots class)) + (setf (slot-value class 'instance-slots-p) t))) + + ;;;; Super class for all classes in the GObject type hierarchy (eval-when (:compile-toplevel :load-toplevel :execute) (defclass gobject (ginstance) - () + (#+debug-ref-counting + (ref-count :allocation :alien :type int :reader ref-count)) (:metaclass gobject-class) (:gtype "GObject"))) +#+debug-ref-counting +(defmethod print-object ((instance gobject) stream) + (print-unreadable-object (instance stream :type t :identity nil) + (if (proxy-valid-p instance) + (format stream "at 0x~X (~D)" (sap-int (foreign-location instance)) (ref-count instance)) + (write-string "at \"unbound\"" stream)))) + (defun initial-add (object function initargs key pkey) (loop @@ -182,60 +248,97 @@ (defun initial-apply-add (object function initargs key pkey) initargs key pkey)) -(defmethod initialize-instance ((object gobject) &rest initargs) - (unless (slot-boundp object 'location) - ;; Extract initargs which we should pass directly to the GObeject - ;; constructor - (let* ((slotds (class-slots (class-of object))) - (args (when initargs - (loop - as (key value . rest) = initargs then rest - as slotd = (find-if - #'(lambda (slotd) - (member key (slot-definition-initargs slotd))) - slotds) - when (and (typep slotd 'effective-property-slot-definition) - (slot-value slotd 'construct)) - collect (progn - (remf initargs key) - (list - (slot-definition-pname slotd) - (slot-definition-type slotd) - value)) - while rest)))) - (if args - (let* ((string-size (size-of 'string)) - (string-writer (writer-function 'string)) - (string-destroy (destroy-function 'string)) - (params (allocate-memory - (* (length args) (+ string-size +gvalue-size+))))) +(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 allocate-foreign ((object gobject) &rest initargs) + (let ((init-slots ())) + (flet ((value-from-initargs (slotd) + (loop + with slot-initargs = (slot-definition-initargs slotd) + for (initarg value) on initargs by #'cddr + when (find initarg slot-initargs) + do (return (values value t))))) + + (loop + for slotd in (class-slots (class-of object)) + when (and + (eq (slot-definition-allocation slotd) :property) + (construct-only-property-p slotd)) + do (multiple-value-bind (value initarg-p) (value-from-initargs slotd) + (cond + (initarg-p (push (cons slotd value) init-slots)) + ((slot-definition-initfunction slotd) + (push + (cons slotd (funcall (slot-definition-initfunction slotd))) + init-slots)))))) + + (cond + (init-slots + (let ((element-size (+ +gvalue-size+ +size-of-pointer+)) + (num-slots (length init-slots))) + (with-allocated-memory (params (* num-slots element-size)) + (loop + with string-writer = (writer-function 'string) + for (slotd . value) in init-slots + as offset = params then (sap+ offset element-size) + as type = (slot-definition-type slotd) + as pname = (slot-definition-pname slotd) + do (funcall string-writer pname offset) + (gvalue-init (sap+ offset +size-of-pointer+) type value)) + + (unwind-protect + (%gobject-newv (type-number-of object) num-slots params) + (loop - for (pname type value) in args - as tmp = params then (sap+ tmp (+ string-size +gvalue-size+)) - do (funcall string-writer pname tmp) - (gvalue-init (sap+ tmp string-size) type value)) - (unwind-protect - (setf - (slot-value object 'location) - (%gobject-newv (type-number-of object) (length args) params)) - (loop - repeat (length args) - as tmp = params then (sap+ tmp (+ string-size +gvalue-size+)) - do (funcall string-destroy tmp) - (gvalue-unset (sap+ tmp string-size))) - (deallocate-memory params))) - (setf - (slot-value object 'location) - (%gobject-new (type-number-of object)))))) - - (apply #'call-next-method object initargs)) + with string-destroy = (destroy-function 'string) + repeat num-slots + as offset = params then (sap+ offset element-size) + do (funcall string-destroy offset) + (gvalue-unset (sap+ offset +size-of-pointer+))))))) + + (t (%gobject-new (type-number-of object)))))) + + +(defmethod shared-initialize ((object gobject) names &rest initargs) + (declare (ignore names initargs)) + (let ((*ignore-setting-construct-only-property* t)) + (call-next-method))) + +(defmethod initialize-instance :around ((object gobject) &rest initargs) + (declare (ignore initargs)) + (prog1 + (call-next-method) + #+debug-ref-counting(%object-weak-ref (foreign-location object)) + #+glib2.8 + (when (slot-value (class-of object) 'instance-slots-p) + (with-slots (location) object + (%object-add-toggle-ref location) + (%object-unref location))))) (defmethod instance-finalizer ((instance gobject)) - (let ((location (proxy-location instance))) + (let ((location (foreign-location instance))) + #+glib2.8 + (if (slot-value (class-of instance) 'instance-slots-p) + #'(lambda () + #+debug-ref-counting + (format t "Finalizing proxy for 0x~8,'0X~%" (sap-int location)) + (remove-cached-instance location) + (%object-remove-toggle-ref location)) + #'(lambda () + #+debug-ref-counting + (format t "Finalizing proxy for 0x~8,'0X~%" (sap-int location)) + (remove-cached-instance location) + (%object-unref location))) + #-glib2.8 #'(lambda () (remove-cached-instance location) - (%object-unref location)))) + (%object-unref location)))) (defbinding (%gobject-new "g_object_new") () pointer @@ -390,9 +493,8 @@ (defun slot-definition-from-property (class property &optional slot-name args) '(:writable nil)) ,@(when (not (member :readable flags)) '(:readable nil)) - ,@(when (or (member :construct flags) - (member :construct-only flags)) - '(:construct t)) + ,@(when (member :construct-only flags) + '(:construct-only t)) ;; initargs ,@(if (find :initarg args) @@ -464,7 +566,7 @@ (defmethod from-alien-form (form (type (eql 'referenced)) &rest args) (let ((instance (make-symbol "INSTANCE"))) `(let ((,instance ,(from-alien-form form type))) (when ,instance - (%object-unref (proxy-location ,instance))) + (%object-unref (foreign-location ,instance))) ,instance)) (error "~A is not a subclass of GOBJECT" type))))