[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.20 2004-11-13 16:37:09 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) 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)))


;;;; 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
560af5c5	1	;; Common Lisp bindings for GTK+ v2.0
d4b21b08	2	;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
560af5c5	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
e74cfcab	18	;; $Id: gtype.lisp,v 1.20 2004-11-13 16:37:09 espen Exp $
560af5c5	19
	20	(in-package "GLIB")
	21
	22	(use-prefix "g")
	23
e0349dbd	24	;; Initialize the glib type system
	25	(defbinding type-init () nil)
	26	(type-init)
560af5c5	27
	28	(deftype type-number () '(unsigned 32))
	29
e74cfcab	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
93aa67db	71	(eval-when (:compile-toplevel :load-toplevel :execute)
d4b21b08	72	(defclass type-query (struct)
93aa67db	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))
d168bafd	77	(:metaclass struct-class)))
93aa67db	78
93aa67db	79
e74cfcab	80	(defbinding type-query (type) nil
	81	((find-type-number type t) type-number)
	82	((make-instance 'type-query) type-query :return))
93aa67db	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))
560af5c5	89
d4b21b08	90	(defbinding type-class-ref (type) pointer
d4b21b08	91	((find-type-number type t) type-number))
560af5c5	92
d4b21b08	93	(defbinding type-class-unref (type) nil
d4b21b08	94	((find-type-number type t) type-number))
93aa67db	95
d4b21b08	96	(defbinding type-class-peek (type) pointer
d4b21b08	97	((find-type-number type t) type-number))
93aa67db	98
560af5c5	99
d4b21b08	100	;;;; Mapping between lisp types and glib types
560af5c5	101
	102	(defvar type-to-number-hash (make-hash-table))
	103	(defvar number-to-type-hash (make-hash-table))
	104
d4b21b08	105	(defun register-type (type id)
	106	(let ((type-number
	107	(etypecase id
	108	(integer id)
4d83a8a6	109	(string (find-type-number id t))
4d83a8a6	110	(symbol (gethash id type-to-number-hash)))))
d4b21b08	111	(setf (gethash type type-to-number-hash) type-number)
4d83a8a6	112	(unless (symbolp id)
4d83a8a6	113	(setf (gethash type-number number-to-type-hash) type))
d4b21b08	114	type-number))
	115
	116	(defbinding %type-from-name () type-number
	117	(name string))
	118
	119	(defun find-type-number (type &optional error)
560af5c5	120	(etypecase type
560af5c5	121	(integer type)
d4b21b08	122	(string
	123	(let ((type-number (%type-from-name type)))
	124	(cond
	125	((and (zerop type-number) error)
d168bafd	126	(error "Invalid gtype name: ~A" type))
d4b21b08	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))))
560af5c5	135
4de90d10	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))
560af5c5	145
d4b21b08	146	(defun type-from-name (name)
	147	(etypecase name
	148	(string (type-from-number (find-type-number name t)))))
