+;;;; 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 "GString")
+
+
+;;;;
+
+(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 type-dependencies (type)
+ (let ((query (second (assoc (car (last (type-hierarchy type)))
+ *derivable-type-info*))))
+ (when query
+ (funcall query (find-type-number type t)))))
+
+(defun expand-type-definition (type)
+ (let ((expander (third (assoc (car (last (type-hierarchy type)))
+ *derivable-type-info*))))
+ (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)
+ (push 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 argss :test #'string=)))))
+
+ (let ((type-list
+ (delete-if
+ #'(lambda (type-number)
+ (getf (type-options type-number) :ignore nil))
+ (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)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ ,(expand-type-definitions prefix args)))
\ No newline at end of file