- (type-number (find-type-number type)))
- (unless (slot-boundp slotd 'reader-function)
- (setf
- (slot-value slotd 'reader-function)
- (if (slot-readable-p slotd)
- (let () ;(reader (reader-function (type-from-number type-number))))
- #'(lambda (object)
- (let ((gvalue (gvalue-new type-number)))
- (%object-get-property object pname gvalue)
- (unwind-protect
- (funcall #|reader|# (reader-function (type-from-number type-number)) gvalue +gvalue-value-offset+)
- (gvalue-free gvalue t)))))
- #'(lambda (value object)
- (error "Slot is not readable: ~A" (slot-definition-name slotd))))))
-
- (unless (slot-boundp slotd 'writer-function)
- (setf
- (slot-value slotd 'writer-function)
- (if (slot-writable-p slotd)
- (let ();; (writer (writer-function (type-from-number type-number)))
-;; (destroy (destroy-function (type-from-number type-number))))
- #'(lambda (value object)
- (let ((gvalue (gvalue-new type-number)))
- (funcall #|writer|# (writer-function (type-from-number type-number)) value gvalue +gvalue-value-offset+)
- (%object-set-property object pname gvalue)
-; (funcall #|destroy|#(destroy-function (type-from-number type-number)) gvalue +gvalue-value-offset+)
- (gvalue-free gvalue t)
- value)))
- #'(lambda (value object)
- (error "Slot is not writable: ~A" (slot-definition-name slotd))))))
-
- (unless (slot-boundp slotd 'boundp-function)
- (setf
- (slot-value slotd 'boundp-function)
- #'(lambda (object)
- (declare (ignore object))
- t))))
- (call-next-method))
+ (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)
+ (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))
+ (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))
+ (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)))
+
+(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))
+ (let ((slot-name (slot-definition-name slotd)))
+ #'(lambda (object)
+ (user-data object slot-name))))
+
+(defmethod compute-slot-boundp-function ((slotd effective-user-data-slot-definition))
+ (let ((slot-name (slot-definition-name slotd)))
+ #'(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)
+ (setf (user-data object slot-name) value))))
+
+(defmethod compute-slot-makunbound-function ((slotd effective-user-data-slot-definition))
+ (let ((slot-name (slot-definition-name slotd)))
+ #'(lambda (object)
+ (unset-user-data object slot-name))))
+
+(defmethod compute-slots :around ((class gobject-class))
+ (let ((slots (call-next-method)))
+ (when (some #'(lambda (slotd)
+ (and
+ (eq (slot-definition-allocation slotd) :instance)
+ (not (typep slotd 'effective-special-slot-definition))))
+ slots)
+ (setf (slot-value class 'instance-slots-p) t))
+ slots))