560af5c5	149
d4b21b08	150	(defbinding (find-type-name "g_type_name") (type) string
	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
d168bafd	162	(defun %init-types-in-library (pathname prefix ignore)
d4b21b08	163	(let ((process (ext:run-program
0c0db5e2	164	"nm" (list "-D" (namestring (truename pathname)))
d4b21b08	165	:output :stream :wait nil))
	166	(fnames ()))
	167	(labels ((read-symbols ()
	168	(let ((line (read-line (ext:process-output process) nil)))
	169	(when line
4de90d10	170	(let ((symbol (subseq line 11)))
4de90d10	171	(when (and
d168bafd	172	(> (length symbol) (length prefix))
d168bafd	173	(string= prefix symbol :end2 (length prefix))
4de90d10	174	(search "_get_type" symbol)
	175	(not (member symbol ignore :test #'string=)))
	176	(push symbol fnames)))
d4b21b08	177	(read-symbols)))))
	178	(read-symbols)
	179	(ext:process-close process)
	180	`(init-type ',fnames))))
560af5c5	181
d168bafd	182	(defmacro init-types-in-library (filename &key (prefix "") ignore)
d168bafd	183	(%init-types-in-library filename prefix ignore))
4de90d10	184
4de90d10	185
560af5c5	186
93aa67db	187	;;;; Superclass for wrapping types in the glib type system
560af5c5	188
560af5c5	189	(eval-when (:compile-toplevel :load-toplevel :execute)
93aa67db	190	(defclass ginstance (proxy)
d4b21b08	191	((class :allocation :alien :type pointer))
d4b21b08	192	(:metaclass proxy-class)))
560af5c5	193
93aa67db	194	(defun %type-of-ginstance (location)
93aa67db	195	(let ((class (sap-ref-sap location 0)))
d168bafd	196	(type-from-number (sap-ref-32 class 0))))
560af5c5	197
d168bafd	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)))
560af5c5	205
560af5c5	206
93aa67db	207	;;;; Metaclass for subclasses of ginstance
560af5c5	208
560af5c5	209	(eval-when (:compile-toplevel :load-toplevel :execute)
4d83a8a6	210	(defclass ginstance-class (proxy-class)
4d83a8a6	211	()))
560af5c5	212
560af5c5	213
c8c48a4c	214	(defmethod shared-initialize ((class ginstance-class) names
d168bafd	215	&rest initargs &key name alien-name)
d168bafd	216	(declare (ignore names))
93aa67db	217	(let* ((class-name (or name (class-name class)))
93aa67db	218	(type-number
d4b21b08	219	(find-type-number
4de90d10	220	(or (first alien-name) (default-alien-type-name class-name)) t)))
d4b21b08	221	(register-type class-name type-number)
4d83a8a6	222	(if (getf initargs :size)
	223	(call-next-method)
	224	(let ((size (type-instance-size type-number)))
d168bafd	225	(apply #'call-next-method class names :size (list size) initargs)))))
	226
	227
	228	(defmethod validate-superclass ((class ginstance-class) (super standard-class))
c8c48a4c	229	(subtypep (class-name super) 'ginstance))
560af5c5	230
560af5c5	231
d4b21b08	232	;;;; Registering fundamental types
	233
	234	(register-type 'pointer "gpointer")
	235	(register-type 'char "gchar")
	236	(register-type 'unsigned-char "guchar")
	237	(register-type 'boolean "gboolean")
	238	(register-type 'fixnum "gint")
	239	(register-type 'int "gint")
	240	(register-type 'unsigned-int "guint")
	241	(register-type 'long "glong")
	242	(register-type 'unsigned-long "gulong")
	243	(register-type 'single-float "gfloat")
	244	(register-type 'double-float "gdouble")
4de90d10	245	(register-type 'string "gchararray")
d4b21b08	246
	247
	248	;;;;
	249
e77e7713	250	(defvar derivable-type-info (make-hash-table))
d4b21b08	251
e77e7713	252	(defun register-derivable-type (type id expander)
d4b21b08	253	(register-type type id)
e77e7713	254	(let ((type-number (register-type type id)))
e77e7713	255	(setf (gethash type-number derivable-type-info) expander)))
d4b21b08	256
4de90d10	257	(defun find-type-info (type)
4de90d10	258	(dolist (super (cdr (type-hierarchy type)))
e77e7713	259	(let ((info (gethash super derivable-type-info)))
4de90d10	260	(return-if info))))
4de90d10	261
e77e7713	262	(defun expand-type-definition (type options)
	263	(let ((expander (find-type-info type)))
	264	(funcall expander (find-type-number type t) options)))
d4b21b08	265
d4b21b08	266	(defbinding type-parent (type) type-number
	267	((find-type-number type t) type-number))
	268
	269	(defun supertype (type)
	270	(type-from-number (type-parent type)))
	271
337933d8	272	(defbinding %type-interfaces (type) pointer
	273	((find-type-number type t) type-number)
	274	(n-interfaces unsigned-int :out))
	275
	276	(defun type-interfaces (type)
	277	(multiple-value-bind (array length) (%type-interfaces type)
	278	(unwind-protect
d168bafd	279	(map-c-vector 'list #'identity array 'type-number length)
337933d8	280	(deallocate-memory array))))
	281
	282	(defun implements (type)
	283	(mapcar #'type-from-number (type-interfaces type)))
	284
d4b21b08	285	(defun type-hierarchy (type)
	286	(let ((type-number (find-type-number type t)))
	287	(unless (= type-number 0)
	288	(cons type-number (type-hierarchy (type-parent type-number))))))
	289
	290	(defbinding (type-is-p "g_type_is_a") (type super) boolean
	291	((find-type-number type) type-number)
	292	((find-type-number super) type-number))
	293
	294	(defbinding %type-children () pointer
	295	(type-number type-number)
	296	(num-children unsigned-int :out))
	297
	298	(defun map-subtypes (function type &optional prefix)
	299	(let ((type-number (find-type-number type t)))
	300	(multiple-value-bind (array length) (%type-children type-number)
	301	(unwind-protect
d168bafd	302	(map-c-vector
d4b21b08	303	'nil
	304	#'(lambda (type-number)
	305	(when (or
	306	(not prefix)
	307	(string-prefix-p prefix (find-type-name type-number)))
	308	(funcall function type-number))
	309	(map-subtypes function type-number prefix))
	310	array 'type-number length)
	311	(deallocate-memory array)))))
	312
	313	(defun find-types (prefix)
	314	(let ((type-list nil))
e77e7713	315	(maphash
	316	#'(lambda (type-number expander)
	317	(declare (ignore expander))
	318	(map-subtypes
	319	#'(lambda (type-number)
	320	(pushnew type-number type-list))
	321	type-number prefix))
	322	derivable-type-info)
d4b21b08	323	type-list))
	324
	325	(defun %sort-types-topologicaly (unsorted)
	326	(let ((sorted ()))
	327	(loop while unsorted do
	328	(dolist (type unsorted)
337933d8	329	(let ((dependencies
337933d8	330	(append (rest (type-hierarchy type)) (type-interfaces type))))
d4b21b08	331	(cond
	332	((null dependencies)
	333	(push type sorted)
	334	(setq unsorted (delete type unsorted)))
	335	(t
	336	(unless (dolist (dep dependencies)
e77e7713	337	(when (find type (rest (type-hierarchy dep)))
e77e7713	338	(error "Cyclic type dependencie"))
d4b21b08	339	(return-if (find dep unsorted)))
	340	(push type sorted)
	341	(setq unsorted (delete type unsorted))))))))
	342	(nreverse sorted)))
	343
	344
	345	(defun expand-type-definitions (prefix &optional args)
e77e7713	346	(flet ((type-options (type-number)
d4b21b08	347	(let ((name (find-type-name type-number)))
4de90d10	348	(cdr (assoc name args :test #'string=)))))
d4b21b08	349
e77e7713	350	(let ((type-list
	351	(delete-if
	352	#'(lambda (type-number)
	353	(let ((name (find-type-name type-number)))
	354	(or
	355	(getf (type-options type-number) :ignore)
	356	(find-if
	357	#'(lambda (options)
	358	(and
	359	(string-prefix-p (first options) name)
80a09c29	360	(getf (cdr options) :ignore-prefix)
	361	(not (some
	362	#'(lambda (exception)
	363	(string= name exception))
	364	(getf (cdr options) :except)))))
e77e7713	365	args))))
e77e7713	366	(find-types prefix))))
d4b21b08	367
e77e7713	368	(dolist (type-number type-list)
	369	(let ((name (find-type-name type-number)))
	370	(register-type
	371	(getf (type-options type-number) :type (default-type-name name))
	372	type-number)))
	373
	374	`(progn
	375	,@(mapcar
	376	#'(lambda (type)
	377	(expand-type-definition type (type-options type)))
	378	(%sort-types-topologicaly type-list))))))
	379
d4b21b08	380	(defmacro define-types-by-introspection (prefix &rest args)
4de90d10	381	(expand-type-definitions prefix args))
e77e7713	382
	383
	384