-
-;;;; Metaclass used for subclasses of gobject
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass gobject-class (ginstance-class)
- ())
-
- (defclass direct-gobject-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)))
-
- (defclass effective-gobject-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))))
-
-
-
-; (defbinding object-class-install-param () nil
-; (class pointer)
-; (id unsigned-int)
-; (parameter parameter))
-
-; (defbinding object-class-find-param-spec () parameter
-; (class pointer)
-; (name string))
-
-(defun signal-name-to-string (name)
- (substitute #\_ #\- (string-downcase (string name))))
-
-
-(defmethod direct-slot-definition-class ((class gobject-class) &rest initargs)
- (case (getf initargs :allocation)
- (:property (find-class 'direct-gobject-slot-definition))
- (t (call-next-method))))
-
-(defmethod effective-slot-definition-class ((class gobject-class) &rest initargs)
- (case (getf initargs :allocation)
- (:property (find-class 'effective-gobject-slot-definition))
- (t (call-next-method))))
-
-(defmethod compute-effective-slot-definition-initargs ((class gobject-class) direct-slotds)
- (if (eq (most-specific-slot-value direct-slotds 'allocation) :property)
- (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))
- (call-next-method))
- (call-next-method)))
-
-
-(defmethod initialize-internal-slot-functions ((slotd effective-gobject-slot-definition))
- (let* ((type (slot-definition-type slotd))
- (pname (slot-definition-pname slotd))
- (type-number (find-type-number type)))
- (unless (slot-boundp slotd 'reader-function)
- (setf
- (slot-value slotd 'reader-function)
- (if (slot-readable-p slotd)
- #'(lambda (object)
- (with-gc-disabled
- (let ((gvalue (gvalue-new type-number)))
- (%object-get-property object pname gvalue)
- (unwind-protect
- (funcall
- (intern-reader-function (type-from-number type-number)) gvalue +gvalue-value-offset+) ; temporary workaround for wrong topological sorting of types
- (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)
- #'(lambda (value object)
- (with-gc-disabled
- (let ((gvalue (gvalue-new type-number)))
- (funcall
- (intern-writer-function (type-from-number type-number)) ; temporary
- value gvalue +gvalue-value-offset+)
- (%object-set-property object pname gvalue)
- (funcall
- (intern-destroy-function (type-from-number type-number)) ; temporary
- gvalue +gvalue-value-offset+)
- (gvalue-free gvalue nil)
- 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))
-
-
-(defmethod validate-superclass ((class gobject-class)
- (super pcl::standard-class))
-; (subtypep (class-name super) 'gobject)
- t)
-
-
-