X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.foreign-gobject.lisp;h=50ba2ff04581edc40e8607393023dda9b03b24e7;hb=b8b6be84993178319789e864ae1d9f9f65c8e4c7;hp=0ea990a38ecaf0dc4782a8c8c0a434dd17aaebab;hpb=c96bf0edca9130595781245497e4ed8deaefb378;p=cl-gtk2.git diff --git a/glib/gobject.foreign-gobject.lisp b/glib/gobject.foreign-gobject.lisp index 0ea990a..50ba2ff 100644 --- a/glib/gobject.foreign-gobject.lisp +++ b/glib/gobject.foreign-gobject.lisp @@ -9,20 +9,17 @@ (has-reference :type boolean :accessor g-object-has-reference - :initform nil))) + :initform nil)) + (:documentation + "Base class for GObject classes hierarchy.")) (defvar *foreign-gobjects* (make-weak-hash-table :test 'equal :weakness :value)) (defvar *foreign-gobjects-ref-count* (make-hash-table :test 'equal)) (defvar *lisp-objects-pointers* (make-hash-table :test 'equal)) (defvar *current-creating-object* nil) -(defcstruct g-object-struct - (type-instance g-type-instance) - (ref-count :uint) - (qdata :pointer)) - (defun ref-count (pointer) - (foreign-slot-value (if (pointerp pointer) pointer (pointer pointer)) 'g-object-struct 'ref-count)) + (foreign-slot-value (if (pointerp pointer) pointer (pointer pointer)) 'g-object-struct :ref-count)) (defmethod initialize-instance :around ((obj g-object) &key) (let ((*current-creating-object* obj)) @@ -115,9 +112,10 @@ (gethash (pointer-address pointer) *foreign-gobjects*) (gethash (pointer-address pointer) *foreign-gobjects-ref-count*) (ref-count pointer)) - (awhen (gethash (pointer-address pointer) *foreign-gobjects*) - (setf (pointer it) nil) - (cancel-finalization it)) + (let ((object (gethash (pointer-address pointer) *foreign-gobjects*))) + (when object + (setf (pointer object) nil) + (cancel-finalization object))) (remhash (pointer-address pointer) *foreign-gobjects*) (remhash (pointer-address pointer) *foreign-gobjects-ref-count*) (g-object-unref pointer)) @@ -137,11 +135,12 @@ (defun registered-object-type-by-name (name) (gethash name *registered-object-types*)) (defun get-g-object-lisp-type (g-type) + (setf g-type (ensure-g-type g-type)) (loop while (not (zerop g-type)) for lisp-type = (gethash (g-type-name g-type) *registered-object-types*) when lisp-type do (return lisp-type) - do (setf g-type (g-type-parent g-type)))) + do (setf g-type (ensure-g-type (g-type-parent g-type))))) (defun make-g-object-from-pointer (pointer) (let* ((g-type (g-type-from-instance pointer)) @@ -163,6 +162,7 @@ (cond ((null object) (null-pointer)) + ((pointerp object) object) ((null (pointer object)) (error "Object ~A has been disposed" object)) ((typep object 'g-object) @@ -170,16 +170,16 @@ nil "Object ~A is not a subtype of ~A" object (sub-type type)) (pointer object)) - ((pointerp object) object) (t (error "Object ~A is not translatable as GObject*" object)))) (defun get-g-object-for-pointer (pointer) (unless (null-pointer-p pointer) - (aif (gethash (pointer-address pointer) *foreign-gobjects*) - (prog1 it - (incf (gethash (pointer-address pointer) *foreign-gobjects-ref-count*)) - (debugf "increfering object ~A~%" pointer)) - (make-g-object-from-pointer pointer)))) + (let ((object (gethash (pointer-address pointer) *foreign-gobjects*))) + (if object + (prog1 object + (incf (gethash (pointer-address pointer) *foreign-gobjects-ref-count*)) + (debugf "increfering object ~A~%" pointer)) + (make-g-object-from-pointer pointer))))) (defmethod translate-from-foreign (pointer (type foreign-g-object-type)) (get-g-object-for-pointer pointer)) @@ -187,6 +187,9 @@ (register-object-type "GObject" 'g-object) (defun ensure-g-type (type) + "Returns the GType value for a given type. If type is an integer, it is returned. If type is a string, GType corresponding to this type name is looked up and returned. +@arg[type]{a string or and integer} +@return{integer equal to GType of @code{type}}" (etypecase type (integer type) (string (or (g-type-from-name type) @@ -198,6 +201,24 @@ (etypecase object (g-object (pointer object))))) +(define-condition property-access-error (error) + ((property-name :initarg :property-name :reader property-access-error-property-name) + (class-name :initarg :class-name :reader property-access-error-class-name) + (message :initarg :message :reader property-access-error-message)) + (:report (lambda (condition stream) + (format stream "Error accessing property '~A' on class '~A': ~A" + (property-access-error-property-name condition) + (property-access-error-class-name condition) + (property-access-error-message condition))))) + +(define-condition property-unreadable-error (property-access-error) + () + (:default-initargs :message "property is not readable")) + +(define-condition property-unwritable-error (property-access-error) + () + (:default-initargs :message "property is not writable")) + (defun g-param-spec-property-type (param-spec property-name object-type assert-readable assert-writable) (when (null-pointer-p param-spec) (error "Property ~A on type ~A is not found" @@ -207,19 +228,19 @@ (not (member :readable (foreign-slot-value param-spec 'g-param-spec - 'flags)))) - (error "Property ~A on type ~A is not readable" - property-name - (g-type-name object-type))) + :flags)))) + (error 'property-unreadable-error + :property-name property-name + :class-name (g-type-name object-type))) (when (and assert-writable (not (member :writable (foreign-slot-value param-spec 'g-param-spec - 'flags)))) - (error "Property ~A on type ~A is not writable" - property-name - (g-type-name object-type))) - (foreign-slot-value param-spec 'g-param-spec 'value-type)) + :flags)))) + (error 'property-unwritable-error + :property-name property-name + :class-name (g-type-name object-type))) + (foreign-slot-value param-spec 'g-param-spec :value-type)) (defun g-object-type-property-type (object-type property-name &key assert-readable assert-writable) @@ -238,7 +259,6 @@ (defun g-object-call-constructor (object-type args-names args-values &optional args-types) - (setf object-type (ensure-g-type object-type)) (unless args-types (setf args-types (mapcar (lambda (name) @@ -251,10 +271,10 @@ for arg-name in args-names for arg-value in args-values for arg-type in args-types - for arg-g-type = (ensure-g-type arg-type) + for arg-g-type = (if arg-type (ensure-g-type arg-type) (g-object-type-property-type object-type arg-name)) for parameter = (mem-aref parameters 'g-parameter i) - do (setf (foreign-slot-value parameter 'g-parameter 'name) arg-name) - do (set-g-value (foreign-slot-value parameter 'g-parameter 'value) + do (setf (foreign-slot-value parameter 'g-parameter :name) arg-name) + do (set-g-value (foreign-slot-value parameter 'g-parameter :value) arg-value arg-g-type :zero-g-value t)) (unwind-protect @@ -262,16 +282,15 @@ (loop for i from 0 below args-count for parameter = (mem-aref parameters 'g-parameter i) - do (foreign-free - (mem-ref (foreign-slot-pointer parameter 'g-parameter 'name) - :pointer)) - do (g-value-unset - (foreign-slot-pointer parameter 'g-parameter 'value))))))) + do (foreign-free (mem-ref (foreign-slot-pointer parameter 'g-parameter :name) :pointer)) + do (g-value-unset (foreign-slot-pointer parameter 'g-parameter :value))))))) (defun g-object-call-get-property (object property-name &optional property-type) - (unless property-type - (setf property-type - (g-object-property-type object property-name :assert-readable t))) + (restart-case + (unless property-type + (setf property-type + (g-object-property-type object property-name :assert-readable t))) + (return-nil () (return-from g-object-call-get-property nil))) (setf property-type (ensure-g-type property-type)) (with-foreign-object (value 'g-value) (g-value-zero value)