[clg] / glib / gtype.lisp

;; Common Lisp bindings for GTK+ v2.0
;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

;; $Id: gtype.lisp,v 1.21 2004/11/19 13:02:51 espen Exp $

(in-package "GLIB")

(use-prefix "g")

;; Initialize the glib type system
(defbinding type-init () nil)
(type-init)

(deftype type-number () '(unsigned 32))

(deftype gtype () 'symbol)

(defmethod alien-type ((type (eql 'gtype)) &rest args)
  (declare (ignore type args))
  (alien-type 'type-number))

(defmethod size-of ((type (eql 'gtype)) &rest args)
  (declare (ignore type args))
  (size-of 'type-number))

(defmethod to-alien-form (gtype (type (eql 'gtype)) &rest args)
  (declare (ignore type args))
  `(find-type-number ,gtype t)) 

(defmethod to-alien-function ((type (eql 'gtype)) &rest args)
  (declare (ignore type args))
  #'(lambda (gtype)
      (find-type-number gtype t)))

(defmethod from-alien-form (type-number (type (eql 'gtype)) &rest args)
  (declare (ignore type args))
  `(type-from-number ,type-number t)) 

(defmethod from-alien-function ((type (eql 'gtype)) &rest args)
  (declare (ignore type args))
  #'(lambda (type-number)
      (type-from-number type-number t)))

(defmethod writer-function ((type (eql 'gtype)) &rest args)
  (declare (ignore type))
  (let ((writer (writer-function 'type-number)))
    #'(lambda (gtype location &optional (offset 0))
	(funcall writer (find-type-number gtype t) location offset))))

(defmethod reader-function ((type (eql 'gtype)) &rest args)
  (declare (ignore type))
  (let ((reader (reader-function 'type-number)))
    #'(lambda (location &optional (offset 0))
	(type-from-number (funcall reader location offset) t))))


(eval-when (:compile-toplevel :load-toplevel :execute)
  (defclass type-query (struct)
    ((type-number :allocation :alien :type type-number)
     (name :allocation :alien :type string)
     (class-size :allocation :alien :type unsigned-int)
     (instance-size :allocation :alien :type unsigned-int))
    (:metaclass struct-class)))


(defbinding type-query (type) nil
  ((find-type-number type t) type-number)
  ((make-instance 'type-query) type-query :return))

(defun type-instance-size (type)
  (slot-value (type-query type) 'instance-size))

(defun type-class-size (type)
  (slot-value (type-query type) 'class-size))

(defbinding type-class-ref (type) pointer
  ((find-type-number type t) type-number))

(defbinding type-class-unref (type) nil
  ((find-type-number type t) type-number))

(defbinding type-class-peek (type) pointer
  ((find-type-number type t) type-number))


;;;; Mapping between lisp types and glib types

(defvar *type-to-number-hash* (make-hash-table))
(defvar *number-to-type-hash* (make-hash-table))

(defun register-type (type id)
  (let ((type-number
	 (etypecase id
	   (integer id)
	   (string (find-type-number id t))
	   (symbol (gethash id *type-to-number-hash*)))))
    (setf (gethash type *type-to-number-hash*) type-number)
    (unless (symbolp id)
      (setf (gethash type-number *number-to-type-hash*) type))
    type-number))

(defbinding %type-from-name () type-number
  (name string))

(defun find-type-number (type &optional error)
  (etypecase type
    (integer type)
    (string
     (let ((type-number (%type-from-name type)))
       (cond
	((and (zerop type-number) error)
	 (error "Invalid gtype name: ~A" type))
	((zerop type-number) nil)
	(t type-number))))
    (symbol
     (let ((type-number (gethash type *type-to-number-hash*)))
       (or
	type-number
	(and error (error "Type not registered: ~A" type)))))
    (pcl::class (find-type-number (class-name type) error))))
 
(defun type-from-number (type-number &optional error)
  (multiple-value-bind (type found)
      (gethash type-number *number-to-type-hash*)
    (when (and error (not found))
      (let ((name (find-type-name type-number)))
	(if name
	    (error "Type number not registered: ~A (~A)" type-number name)
	  (error "Invalid type number: ~A" type-number))))
    type))

(defun type-from-name (name)
  (etypecase name
    (string (type-from-number (find-type-number name t)))))

(defbinding (find-type-name "g_type_name") (type) (copy-of string)
  ((find-type-number type t) type-number))

(defun type-number-of (object)
  (find-type-number (type-of object) t))

(defun init-type (init)
  (mapc
   #'(lambda (fname)
       (funcall (mkbinding fname 'type-number)))
   (mklist init)))

(defun %init-types-in-library (pathname prefix ignore)
  (let ((process (ext:run-program
		  "nm" (list "-D" (namestring (truename pathname)))
		  :output :stream :wait nil))
	(fnames ()))
    (labels ((read-symbols ()
	       (let ((line (read-line (ext:process-output process) nil)))
		 (when line
		   (let ((symbol (subseq line 11)))
		     (when (and
			    (> (length symbol) (length prefix))
			    (string= prefix symbol :end2 (length prefix))
			    (search "_get_type" symbol)
			    (not (member symbol ignore :test #'string=)))
		       (push symbol fnames)))
		   (read-symbols)))))
      (read-symbols)
      (ext:process-close process)
      `(init-type ',fnames))))

(defmacro init-types-in-library (filename &key (prefix "") ignore)
  (%init-types-in-library filename prefix ignore))


;;;; Superclass for wrapping types in the glib type system

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defclass ginstance (proxy)
    ((class :allocation :alien :type pointer))
    (:metaclass proxy-class)))

(defun %type-of-ginstance (location)
  (let ((class (sap-ref-sap location 0)))
    (type-from-number (sap-ref-32 class 0))))

(defmethod ensure-proxy-instance ((class ginstance-class) location)
  (declare (ignore class))
  (let ((class (find-class (%type-of-ginstance location))))
    (if class
	(make-instance class :location (reference-foreign class location))
      ;; TODO: (make-instance 'ginstance ...)
      location)))

(defmethod copy-from-alien-form (location (class ginstance-class) &rest args)
  (declare (ignore location class args))
  (error "Doing copy-from-alien on a ref. counted class is most certainly an error, but if it really is what you want you should use REFERENCE-FOREIGN on the returned instance instead."))

(defmethod copy-from-alien-function ((class ginstance-class) &rest args)
  (declare (ignore class args))  
  (error "Doing copy-from-alien on a ref. counted class is most certainly an error, but if it really is what you want you should use REFERENCE-FOREIGN on the returned instance instead."))

(defmethod reader-function ((class ginstance-class) &rest args)
  (declare (ignore args))
  #'(lambda (location &optional (offset 0))
      (ensure-proxy-instance class (sap-ref-sap location offset))))


;;;; Metaclass for subclasses of ginstance

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defclass ginstance-class (proxy-class)
    ()))


(defmethod shared-initialize ((class ginstance-class) names
			      &rest initargs &key name alien-name)
  (declare (ignore names))
  (let* ((class-name (or name (class-name class)))
	 (type-number
	  (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 '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))))
	  (cond
	   ((null dependencies)
	    (push type sorted)
	    (setq unsorted (delete type unsorted)))
	   (t
	    (unless (dolist (dep dependencies)
		      (when (find type (rest (type-hierarchy dep)))
			(error "Cyclic type dependencie"))
		      (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)
			(not (some
			      #'(lambda (exception)
				  (string= name exception))
			      (getf (cdr options) :except)))))
		   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
	   #'(lambda (type)
	       (expand-type-definition type (type-options type)))
	   (%sort-types-topologicaly type-list))))))

(defmacro define-types-by-introspection (prefix &rest args)
  (expand-type-definitions prefix args))
Commit	Line	Data
0d07716f	1	;; Common Lisp bindings for GTK+ v2.0
3a935dfa	2	;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
0d07716f	3	;;
	4	;; This library is free software; you can redistribute it and/or
	5	;; modify it under the terms of the GNU Lesser General Public
	6	;; License as published by the Free Software Foundation; either
	7	;; version 2 of the License, or (at your option) any later version.
	8	;;
	9	;; This library is distributed in the hope that it will be useful,
	10	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	11	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	12	;; Lesser General Public License for more details.
	13	;;
	14	;; You should have received a copy of the GNU Lesser General Public
	15	;; License along with this library; if not, write to the Free Software
	16	;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
	17
508d13a7	18	;; $Id: gtype.lisp,v 1.21 2004/11/19 13:02:51 espen Exp $
0d07716f	19
	20	(in-package "GLIB")
	21
	22	(use-prefix "g")
	23
d1266407	24	;; Initialize the glib type system
	25	(defbinding type-init () nil)
	26	(type-init)
0d07716f	27
	28	(deftype type-number () '(unsigned 32))
	29
b4a2c852	30	(deftype gtype () 'symbol)
	31
	32	(defmethod alien-type ((type (eql 'gtype)) &rest args)
	33	(declare (ignore type args))
	34	(alien-type 'type-number))
	35
	36	(defmethod size-of ((type (eql 'gtype)) &rest args)
	37	(declare (ignore type args))
	38	(size-of 'type-number))
	39
	40	(defmethod to-alien-form (gtype (type (eql 'gtype)) &rest args)
	41	(declare (ignore type args))
	42	`(find-type-number ,gtype t))
	43
	44	(defmethod to-alien-function ((type (eql 'gtype)) &rest args)
	45	(declare (ignore type args))
	46	#'(lambda (gtype)
	47	(find-type-number gtype t)))
	48
	49	(defmethod from-alien-form (type-number (type (eql 'gtype)) &rest args)
	50	(declare (ignore type args))
	51	`(type-from-number ,type-number t))
	52
	53	(defmethod from-alien-function ((type (eql 'gtype)) &rest args)
	54	(declare (ignore type args))
	55	#'(lambda (type-number)
	56	(type-from-number type-number t)))
	57
	58	(defmethod writer-function ((type (eql 'gtype)) &rest args)
	59	(declare (ignore type))
	60	(let ((writer (writer-function 'type-number)))
	61	#'(lambda (gtype location &optional (offset 0))
	62	(funcall writer (find-type-number gtype t) location offset))))
	63
	64	(defmethod reader-function ((type (eql 'gtype)) &rest args)
	65	(declare (ignore type))
	66	(let ((reader (reader-function 'type-number)))
	67	#'(lambda (location &optional (offset 0))
	68	(type-from-number (funcall reader location offset) t))))
	69
	70
fc47a022	71	(eval-when (:compile-toplevel :load-toplevel :execute)
3a935dfa	72	(defclass type-query (struct)
fc47a022	73	((type-number :allocation :alien :type type-number)
	74	(name :allocation :alien :type string)
	75	(class-size :allocation :alien :type unsigned-int)
	76	(instance-size :allocation :alien :type unsigned-int))
4d1d3921	77	(:metaclass struct-class)))
fc47a022	78
fc47a022	79
b4a2c852	80	(defbinding type-query (type) nil
	81	((find-type-number type t) type-number)
	82	((make-instance 'type-query) type-query :return))
fc47a022	83
	84	(defun type-instance-size (type)
	85	(slot-value (type-query type) 'instance-size))
	86
	87	(defun type-class-size (type)
	88	(slot-value (type-query type) 'class-size))
0d07716f	89
3a935dfa	90	(defbinding type-class-ref (type) pointer
3a935dfa	91	((find-type-number type t) type-number))
0d07716f	92
3a935dfa	93	(defbinding type-class-unref (type) nil
3a935dfa	94	((find-type-number type t) type-number))
fc47a022	95
3a935dfa	96	(defbinding type-class-peek (type) pointer
3a935dfa	97	((find-type-number type t) type-number))
fc47a022	98
0d07716f	99
3a935dfa	100	;;;; Mapping between lisp types and glib types
0d07716f	101
	102	(defvar type-to-number-hash (make-hash-table))
	103	(defvar number-to-type-hash (make-hash-table))
	104
3a935dfa	105	(defun register-type (type id)
	106	(let ((type-number
	107	(etypecase id
	108	(integer id)
935a783c	109	(string (find-type-number id t))
935a783c	110	(symbol (gethash id type-to-number-hash)))))
3a935dfa	111	(setf (gethash type type-to-number-hash) type-number)
935a783c	112	(unless (symbolp id)
935a783c	113	(setf (gethash type-number number-to-type-hash) type))
3a935dfa	114	type-number))
	115
	116	(defbinding %type-from-name () type-number
	117	(name string))
	118
	119	(defun find-type-number (type &optional error)
0d07716f	120	(etypecase type
0d07716f	121	(integer type)
3a935dfa	122	(string
	123	(let ((type-number (%type-from-name type)))
	124	(cond
	125	((and (zerop type-number) error)
4d1d3921	126	(error "Invalid gtype name: ~A" type))
3a935dfa	127	((zerop type-number) nil)
	128	(t type-number))))
	129	(symbol
	130	(let ((type-number (gethash type type-to-number-hash)))
	131	(or
	132	type-number
	133	(and error (error "Type not registered: ~A" type)))))
	134	(pcl::class (find-type-number (class-name type) error))))
0d07716f	135
b011356b	136	(defun type-from-number (type-number &optional error)
	137	(multiple-value-bind (type found)
	138	(gethash type-number number-to-type-hash)
	139	(when (and error (not found))
	140	(let ((name (find-type-name type-number)))
	141	(if name
	142	(error "Type number not registered: ~A (~A)" type-number name)
	143	(error "Invalid type number: ~A" type-number))))
	144	type))
0d07716f	145
3a935dfa	146	(defun type-from-name (name)
	147	(etypecase name
	148	(string (type-from-number (find-type-number name t)))))
0d07716f	149
508d13a7	150	(defbinding (find-type-name "g_type_name") (type) (copy-of string)
3a935dfa	151	((find-type-number type t) type-number))
	152
	153	(defun type-number-of (object)
	154	(find-type-number (type-of object) t))
	155
	156	(defun init-type (init)
	157	(mapc
	158	#'(lambda (fname)
	159	(funcall (mkbinding fname 'type-number)))
	160	(mklist init)))
	161
4d1d3921	162	(defun %init-types-in-library (pathname prefix ignore)
3a935dfa	163	(let ((process (ext:run-program
27487b3d	164	"nm" (list "-D" (namestring (truename pathname)))
3a935dfa	165	:output :stream :wait nil))
	166	(fnames ()))
	167	(labels ((read-symbols ()
	168	(let ((line (read-line (ext:process-output process) nil)))
	169	(when line
b011356b	170	(let ((symbol (subseq line 11)))
b011356b	171	(when (and
4d1d3921	172	(> (length symbol) (length prefix))
4d1d3921	173	(string= prefix symbol :end2 (length prefix))
b011356b	174	(search "_get_type" symbol)
	175	(not (member symbol ignore :test #'string=)))
	176	(push symbol fnames)))
3a935dfa	177	(read-symbols)))))
	178	(read-symbols)
	179	(ext:process-close process)
	180	`(init-type ',fnames))))
0d07716f	181
4d1d3921	182	(defmacro init-types-in-library (filename &key (prefix "") ignore)
4d1d3921	183	(%init-types-in-library filename prefix ignore))
b011356b	184
b011356b	185
0d07716f	186
fc47a022	187	;;;; Superclass for wrapping types in the glib type system
0d07716f	188
0d07716f	189	(eval-when (:compile-toplevel :load-toplevel :execute)
fc47a022	190	(defclass ginstance (proxy)
3a935dfa	191	((class :allocation :alien :type pointer))
3a935dfa	192	(:metaclass proxy-class)))
0d07716f	193
fc47a022	194	(defun %type-of-ginstance (location)
fc47a022	195	(let ((class (sap-ref-sap location 0)))
4d1d3921	196	(type-from-number (sap-ref-32 class 0))))
0d07716f	197
4d1d3921	198	(defmethod ensure-proxy-instance ((class ginstance-class) location)
	199	(declare (ignore class))
	200	(let ((class (find-class (%type-of-ginstance location))))
	201	(if class
	202	(make-instance class :location (reference-foreign class location))
	203	;; TODO: (make-instance 'ginstance ...)
	204	location)))
0d07716f	205
508d13a7	206	(defmethod copy-from-alien-form (location (class ginstance-class) &rest args)
	207	(declare (ignore location class args))
	208	(error "Doing copy-from-alien on a ref. counted class is most certainly an error, but if it really is what you want you should use REFERENCE-FOREIGN on the returned instance instead."))
	209
	210	(defmethod copy-from-alien-function ((class ginstance-class) &rest args)
	211	(declare (ignore class args))
	212	(error "Doing copy-from-alien on a ref. counted class is most certainly an error, but if it really is what you want you should use REFERENCE-FOREIGN on the returned instance instead."))
	213
	214	(defmethod reader-function ((class ginstance-class) &rest args)
	215	(declare (ignore args))
	216	#'(lambda (location &optional (offset 0))
	217	(ensure-proxy-instance class (sap-ref-sap location offset))))
	218
0d07716f	219
fc47a022	220	;;;; Metaclass for subclasses of ginstance
0d07716f	221
0d07716f	222	(eval-when (:compile-toplevel :load-toplevel :execute)
935a783c	223	(defclass ginstance-class (proxy-class)
935a783c	224	()))
0d07716f	225
0d07716f	226
c9819f3e	227	(defmethod shared-initialize ((class ginstance-class) names
4d1d3921	228	&rest initargs &key name alien-name)
4d1d3921	229	(declare (ignore names))
fc47a022	230	(let* ((class-name (or name (class-name class)))
fc47a022	231	(type-number
3a935dfa	232	(find-type-number
b011356b	233	(or (first alien-name) (default-alien-type-name class-name)) t)))
3a935dfa	234	(register-type class-name type-number)
935a783c	235	(if (getf initargs :size)
	236	(call-next-method)
	237	(let ((size (type-instance-size type-number)))
4d1d3921	238	(apply #'call-next-method class names :size (list size) initargs)))))
	239
	240
	241	(defmethod validate-superclass ((class ginstance-class) (super standard-class))
c9819f3e	242	(subtypep (class-name super) 'ginstance))
0d07716f	243
0d07716f	244
3a935dfa	245	;;;; Registering fundamental types
	246
	247	(register-type 'pointer "gpointer")
	248	(register-type 'char "gchar")
	249	(register-type 'unsigned-char "guchar")
	250	(register-type 'boolean "gboolean")
	251	(register-type 'fixnum "gint")
	252	(register-type 'int "gint")
	253	(register-type 'unsigned-int "guint")
	254	(register-type 'long "glong")
	255	(register-type 'unsigned-long "gulong")
	256	(register-type 'single-float "gfloat")
	257	(register-type 'double-float "gdouble")
b011356b	258	(register-type 'string "gchararray")
3a935dfa	259
	260
	261	;;;;
	262
4812615b	263	(defvar derivable-type-info (make-hash-table))
3a935dfa	264
4812615b	265	(defun register-derivable-type (type id expander)
3a935dfa	266	(register-type type id)
4812615b	267	(let ((type-number (register-type type id)))
4812615b	268	(setf (gethash type-number derivable-type-info) expander)))
3a935dfa	269
b011356b	270	(defun find-type-info (type)
b011356b	271	(dolist (super (cdr (type-hierarchy type)))
4812615b	272	(let ((info (gethash super derivable-type-info)))
b011356b	273	(return-if info))))
b011356b	274
4812615b	275	(defun expand-type-definition (type options)
	276	(let ((expander (find-type-info type)))
	277	(funcall expander (find-type-number type t) options)))
3a935dfa	278
3a935dfa	279	(defbinding type-parent (type) type-number
	280	((find-type-number type t) type-number))
	281
	282	(defun supertype (type)
	283	(type-from-number (type-parent type)))
	284
7858d45e	285	(defbinding %type-interfaces (type) pointer
	286	((find-type-number type t) type-number)
	287	(n-interfaces unsigned-int :out))
	288
	289	(defun type-interfaces (type)
	290	(multiple-value-bind (array length) (%type-interfaces type)
	291	(unwind-protect
4d1d3921	292	(map-c-vector 'list #'identity array 'type-number length)
7858d45e	293	(deallocate-memory array))))
	294
	295	(defun implements (type)
	296	(mapcar #'type-from-number (type-interfaces type)))
	297
3a935dfa	298	(defun type-hierarchy (type)
	299	(let ((type-number (find-type-number type t)))
	300	(unless (= type-number 0)
	301	(cons type-number (type-hierarchy (type-parent type-number))))))
	302
	303	(defbinding (type-is-p "g_type_is_a") (type super) boolean
	304	((find-type-number type) type-number)
	305	((find-type-number super) type-number))
	306
	307	(defbinding %type-children () pointer
	308	(type-number type-number)
	309	(num-children unsigned-int :out))
	310
	311	(defun map-subtypes (function type &optional prefix)
	312	(let ((type-number (find-type-number type t)))
	313	(multiple-value-bind (array length) (%type-children type-number)
	314	(unwind-protect
4d1d3921	315	(map-c-vector
3a935dfa	316	'nil
	317	#'(lambda (type-number)
	318	(when (or
	319	(not prefix)
	320	(string-prefix-p prefix (find-type-name type-number)))
	321	(funcall function type-number))
	322	(map-subtypes function type-number prefix))
	323	array 'type-number length)
	324	(deallocate-memory array)))))
	325
	326	(defun find-types (prefix)
	327	(let ((type-list nil))
4812615b	328	(maphash
	329	#'(lambda (type-number expander)
	330	(declare (ignore expander))
	331	(map-subtypes
	332	#'(lambda (type-number)
	333	(pushnew type-number type-list))
	334	type-number prefix))
	335	derivable-type-info)
3a935dfa	336	type-list))
	337
	338	(defun %sort-types-topologicaly (unsorted)
	339	(let ((sorted ()))
	340	(loop while unsorted do
	341	(dolist (type unsorted)
7858d45e	342	(let ((dependencies
7858d45e	343	(append (rest (type-hierarchy type)) (type-interfaces type))))
3a935dfa	344	(cond
	345	((null dependencies)
	346	(push type sorted)
	347	(setq unsorted (delete type unsorted)))
	348	(t
	349	(unless (dolist (dep dependencies)
4812615b	350	(when (find type (rest (type-hierarchy dep)))
4812615b	351	(error "Cyclic type dependencie"))
3a935dfa	352	(return-if (find dep unsorted)))
	353	(push type sorted)
	354	(setq unsorted (delete type unsorted))))))))
	355	(nreverse sorted)))
	356
	357
	358	(defun expand-type-definitions (prefix &optional args)
4812615b	359	(flet ((type-options (type-number)
3a935dfa	360	(let ((name (find-type-name type-number)))
b011356b	361	(cdr (assoc name args :test #'string=)))))
3a935dfa	362
4812615b	363	(let ((type-list
	364	(delete-if
	365	#'(lambda (type-number)
	366	(let ((name (find-type-name type-number)))
	367	(or
	368	(getf (type-options type-number) :ignore)
	369	(find-if
	370	#'(lambda (options)
	371	(and
	372	(string-prefix-p (first options) name)
17c607d0	373	(getf (cdr options) :ignore-prefix)
	374	(not (some
	375	#'(lambda (exception)
	376	(string= name exception))
	377	(getf (cdr options) :except)))))
4812615b	378	args))))
4812615b	379	(find-types prefix))))
3a935dfa	380
4812615b	381	(dolist (type-number type-list)
	382	(let ((name (find-type-name type-number)))
	383	(register-type
	384	(getf (type-options type-number) :type (default-type-name name))
	385	type-number)))
	386
	387	`(progn
	388	,@(mapcar
	389	#'(lambda (type)
	390	(expand-type-definition type (type-options type)))
	391	(%sort-types-topologicaly type-list))))))
	392
3a935dfa	393	(defmacro define-types-by-introspection (prefix &rest args)
b011356b	394	(expand-type-definitions prefix args))
4812615b	395
	396
	397