[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.23 2005/01/12 13:33:06 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)) 

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

(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)))))


(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 'nil "void")
(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))))
	  (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
40c346ec	18	;; $Id: gtype.lisp,v 1.23 2005/01/12 13:33:06 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))
40c346ec	51	`(type-from-number ,type-number))
b4a2c852	52
	53	(defmethod from-alien-function ((type (eql 'gtype)) &rest args)
	54	(declare (ignore type args))
	55	#'(lambda (type-number)
40c346ec	56	(type-from-number type-number)))
b4a2c852	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))
40c346ec	68	(type-from-number (funcall reader location offset)))))
b4a2c852	69
b4a2c852	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
3a935dfa	246
40c346ec	247	(register-type 'nil "void")
3a935dfa	248	(register-type 'pointer "gpointer")
	249	(register-type 'char "gchar")
	250	(register-type 'unsigned-char "guchar")
	251	(register-type 'boolean "gboolean")
	252	(register-type 'fixnum "gint")
	253	(register-type 'int "gint")
	254	(register-type 'unsigned-int "guint")
	255	(register-type 'long "glong")
	256	(register-type 'unsigned-long "gulong")
	257	(register-type 'single-float "gfloat")
	258	(register-type 'double-float "gdouble")
b77fe850	259	(register-type 'pathname "gchararray")
b011356b	260	(register-type 'string "gchararray")
3a935dfa	261
	262
	263	;;;;
	264
4812615b	265	(defvar derivable-type-info (make-hash-table))
3a935dfa	266
4812615b	267	(defun register-derivable-type (type id expander)
3a935dfa	268	(register-type type id)
4812615b	269	(let ((type-number (register-type type id)))
4812615b	270	(setf (gethash type-number derivable-type-info) expander)))
3a935dfa	271
b011356b	272	(defun find-type-info (type)
b011356b	273	(dolist (super (cdr (type-hierarchy type)))
4812615b	274	(let ((info (gethash super derivable-type-info)))
b011356b	275	(return-if info))))
b011356b	276
4812615b	277	(defun expand-type-definition (type options)
	278	(let ((expander (find-type-info type)))
	279	(funcall expander (find-type-number type t) options)))
3a935dfa	280
3a935dfa	281	(defbinding type-parent (type) type-number
	282	((find-type-number type t) type-number))
	283
	284	(defun supertype (type)
	285	(type-from-number (type-parent type)))
	286
7858d45e	287	(defbinding %type-interfaces (type) pointer
	288	((find-type-number type t) type-number)
	289	(n-interfaces unsigned-int :out))
	290
	291	(defun type-interfaces (type)
	292	(multiple-value-bind (array length) (%type-interfaces type)
	293	(unwind-protect
4d1d3921	294	(map-c-vector 'list #'identity array 'type-number length)
7858d45e	295	(deallocate-memory array))))
	296
	297	(defun implements (type)
	298	(mapcar #'type-from-number (type-interfaces type)))
	299
3a935dfa	300	(defun type-hierarchy (type)
	301	(let ((type-number (find-type-number type t)))
	302	(unless (= type-number 0)
	303	(cons type-number (type-hierarchy (type-parent type-number))))))
	304
	305	(defbinding (type-is-p "g_type_is_a") (type super) boolean
	306	((find-type-number type) type-number)
	307	((find-type-number super) type-number))
	308
	309	(defbinding %type-children () pointer
	310	(type-number type-number)
	311	(num-children unsigned-int :out))
	312
	313	(defun map-subtypes (function type &optional prefix)
	314	(let ((type-number (find-type-number type t)))
	315	(multiple-value-bind (array length) (%type-children type-number)
	316	(unwind-protect
4d1d3921	317	(map-c-vector
3a935dfa	318	'nil
	319	#'(lambda (type-number)
	320	(when (or
	321	(not prefix)
	322	(string-prefix-p prefix (find-type-name type-number)))
	323	(funcall function type-number))
	324	(map-subtypes function type-number prefix))
	325	array 'type-number length)
	326	(deallocate-memory array)))))
	327
	328	(defun find-types (prefix)
	329	(let ((type-list nil))
4812615b	330	(maphash
	331	#'(lambda (type-number expander)
	332	(declare (ignore expander))
	333	(map-subtypes
	334	#'(lambda (type-number)
	335	(pushnew type-number type-list))
	336	type-number prefix))
	337	derivable-type-info)
3a935dfa	338	type-list))
	339
	340	(defun %sort-types-topologicaly (unsorted)
	341	(let ((sorted ()))
	342	(loop while unsorted do
	343	(dolist (type unsorted)
7858d45e	344	(let ((dependencies
7858d45e	345	(append (rest (type-hierarchy type)) (type-interfaces type))))
3a935dfa	346	(cond
	347	((null dependencies)
	348	(push type sorted)
	349	(setq unsorted (delete type unsorted)))
	350	(t
	351	(unless (dolist (dep dependencies)
4812615b	352	(when (find type (rest (type-hierarchy dep)))
4812615b	353	(error "Cyclic type dependencie"))
3a935dfa	354	(return-if (find dep unsorted)))
	355	(push type sorted)
	356	(setq unsorted (delete type unsorted))))))))
	357	(nreverse sorted)))
	358
	359
	360	(defun expand-type-definitions (prefix &optional args)
4812615b	361	(flet ((type-options (type-number)
3a935dfa	362	(let ((name (find-type-name type-number)))
b011356b	363	(cdr (assoc name args :test #'string=)))))
3a935dfa	364
4812615b	365	(let ((type-list
	366	(delete-if
	367	#'(lambda (type-number)
	368	(let ((name (find-type-name type-number)))
	369	(or
	370	(getf (type-options type-number) :ignore)
	371	(find-if
	372	#'(lambda (options)
	373	(and
	374	(string-prefix-p (first options) name)
17c607d0	375	(getf (cdr options) :ignore-prefix)
	376	(not (some
	377	#'(lambda (exception)
	378	(string= name exception))
	379	(getf (cdr options) :except)))))
4812615b	380	args))))
4812615b	381	(find-types prefix))))
3a935dfa	382
4812615b	383	(dolist (type-number type-list)
	384	(let ((name (find-type-name type-number)))
	385	(register-type
	386	(getf (type-options type-number) :type (default-type-name name))
	387	type-number)))
	388
	389	`(progn
	390	,@(mapcar
	391	#'(lambda (type)
	392	(expand-type-definition type (type-options type)))
	393	(%sort-types-topologicaly type-list))))))
	394
3a935dfa	395	(defmacro define-types-by-introspection (prefix &rest args)
b011356b	396	(expand-type-definitions prefix args))
4812615b	397
	398
	399