From 2ef2ba47e1176d67f2d49308329c8d5db59b7c77 Mon Sep 17 00:00:00 2001 From: Dmitry Kalyanov Date: Wed, 17 Jun 2009 11:05:29 +0400 Subject: [PATCH] glib/gobject.meta: remove slot initargs before call-next-method in make-instance If slot initargs are not removed then shared-initialize will try to set corresponding slots' values. For constructor-only properties this will throw warnings, and for other properties this will set them two times (e.g., redundantly). Initargs are only removed from make-instance's primary method. :before, :after and :around methods for initialize-instance will receive full arguments list. --- glib/gobject.meta.lisp | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/glib/gobject.meta.lisp b/glib/gobject.meta.lisp index 7f42613..e95aa55 100644 --- a/glib/gobject.meta.lisp +++ b/glib/gobject.meta.lisp @@ -150,12 +150,12 @@ (defun create-gobject-from-class-and-initargs (class initargs) (when (gobject-class-interface-p class) (error "Trying to create instance of GInterface '~A' (class '~A')" (gobject-class-g-type-name class) (class-name class))) - (let (arg-names arg-values arg-types nc-setters nc-arg-values) + (let (arg-names arg-values arg-types nc-setters nc-arg-values rest-initargs) (declare (dynamic-extent arg-names arg-values arg-types nc-setters nc-arg-values)) (loop for (arg-name arg-value) on initargs by #'cddr for slot = (find arg-name (class-slots class) :key 'slot-definition-initargs :test 'member) - when (and slot (typep slot 'gobject-effective-slot-definition)) + if (and slot (typep slot 'gobject-effective-slot-definition)) do (typecase slot (gobject-property-effective-slot-definition (push (gobject-property-effective-slot-definition-g-property-name slot) arg-names) @@ -163,7 +163,8 @@ (push (gobject-effective-slot-definition-g-property-type slot) arg-types)) (gobject-fn-effective-slot-definition (push (gobject-fn-effective-slot-definition-g-setter-fn slot) nc-setters) - (push arg-value nc-arg-values)))) + (push arg-value nc-arg-values))) + else do (setf rest-initargs (nconc rest-initargs (list arg-name arg-value)))) (let ((object (g-object-call-constructor (gobject-class-g-type-name class) arg-names arg-values arg-types))) (loop for fn in nc-setters @@ -176,8 +177,10 @@ (progn (assert (= (length initargs) 2) nil "POINTER can not be combined with other initargs (~A)" initargs) (call-next-method)) - (let ((pointer (create-gobject-from-class-and-initargs class initargs))) - (apply #'call-next-method class :pointer pointer initargs)))) + (multiple-value-bind (pointer rest-initargs) + (create-gobject-from-class-and-initargs class initargs) + (declare (dynamic-extent rest-initargs)) + (apply #'call-next-method class :pointer pointer rest-initargs)))) (defmethod slot-boundp-using-class ((class gobject-class) object (slot gobject-property-effective-slot-definition)) (handler-case -- 1.7.10.4