X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/2bd78f93f681c3afb5b555265ae3831fbe3ba017..406aa97b03d3f732c280b04e3f6c12cfc66e338f:/glib/gobject.lisp diff --git a/glib/gobject.lisp b/glib/gobject.lisp index 115a04c..68ee82c 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.54 2006-08-16 12:09:03 espen Exp $ +;; $Id: gobject.lisp,v 1.59 2008-11-04 03:22:23 espen Exp $ (in-package "GLIB") @@ -32,18 +32,26 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defclass gobject-class (ginstance-class) ((instance-slots-p :initform nil :reader instance-slots-p :documentation "Non NIL if the class has slots with instance allocation"))) - (defmethod shared-initialize ((class gobject-class) names &rest initargs) - (declare (ignore names initargs)) - (call-next-method) - (unless (slot-boundp class 'ref) - (setf (slot-value class 'ref) '%object-ref)) - (unless (slot-boundp class 'unref) - (setf (slot-value class 'unref) '%object-unref))) (defmethod validate-superclass ((class gobject-class) (super standard-class)) ; (subtypep (class-name super) 'gobject) t)) +(defmethod slot-unbound (metaclass (class gobject-class) (slot (eql 'ref))) + (assert (class-direct-superclasses class)) + (setf (slot-value class 'ref) + #?-(pkg-exists-p "glib-2.0" :atleast-version "2.10.0") '%object-ref + #?(pkg-exists-p "glib-2.0" :atleast-version "2.10.0") + ;; We do this hack instead of creating a new metaclass to avoid + ;; breaking backward compatibility + (if (subtypep (class-name class) 'initially-unowned) + '%object-ref-sink + '%object-ref))) + +(defmethod slot-unbound (metaclass (class gobject-class) (slot (eql 'unref))) + (setf (slot-value class 'unref) '%object-unref)) + + (defclass direct-property-slot-definition (direct-virtual-slot-definition) ((pname :reader slot-definition-pname :initarg :pname) (readable :reader slot-readable-p :initarg :readable) @@ -144,17 +152,20 @@ (defmethod compute-slot-reader-function ((slotd effective-property-slot-definiti (declare (ignore signal-unbound-p)) (let* ((type (slot-definition-type slotd)) (pname (slot-definition-pname slotd)) - (reader (reader-function type :ref :get))) + (get-reader (reader-function type :ref :get)) + (peek-reader (reader-function type :ref :peek))) #'(lambda (object) (with-memory (gvalue +gvalue-size+) (%gvalue-init gvalue (find-type-number type)) (%object-get-property object pname gvalue) - (funcall reader gvalue +gvalue-value-offset+))))) + (if (gvalue-static-p gvalue) + (funcall peek-reader gvalue +gvalue-value-offset+) + (funcall get-reader gvalue +gvalue-value-offset+)))))) (defmethod compute-slot-writer-function :around ((slotd effective-property-slot-definition)) (if (construct-only-property-p slotd) #'(lambda (value object) - (declare (ignore value object)) + (declare (ignore value)) (unless *ignore-setting-construct-only-property* (error 'unwritable-slot :name (slot-definition-name slotd) :instance object))) (call-next-method))) @@ -271,6 +282,10 @@ (defmethod make-proxy-instance ((class gobject-class) location &rest initargs) (error "Objects of class ~A has instance slots and should only be created with MAKE-INSTANCE" class) (call-next-method))) +(defparameter +gparameter-gvalue-offset+ + (max (size-of 'pointer) (type-alignment '(unsigned-byte 64)))) +(defparameter +gparameter-size+ + (+ +gparameter-gvalue-offset+ +gvalue-size+)) (defmethod allocate-foreign ((object gobject) &rest initargs) (let ((init-slots ())) @@ -296,18 +311,17 @@ (defmethod allocate-foreign ((object gobject) &rest initargs) (cond (init-slots - (let* ((pointer-size (size-of 'pointer)) - (element-size (+ +gvalue-size+ pointer-size)) - (num-slots (length init-slots))) - (with-memory (params (* num-slots element-size)) + (let* ((num-slots (length init-slots))) + (with-memory (params (* num-slots +gparameter-size+)) (loop with string-writer = (writer-function 'string) for (slotd . value) in init-slots - as param = params then (pointer+ param element-size) + as param = params then (pointer+ param +gparameter-size+) as type = (slot-definition-type slotd) as pname = (slot-definition-pname slotd) do (funcall string-writer pname param) - (gvalue-init (pointer+ param pointer-size) type value)) + (gvalue-init + (pointer+ param +gparameter-gvalue-offset+) type value)) (unwind-protect (%gobject-newv (type-number-of object) num-slots params) @@ -315,10 +329,10 @@ (defmethod allocate-foreign ((object gobject) &rest initargs) (loop with string-destroy = (destroy-function 'string) repeat num-slots - as param = params then (pointer+ param element-size) + as param = params then (pointer+ param +gparameter-size+) do (funcall string-destroy param) - (gvalue-unset (pointer+ param pointer-size))))))) - + (gvalue-unset (pointer+ param +gparameter-gvalue-offset+))))))) + (t (%gobject-new (type-number-of object)))))) @@ -331,11 +345,12 @@ (defmethod initialize-instance :around ((object gobject) &rest initargs) (declare (ignore initargs)) (prog1 (call-next-method) - #+debug-ref-counting(%object-weak-ref (foreign-location object)) - #?(pkg-exists-p "glib-2.0" :atleast-version "2.8.0") - (when (slot-value (class-of object) 'instance-slots-p) - (%object-add-toggle-ref (foreign-location object)) - (%object-unref (foreign-location object))))) + (let ((location (foreign-location object))) + #+debug-ref-counting(%object-weak-ref location) + #?(pkg-exists-p "glib-2.0" :atleast-version "2.8.0") + (when (slot-value (class-of object) 'instance-slots-p) + (%object-add-toggle-ref location) + (%object-unref location))))) (defmethod instance-finalizer ((instance gobject)) @@ -344,11 +359,15 @@ (defmethod instance-finalizer ((instance gobject)) (if (slot-value (class-of instance) 'instance-slots-p) #'(lambda () #+debug-ref-counting - (format t "Finalizing proxy for 0x~8,'0X~%" (pointer-address location)) + (format t "Finalizing proxy for 0x~8,'0X (~A)~%" + (pointer-address location) + (find-foreign-type-name (%type-number-of-ginstance location))) (%object-remove-toggle-ref location)) #'(lambda () #+debug-ref-counting - (format t "Finalizing proxy for 0x~8,'0X~%" (pointer-address location)) + (format t "Finalizing proxy for 0x~8,'0X (~A)~%" + (pointer-address location) + (find-foreign-type-name (%type-number-of-ginstance location))) (%object-unref location))) #?-(pkg-exists-p "glib-2.0" :atleast-version "2.8.0") #'(lambda () @@ -365,6 +384,25 @@ (defbinding (%gobject-newv "g_object_newv") () pointer (params pointer)) +;;;; Floating references + +#?(pkg-exists-p "glib-2.0" :atleast-version "2.10.0") +(progn + (defclass initially-unowned (gobject) + () + (:metaclass gobject-class) + (:gtype "GInitiallyUnowned")) + + (defbinding %object-ref-sink () pointer + (location pointer)) + + (defbinding %object-is-floating () boolean + (location pointer)) + + (defmethod initialize-instance :before ((object initially-unowned) &rest initargs) + (declare (ignore initargs)) + (%object-ref-sink (foreign-location object)))) + ;;;; Property stuff @@ -391,35 +429,40 @@ (defbinding object-thaw-notify () nil ;;;; User data +(defgeneric (setf user-data) (data object key)) +(defgeneric user-data (object key)) +(defgeneric user-data-p (object key)) +(defgeneric unset-user-data (object key)) + (defbinding %object-set-qdata-full () nil (object gobject) (id quark) - (data unsigned-long) + (data pointer-data) (destroy-marshal callback)) -(define-callback user-data-destroy-callback nil ((id unsigned-int)) +(define-callback user-data-destroy-callback nil ((id pointer-data)) (destroy-user-data id)) -(defun (setf user-data) (data object key) +(defmethod (setf user-data) (data (object gobject) key) (%object-set-qdata-full object (quark-intern key) (register-user-data data) user-data-destroy-callback) data) -(defbinding %object-get-qdata () unsigned-long +(defbinding %object-get-qdata () pointer-data (object gobject) (id quark)) -(defun user-data (object key) +(defmethod user-data ((object gobject) key) (find-user-data (%object-get-qdata object (quark-intern key)))) -(defun user-data-p (object key) +(defmethod user-data-p ((object gobject) key) (user-data-exists-p (%object-get-qdata object (quark-intern key)))) -(defbinding %object-steal-qdata () unsigned-long +(defbinding %object-steal-qdata () pointer-data (object gobject) (id quark)) -(defun unset-user-data (object key) +(defmethod unset-user-data ((object gobject) key) (destroy-user-data (%object-steal-qdata object (quark-intern key)))) @@ -543,6 +586,10 @@ (defun expand-gobject-type (type forward-p options &optional (metaclass 'gobject (let ((supers (cons (supertype type) (implements type))) (class (type-from-number type)) (slots (getf options :slots))) + (when (member nil supers) + (error "Got NIL as a supertype for ~A (full list: ~A).~%~ + This shouldn't happen - is the parent type correctly registered?" + (find-foreign-type-name type) supers)) `(defclass ,class ,supers ,(unless forward-p (slot-definitions class (query-object-class-properties type) slots))