+ (find-type-number
+ (or (first alien-name) (default-alien-type-name class-name)) t)))
+ (register-type class-name type-number)
+ (if (getf initargs :size)
+ (call-next-method)
+ (let ((size (type-instance-size type-number)))
+ (apply #'call-next-method class names :size (list size) initargs)))))
+
+
+(defmethod validate-superclass ((class ginstance-class) (super standard-class))
+ (subtypep (class-name super) 'ginstance))
+
+
+;;;; Registering fundamental types
+
+(register-type 'pointer "gpointer")
+(register-type 'char "gchar")
+(register-type 'unsigned-char "guchar")
+(register-type 'boolean "gboolean")
+(register-type 'fixnum "gint")
+(register-type 'int "gint")
+(register-type 'unsigned-int "guint")
+(register-type 'long "glong")
+(register-type 'unsigned-long "gulong")
+(register-type 'single-float "gfloat")
+(register-type 'double-float "gdouble")
+(register-type 'pathname "gchararray")
+(register-type 'string "gchararray")
+
+
+;;;;
+
+(defvar *derivable-type-info* (make-hash-table))
+
+(defun register-derivable-type (type id expander)
+ (register-type type id)
+ (let ((type-number (register-type type id)))
+ (setf (gethash type-number *derivable-type-info*) expander)))
+
+(defun find-type-info (type)
+ (dolist (super (cdr (type-hierarchy type)))
+ (let ((info (gethash super *derivable-type-info*)))
+ (return-if info))))
+
+(defun expand-type-definition (type options)
+ (let ((expander (find-type-info type)))
+ (funcall expander (find-type-number type t) options)))
+
+(defbinding type-parent (type) type-number
+ ((find-type-number type t) type-number))
+
+(defun supertype (type)
+ (type-from-number (type-parent type)))
+
+(defbinding %type-interfaces (type) pointer
+ ((find-type-number type t) type-number)
+ (n-interfaces unsigned-int :out))
+
+(defun type-interfaces (type)
+ (multiple-value-bind (array length) (%type-interfaces type)
+ (unwind-protect
+ (map-c-vector 'list #'identity array 'type-number length)
+ (deallocate-memory array))))
+
+(defun implements (type)
+ (mapcar #'type-from-number (type-interfaces type)))
+
+(defun type-hierarchy (type)
+ (let ((type-number (find-type-number type t)))
+ (unless (= type-number 0)
+ (cons type-number (type-hierarchy (type-parent type-number))))))
+
+(defbinding (type-is-p "g_type_is_a") (type super) boolean
+ ((find-type-number type) type-number)
+ ((find-type-number super) type-number))
+
+(defbinding %type-children () pointer
+ (type-number type-number)
+ (num-children unsigned-int :out))
+
+(defun map-subtypes (function type &optional prefix)
+ (let ((type-number (find-type-number type t)))
+ (multiple-value-bind (array length) (%type-children type-number)
+ (unwind-protect
+ (map-c-vector
+ 'nil
+ #'(lambda (type-number)
+ (when (or
+ (not prefix)
+ (string-prefix-p prefix (find-type-name type-number)))
+ (funcall function type-number))
+ (map-subtypes function type-number prefix))
+ array 'type-number length)
+ (deallocate-memory array)))))
+
+(defun find-types (prefix)
+ (let ((type-list nil))
+ (maphash
+ #'(lambda (type-number expander)
+ (declare (ignore expander))
+ (map-subtypes
+ #'(lambda (type-number)
+ (pushnew type-number type-list))
+ type-number prefix))
+ *derivable-type-info*)
+ type-list))
+
+(defun %sort-types-topologicaly (unsorted)
+ (let ((sorted ()))
+ (loop while unsorted do
+ (dolist (type unsorted)
+ (let ((dependencies
+ (append (rest (type-hierarchy type)) (type-interfaces type))))