+;;;; 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 'string "gchararray")
+
+
+;;;;
+
+(defvar *derivable-type-info* ())
+
+(defun register-derivable-type (type id &key query expand)
+ (register-type type id)
+ (let* ((type-number (register-type type id))
+ (info (assoc type-number *derivable-type-info*)))
+ (if info
+ (setf (cdr info) (list query expand))
+ (push
+ (list type-number query expand)
+ *derivable-type-info*))))
+
+(defun find-type-info (type)
+ (dolist (super (cdr (type-hierarchy type)))
+ (let ((info (assoc super *derivable-type-info*)))
+ (return-if info))))
+
+(defun type-dependencies (type)
+ (let ((query (second (find-type-info type))))
+ (when query
+ (funcall query (find-type-number type t)))))
+
+(defun expand-type-definition (type)
+ (let ((expander (third (find-type-info type))))
+ (funcall expander (find-type-number type t))))
+
+(defbinding type-parent (type) type-number
+ ((find-type-number type t) type-number))
+
+(defun supertype (type)
+ (type-from-number (type-parent 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-array
+ '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))
+ (dolist (type-info *derivable-type-info*)
+ (map-subtypes
+ #'(lambda (type-number)
+ (pushnew type-number type-list))
+ (first type-info) prefix))
+ type-list))
+
+(defun %sort-types-topologicaly (unsorted)
+ (let ((sorted ()))
+ (loop while unsorted do
+ (dolist (type unsorted)
+ (let ((dependencies (type-dependencies type)))
+ (cond
+ ((null dependencies)
+ (push type sorted)
+ (setq unsorted (delete type unsorted)))
+ (t
+ (unless (dolist (dep dependencies)
+ (when (find type (type-dependencies dep))
+ (error "Cyclic type dependencies not yet supported"))
+ (return-if (find dep unsorted)))
+ (push type sorted)
+ (setq unsorted (delete type unsorted))))))))
+ (nreverse sorted)))
+
+
+(defun expand-type-definitions (prefix &optional args)
+ (flet ((type-options (type-number)
+ (let ((name (find-type-name type-number)))
+ (cdr (assoc name args :test #'string=)))))
+
+ (let ((type-list
+ (delete-if
+ #'(lambda (type-number)
+ (let ((name (find-type-name type-number)))
+ (or
+ (getf (type-options type-number) :ignore)
+ (find-if
+ #'(lambda (options)
+ (and
+ (string-prefix-p (first options) name)
+ (getf (cdr options) :ignore-prefix)))
+ args))))
+ (find-types prefix))))
+
+ (dolist (type-number type-list)
+ (let ((name (find-type-name type-number)))
+ (register-type
+ (getf (type-options type-number) :type (default-type-name name))
+ type-number)))
+
+ `(progn
+ ,@(mapcar
+ #'expand-type-definition
+ (%sort-types-topologicaly type-list))))))
+
+(defmacro define-types-by-introspection (prefix &rest args)
+ (expand-type-definitions prefix args))