X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/584285fba4d518f8d6f581b542ee6b38650ba287..db7a1e771d6aec41d0489b07c546d99ebbbc1019:/glib/gobject.lisp diff --git a/glib/gobject.lisp b/glib/gobject.lisp index ae5995a..e9cbffd 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.53 2006-08-16 11:02:46 espen Exp $ +;; $Id: gobject.lisp,v 1.57 2007-06-01 10:46:15 espen Exp $ (in-package "GLIB") @@ -63,15 +63,6 @@ (defclass effective-user-data-slot-definition (effective-virtual-slot-definition ()) -(defmethod slot-readable-p ((slotd standard-effective-slot-definition)) - (declare (ignore slotd)) - t) - -(defmethod slot-writable-p ((slotd standard-effective-slot-definition)) - (declare (ignore slotd)) - t) - - (defbinding %object-ref () pointer (location pointer)) @@ -151,38 +142,39 @@ (declaim (special *ignore-setting-construct-only-property*)) (defmethod compute-slot-reader-function ((slotd effective-property-slot-definition) &optional signal-unbound-p) (declare (ignore signal-unbound-p)) - (if (slot-readable-p slotd) - (let* ((type (slot-definition-type slotd)) - (pname (slot-definition-pname slotd)) - (reader (reader-function type :ref :get))) - #'(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+)))) + (let* ((type (slot-definition-type slotd)) + (pname (slot-definition-pname slotd)) + (reader (reader-function type :ref :get))) + #'(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+))))) + +(defmethod compute-slot-writer-function :around ((slotd effective-property-slot-definition)) + (if (construct-only-property-p slotd) + #'(lambda (value object) + (declare (ignore value)) + (unless *ignore-setting-construct-only-property* + (error 'unwritable-slot :name (slot-definition-name slotd) :instance object))) (call-next-method))) (defmethod compute-slot-writer-function ((slotd effective-property-slot-definition)) - (cond - ((slot-writable-p slotd) - (let* ((type (slot-definition-type slotd)) - (pname (slot-definition-pname slotd)) - (writer (writer-function type :temp t)) - (destroy (destroy-function type :temp t))) - #'(lambda (value object) - (with-memory (gvalue +gvalue-size+) - (%gvalue-init gvalue (find-type-number type)) - (funcall writer value gvalue +gvalue-value-offset+) - (%object-set-property object pname gvalue) - (funcall destroy gvalue +gvalue-value-offset+)) - value))) - - ((construct-only-property-p slotd) + (let* ((type (slot-definition-type slotd)) + (pname (slot-definition-pname slotd)) + (writer (writer-function type :temp t)) + (destroy (destroy-function type :temp t))) #'(lambda (value object) - (declare (ignore value object)) - (unless *ignore-setting-construct-only-property* - (error 'unwritable-slot :name (slot-definition-name slotd) :instance object)))) - ((call-next-method)))) + (with-memory (gvalue +gvalue-size+) + (%gvalue-init gvalue (find-type-number type)) + (funcall writer value gvalue +gvalue-value-offset+) + (%object-set-property object pname gvalue) + (funcall destroy gvalue +gvalue-value-offset+)) + value))) + +(defmethod slot-readable-p ((slotd effective-user-data-slot-definition)) + (declare (ignore slotd)) + t) (defmethod compute-slot-reader-function ((slotd effective-user-data-slot-definition) &optional signal-unbound-p) (declare (ignore signal-unbound-p)) @@ -195,6 +187,10 @@ (defmethod compute-slot-boundp-function ((slotd effective-user-data-slot-definit #'(lambda (object) (user-data-p object slot-name)))) +(defmethod slot-writable-p ((slotd effective-user-data-slot-definition)) + (declare (ignore slotd)) + t) + (defmethod compute-slot-writer-function ((slotd effective-user-data-slot-definition)) (let ((slot-name (slot-definition-name slotd))) #'(lambda (value object) @@ -275,6 +271,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 ())) @@ -300,18 +300,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) @@ -319,10 +318,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)))))) @@ -395,35 +394,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))))