;; 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.52 2006-04-25 22:10:36 espen Exp $
+;; $Id: gobject.lisp,v 1.59 2008-11-04 03:22:23 espen Exp $
(in-package "GLIB")
(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)
())
-(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))
(defvar *ignore-setting-construct-only-property* nil)
(declaim (special *ignore-setting-construct-only-property*))
-(defmethod compute-slot-reader-function ((slotd effective-property-slot-definition))
- (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+))))
+(defmethod compute-slot-reader-function ((slotd effective-property-slot-definition) &optional signal-unbound-p)
+ (declare (ignore signal-unbound-p))
+ (let* ((type (slot-definition-type slotd))
+ (pname (slot-definition-pname slotd))
+ (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))
- (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))
+(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))))
#'(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)
(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 ()))
(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)
(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))))))
(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))
(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 ()
(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
;;;; 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))))
(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))
~mdw / clg / blobdiff