+(defclass container-child ()
+ ((parent :initarg :parent :type container)
+ (child :initarg :child :type widget)))
+
+
+;;;;
+
+(defbinding %container-query-child-args () arg
+ (type-number type-number)
+ (nil null)
+ (n-args unsigned-int :out))
+
+(defun query-container-type-dependencies (type-number)
+ (let ((child-slot-types ()))
+ (multiple-value-bind (args n-args)
+ (%container-query-child-args type-number)
+ (dotimes (i n-args)
+ (push (arg-type (arg-array-ref args i)) child-slot-types)))
+ (delete-duplicates
+ (append (query-object-type-dependencies type-number) child-slot-types))))
+
+(defun default-container-child-name (container-class)
+ (intern (format nil "~A-CHILD" container-class)))
+
+(defun expand-container-type (type-number &optional slots)
+ (let* ((class (type-from-number type-number))
+ (super (supertype type-number))
+ (child-class (default-container-child-name class))
+ (child-slots ()))
+ (multiple-value-bind (args n-args)
+ (%container-query-child-args type-number)
+ (dotimes (i n-args)
+ (let* ((arg (arg-array-ref args i))
+ (arg-name (arg-name arg))
+ (slot-name (default-slot-name
+ (subseq arg-name (+ (position #\: arg-name) 2))))
+ (type (type-from-number (arg-type arg) #|t|#)))
+ (push
+ `(,slot-name
+ :allocation :arg
+ :arg-name ,arg-name
+ :accessor ,(default-slot-accessor child-class slot-name type)
+ :initarg ,(intern (string slot-name) "KEYWORD")
+ :type ,type)
+ child-slots)))
+ `(progn
+ ,(expand-gobject-type type-number slots)
+ (defclass ,child-class
+ (,(default-container-child-name super))
+ ,child-slots
+ (:metaclass child-class)
+ (:container ,class))))))
+
+(register-derivable-type
+ 'container "GtkContainer"
+ :query 'query-container-type-dependencies
+ :expand 'expand-container-type)