X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.foreign-gobject-subclassing.lisp;h=b197b5faa48e7c0c49bab0c2b591fae86af2555b;hb=8db173e3df82074b8ca96d00304c4e63b499f598;hp=0e921e883a2551c7cd7424162f0c8fcbbd250255;hpb=af90ac5cff9dbb5f44677cc4726eee60ab88bc5d;p=cl-gtk2.git diff --git a/glib/gobject.foreign-gobject-subclassing.lisp b/glib/gobject.foreign-gobject-subclassing.lisp index 0e921e8..b197b5f 100644 --- a/glib/gobject.foreign-gobject-subclassing.lisp +++ b/glib/gobject.foreign-gobject-subclassing.lisp @@ -14,13 +14,13 @@ (setf (gethash (pointer-address object) *lisp-objects-references*) (gethash (pointer-address object) *foreign-gobjects*)))) (defun instance-init (instance class) - (debugf "Initializing instance ~A for type ~A (creating ~A)~%" instance (g-type-name (foreign-slot-value class 'g-type-class 'type)) *current-creating-object*) + (debugf "Initializing instance ~A for type ~A (creating ~A)~%" instance (g-type-name (foreign-slot-value class 'g-type-class :type)) *current-creating-object*) (unless (gethash (pointer-address instance) *lisp-objects-pointers*) (debugf " Proceeding with initialization...") (setf (gethash (pointer-address instance) *lisp-objects-pointers*) t (gethash (pointer-address instance) *lisp-objects-references*) (or *current-creating-object* - (let* ((g-type (foreign-slot-value class 'g-type-class 'type)) + (let* ((g-type (foreign-slot-value class 'g-type-class :type)) (type-name (g-type-name g-type)) (lisp-type-info (gethash type-name *registered-types*)) (lisp-class (object-type-class lisp-type-info))) @@ -72,13 +72,13 @@ (+g-type-string+ (g-param-spec-string property-name property-name property-name "" flags)) (+g-type-pointer+ (g-param-spec-pointer property-name property-name property-name flags)) (+g-type-boxed+ (g-param-spec-boxed property-name property-name property-name property-g-type flags)) - ;(+g-type-param+ (parse-gvalue-param gvalue)) + ;(+g-type-param+ (parse-g-value-param gvalue)) (+g-type-object+ (g-param-spec-object property-name property-name property-name property-g-type flags)) ;(+g-type-interface+ ) (t (error "Unknown type: ~A (~A)" property-g-type (g-type-name property-g-type))))))) (defun install-properties (class) - (let* ((name (g-type-name (foreign-slot-value class 'g-type-class 'type))) + (let* ((name (g-type-name (foreign-slot-value class 'g-type-class :type))) (lisp-type-info (gethash name *registered-types*))) (iter (for property in (object-type-properties lisp-type-info)) (for param-spec = (property->param-spec property)) @@ -117,7 +117,7 @@ (make-vtable-description :type-name ,type-name :cstruct-name ',cstruct-name :methods (list ,@(mapcar #'make-load-form (vtable-methods items))))) ,@(iter (for method in (vtable-methods items)) (collect `(defgeneric ,(vtable-method-info-name method) (,@(mapcar #'first (vtable-method-info-args method))))) - (collect `(defcallback ,(vtable-method-info-callback-name method) ,(vtable-method-info-return-type method) + (collect `(glib-defcallback ,(vtable-method-info-callback-name method) ,(vtable-method-info-return-type method) (,@(vtable-method-info-args method)) (restart-case (,(vtable-method-info-name method) ,@(mapcar #'first (vtable-method-info-args method))) @@ -125,6 +125,7 @@ (defun interface-init (iface data) (destructuring-bind (class-name interface-name) (prog1 (get-stable-pointer-value data) (free-stable-pointer data)) + (declare (ignorable class-name)) (let* ((vtable (gethash interface-name *vtables*)) (vtable-cstruct (vtable-description-cstruct-name vtable))) (debugf "interface-init for class ~A and interface ~A~%" class-name interface-name) @@ -138,8 +139,8 @@ (let* ((interface-info (list name interface)) (interface-info-ptr (allocate-stable-pointer interface-info))) (with-foreign-object (info 'g-interface-info) - (setf (foreign-slot-value info 'g-interface-info 'interface-init) (callback c-interface-init) - (foreign-slot-value info 'g-interface-info 'interface-data) interface-info-ptr) + (setf (foreign-slot-value info 'g-interface-info :interface-init) (callback c-interface-init) + (foreign-slot-value info 'g-interface-info :interface-data) interface-info-ptr) (g-type-add-interface-static (g-type-from-name name) (ensure-g-type interface) info)))) (defun add-interfaces (name) @@ -151,9 +152,9 @@ (defun class-init (class data) (declare (ignore data)) (debugf "class-init for ~A~%" (g-type-name (g-type-from-class class))) - (setf (foreign-slot-value class 'g-object-class 'get-property) + (setf (foreign-slot-value class 'g-object-class :get-property) (callback c-object-property-get) - (foreign-slot-value class 'g-object-class 'set-property) + (foreign-slot-value class 'g-object-class :set-property) (callback c-object-property-set)) (install-properties class)) @@ -161,9 +162,9 @@ (defun object-property-get (object property-id g-value pspec) (declare (ignore property-id)) (let* ((lisp-object (gethash (pointer-address object) *lisp-objects-references*)) - (property-name (foreign-slot-value pspec 'g-param-spec 'name)) - (property-type (foreign-slot-value pspec 'g-param-spec 'value-type)) - (type-name (g-type-name (foreign-slot-value pspec 'g-param-spec 'owner-type))) + (property-name (foreign-slot-value pspec 'g-param-spec :name)) + (property-type (foreign-slot-value pspec 'g-param-spec :value-type)) + (type-name (g-type-name (foreign-slot-value pspec 'g-param-spec :owner-type))) (lisp-type-info (gethash type-name *registered-types*)) (property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first)) (property-get-fn (fourth property-info))) @@ -179,12 +180,12 @@ (defun object-property-set (object property-id value pspec) (declare (ignore property-id)) (let* ((lisp-object (gethash (pointer-address object) *lisp-objects-references*)) - (property-name (foreign-slot-value pspec 'g-param-spec 'name)) - (type-name (g-type-name (foreign-slot-value pspec 'g-param-spec 'owner-type))) + (property-name (foreign-slot-value pspec 'g-param-spec :name)) + (type-name (g-type-name (foreign-slot-value pspec 'g-param-spec :owner-type))) (lisp-type-info (gethash type-name *registered-types*)) (property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first)) (property-set-fn (fifth property-info)) - (new-value (parse-gvalue value))) + (new-value (parse-g-value value))) (debugf "set(~A,'~A',~A)~%" lisp-object property-name new-value) (restart-case (funcall property-set-fn new-value lisp-object) @@ -198,12 +199,16 @@ (setf parent (g-type-name (ensure-g-type parent)))) `(progn (setf (gethash ,name *registered-types*) (make-object-type :name ,name :class ',class :parent ,parent :interfaces ',interfaces :properties ',properties)) - (at-init + (at-init (',class) (debugf "Registering GObject type implementation ~A for type ~A~%" ',class ,name) (with-foreign-object (query 'g-type-query) (g-type-query (g-type-from-name ,parent) query) - (with-foreign-slots ((class-size instance-size) query g-type-query) - (g-type-register-static-simple (g-type-from-name ,parent) ,name class-size (callback c-class-init) instance-size (callback c-instance-init) nil))) + (g-type-register-static-simple (g-type-from-name ,parent) + ,name + (foreign-slot-value query 'g-type-query :class-size) + (callback c-class-init) + (foreign-slot-value query 'g-type-query :instance-size) + (callback c-instance-init) nil)) (add-interfaces ,name)) (defmethod initialize-instance :before ((object ,class) &key pointer) (unless (or pointer (and (slot-boundp object 'gobject::pointer)