chiark / gitweb /
New file main-loop.lisp
[clg] / glib / gtype.lisp
CommitLineData
112ac1d3 1;; Common Lisp bindings for GTK+ v2.x
74821f75 2;; Copyright 2000-2006 Espen S. Johnsen <espen@users.sf.net>
560af5c5 3;;
112ac1d3 4;; Permission is hereby granted, free of charge, to any person obtaining
5;; a copy of this software and associated documentation files (the
6;; "Software"), to deal in the Software without restriction, including
7;; without limitation the rights to use, copy, modify, merge, publish,
8;; distribute, sublicense, and/or sell copies of the Software, and to
9;; permit persons to whom the Software is furnished to do so, subject to
10;; the following conditions:
560af5c5 11;;
112ac1d3 12;; The above copyright notice and this permission notice shall be
13;; included in all copies or substantial portions of the Software.
560af5c5 14;;
112ac1d3 15;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22
b929328d 23;; $Id: gtype.lisp,v 1.66 2008-10-08 18:17:10 espen Exp $
560af5c5 24
25(in-package "GLIB")
26
27(use-prefix "g")
28
e0349dbd 29;; Initialize the glib type system
30(defbinding type-init () nil)
31(type-init)
560af5c5 32
1199ddd2 33(eval-when (:compile-toplevel :load-toplevel :execute)
34 (defbinding (bitsize-of-gtype "bitsize_of_gtype") () unsigned-int))
35
36(deftype type-number () `(unsigned-byte ,(bitsize-of-gtype)))
560af5c5 37
e74cfcab 38(deftype gtype () 'symbol)
39
75689fea 40(define-type-method alien-type ((type gtype))
41 (declare (ignore type))
e74cfcab 42 (alien-type 'type-number))
43
74821f75 44(define-type-method size-of ((type gtype) &key (inlined t))
45 (assert-inlined type inlined)
e74cfcab 46 (size-of 'type-number))
47
74821f75 48(define-type-method to-alien-form ((type gtype) gtype &optional copy-p)
49 (declare (ignore type copy-p))
e74cfcab 50 `(find-type-number ,gtype t))
51
74821f75 52(define-type-method to-alien-function ((type gtype) &optional copy-p)
53 (declare (ignore type copy-p))
e74cfcab 54 #'(lambda (gtype)
55 (find-type-number gtype t)))
56
74821f75 57(define-type-method from-alien-form ((type gtype) form &key ref)
58 (declare (ignore type ref))
59 `(type-from-number ,form))
e74cfcab 60
74821f75 61(define-type-method from-alien-function ((type gtype) &key ref)
62 (declare (ignore type ref))
e74cfcab 63 #'(lambda (type-number)
63752532 64 (type-from-number type-number)))
e74cfcab 65
74821f75 66(define-type-method writer-function ((type gtype) &key temp (inlined t))
67 (declare (ignore temp))
68 (assert-inlined type inlined)
e74cfcab 69 (let ((writer (writer-function 'type-number)))
70 #'(lambda (gtype location &optional (offset 0))
71 (funcall writer (find-type-number gtype t) location offset))))
72
74821f75 73(define-type-method reader-function ((type gtype) &key ref (inlined t))
74 (declare (ignore ref))
75 (assert-inlined type inlined)
e74cfcab 76 (let ((reader (reader-function 'type-number)))
74821f75 77 #'(lambda (location &optional (offset 0))
63752532 78 (type-from-number (funcall reader location offset)))))
e74cfcab 79
80
93aa67db 81(eval-when (:compile-toplevel :load-toplevel :execute)
d4b21b08 82 (defclass type-query (struct)
93aa67db 83 ((type-number :allocation :alien :type type-number)
74821f75 84 (name :allocation :alien :type (copy-of string))
93aa67db 85 (class-size :allocation :alien :type unsigned-int)
86 (instance-size :allocation :alien :type unsigned-int))
d168bafd 87 (:metaclass struct-class)))
93aa67db 88
89
e74cfcab 90(defbinding type-query (type) nil
91 ((find-type-number type t) type-number)
74821f75 92 ((make-instance 'type-query) type-query :in/return))
93aa67db 93
94(defun type-instance-size (type)
95 (slot-value (type-query type) 'instance-size))
96
97(defun type-class-size (type)
98 (slot-value (type-query type) 'class-size))
560af5c5 99
d4b21b08 100(defbinding type-class-ref (type) pointer
101 ((find-type-number type t) type-number))
560af5c5 102
74821f75 103(defbinding type-class-unref () nil
104 (class pointer))
93aa67db 105
d4b21b08 106(defbinding type-class-peek (type) pointer
107 ((find-type-number type t) type-number))
93aa67db 108
560af5c5 109
74821f75 110
d4b21b08 111;;;; Mapping between lisp types and glib types
560af5c5 112
dfa4f314 113(defvar *registered-types* ())
114(defvar *registered-type-aliases* ())
44f47f3d 115(defvar *registered-static-types* ())
dfa4f314 116(defvar *lisp-type-to-type-number* (make-hash-table))
117(defvar *type-number-to-lisp-type* (make-hash-table))
d4b21b08 118
119(defbinding %type-from-name () type-number
120 (name string))
121
dfa4f314 122(defun type-number-from-glib-name (name &optional (error-p t))
123 (let ((type-number (%type-from-name name)))
124 (cond
125 ((not (zerop type-number)) type-number)
126 (error-p (error "Invalid gtype name: ~A" name)))))
127
d32cbb7a 128(defun type-from-glib-name (name)
129 (type-from-number (type-number-from-glib-name name) t))
130
dfa4f314 131(defun register-type (type id)
74821f75 132 (cond
133 ((find-type-number type))
134 ((not id) (warn "Can't register type with no foreign id: ~A" type))
135 (t
136 (pushnew (cons type id) *registered-types* :key #'car)
137 (let ((type-number
138 (typecase id
139 (string (type-number-from-glib-name id))
140 (symbol (funcall id)))))
141 (setf (gethash type *lisp-type-to-type-number*) type-number)
142 (setf (gethash type-number *type-number-to-lisp-type*) type)
143 type-number))))
dfa4f314 144
145(defun register-type-alias (type alias)
146 (pushnew (cons type alias) *registered-type-aliases* :key #'car)
147 (setf
148 (gethash type *lisp-type-to-type-number*)
149 (find-type-number alias t)))
150
151(defun reinitialize-all-types ()
152 (clrhash *lisp-type-to-type-number*)
153 (clrhash *type-number-to-lisp-type*)
154 (type-init) ; initialize the glib type system
155 (mapc #'(lambda (type)
156 (register-type (car type) (cdr type)))
157 *registered-types*)
158 (mapc #'(lambda (type)
74821f75 159 (apply #'register-new-type type))
d32cbb7a 160 (reverse *registered-static-types*))
58a1fb1d 161 (mapc #'(lambda (type)
dfa4f314 162 (register-type-alias (car type) (cdr type)))
163 *registered-type-aliases*))
164
165(pushnew 'reinitialize-all-types
166 #+cmu *after-save-initializations*
74821f75 167 #+sbcl *init-hooks*
168 #+clisp custom:*init-hooks*)
dfa4f314 169
170#+cmu
171(pushnew 'system::reinitialize-global-table ; we shouldn't have to do this?
172 *after-save-initializations*)
173
174
175(defun find-type-number (type &optional error-p)
560af5c5 176 (etypecase type
177 (integer type)
dfa4f314 178 (string (type-number-from-glib-name type error-p))
d4b21b08 179 (symbol
dfa4f314 180 (or
181 (gethash type *lisp-type-to-type-number*)
182 (and error-p (error "Type not registered: ~A" type))))
183 (class (find-type-number (class-name type) error-p))))
560af5c5 184
4de90d10 185(defun type-from-number (type-number &optional error)
186 (multiple-value-bind (type found)
dfa4f314 187 (gethash type-number *type-number-to-lisp-type*)
e7dbc3bf 188 (if found
189 type
dfa4f314 190 (let ((name (find-foreign-type-name type-number)))
e7dbc3bf 191 (cond
cd859052 192 ((and name (not (= (type-number-from-glib-name name nil) type-number)))
e7dbc3bf 193 ;; This is a hack because GdkEvent seems to be registered
194 ;; multiple times
195 (type-from-number (type-number-from-glib-name name)))
196 ((and error name)
197 (error "Type number not registered: ~A (~A)" type-number name))
198 ((and error)
199 (error "Invalid type number: ~A" type-number)))))))
560af5c5 200
dfa4f314 201(defbinding (find-foreign-type-name "g_type_name") (type) (copy-of string)
d4b21b08 202 ((find-type-number type t) type-number))
203
204(defun type-number-of (object)
205 (find-type-number (type-of object) t))
206
4323cc97 207;; For #+(SBCL WIN32):
208;; The first 2 lines of the output from "pexports" are:
209;; LIBRARY XXX.dll
210;; EXPORTS
211;; We don't do anything to skip these 2 lines because they won't pass the
212;; WHEN (AND ...) in the LOOP
213;; - cph 19-May-2007
214
21299acf 215(eval-when (:compile-toplevel :load-toplevel :execute)
dfa4f314 216 (defvar *type-initializers* ())
217 (defun %find-types-in-library (pathname prefixes ignore)
4323cc97 218 (let ((outname (tmpname "types")))
21299acf 219 (unwind-protect
4323cc97 220 (let ((asdf::*verbose-out* nil))
b2dfffb9 221 #-win32
4323cc97 222 (asdf:run-shell-command "nm ~A ~A > ~A"
223 #-darwin "--defined-only --dynamic --extern-only"
224 #+darwin "-f -s __TEXT __text"
225 (namestring (truename pathname)) outname)
226 ;; Note about win32 port:
227 ;; 1. (TRUENAME PATHNAME) will bomb.
228 ;; 2. either
229 ;; pexports "d:\\whatever\\bin\\zlib1.dll"
230 ;; or
231 ;; pexports d:/whatever/bin/zlib1.dll
232 ;; anything else will bomb. this is why ~S is used below.
233 #+win32
234 (asdf:run-shell-command "pexports ~S > ~A"
235 (namestring pathname) outname)
236
237 (with-open-file (output outname)
238 (loop
239 as line = (read-line output nil)
240 as symbol = (when line
241 #-win32
242 (let ((pos (position #\space line :from-end t)))
243 #-darwin(subseq line (1+ pos))
244 #+darwin
245 (when (char= (char line (1- pos)) #\T)
246 (subseq line (+ pos 2))))
247 #+win32
248 (subseq line 0 (1- (length line))))
249 while line
250 when (and
251 symbol (> (length symbol) 9)
252 (not (char= (char symbol 0) #\_))
253 (or
254 (not prefixes)
255 (some #'(lambda (prefix)
256 (and
257 (> (length symbol) (length prefix))
258 (string= prefix symbol :end2 (length prefix))))
259 (mklist prefixes)))
260 (string= "_get_type" symbol :start2 (- (length symbol) 9))
261 (not (member symbol ignore :test #'string=)))
262 collect symbol)))
263 (delete-file outname)))))
21299acf 264
560af5c5 265
8f12a0ff 266(defmacro init-types-in-library (system library &key prefix ignore)
267 (let* ((filename (asdf:component-pathname (asdf:find-component (asdf:find-system system) library)))
268 (names (%find-types-in-library filename prefix ignore)))
21299acf 269 `(progn
270 ,@(mapcar #'(lambda (name)
271 `(progn
272 (defbinding (,(intern name) ,name) () type-number)
dfa4f314 273 (,(intern name))
274 (pushnew ',(intern name) *type-initializers*)))
21299acf 275 names))))
276
dfa4f314 277(defun find-type-init-function (type-number)
735a29da 278 (loop
279 for type-init in *type-initializers*
280 when (= type-number (funcall type-init))
281 do (return type-init)))
282
283(defun register-type-as (type-number)
284 (or
285 (find-type-init-function type-number)
286 (find-foreign-type-name type-number)
287 (error "Unknown type-number: ~A" type-number)))
dfa4f314 288
289(defun default-type-init-name (type)
290 (find-symbol (format nil "~A_~A_get_type"
291 (package-prefix *package*)
292 (substitute #\_ #\- (string-downcase type)))))
293
21299acf 294
15cbdefc 295(eval-when (:compile-toplevel :load-toplevel :execute)
296 (defclass type-info (struct)
297 ((class-size :allocation :alien :type (unsigned 16) :initarg :class-size)
298 (base-init :allocation :alien :type pointer)
299 (base-finalize :allocation :alien :type pointer)
300 (class-init :allocation :alien :type pointer)
301 (class-finalize :allocation :alien :type pointer)
302 (class-data :allocation :alien :type pointer)
303 (instance-size :allocation :alien :type (unsigned 16)
304 :initarg :instance-size)
305 (n-preallocs :allocation :alien :type (unsigned 16))
306 (instance-init :allocation :alien :type pointer)
307 (value-table :allocation :alien :type pointer))
308 (:metaclass struct-class)))
309
310(defbinding %type-register-static () type-number
e7dbc3bf 311 (parent-type type-number)
15cbdefc 312 (name string)
313 (info type-info)
314 (0 unsigned-int))
315
92a07e63 316(defun register-new-type (type parent &optional foreign-name)
15cbdefc 317 (let ((parent-info (type-query parent)))
318 (with-slots ((parent-number type-number) class-size instance-size) parent-info
319 (let ((type-number
320 (%type-register-static
321 parent-number
92a07e63 322 (or foreign-name (default-alien-type-name type))
15cbdefc 323 (make-instance 'type-info :class-size class-size :instance-size instance-size))))
44f47f3d 324 (pushnew (list type parent foreign-name) *registered-static-types* :key #'car)
325 (setf (gethash type *lisp-type-to-type-number*) type-number)
326 (setf (gethash type-number *type-number-to-lisp-type*) type)
327 type-number))))
15cbdefc 328
329
21299acf 330
331;;;; Metaclass for subclasses of ginstance
332
333(eval-when (:compile-toplevel :load-toplevel :execute)
334 (defclass ginstance-class (proxy-class)
6497583a 335 ((gtype :initarg :gtype :initform nil :reader ginstance-class-gtype))))
cd859052 336
337
1eaa1bd6 338(defun update-size (class)
339 (let ((type-number (find-type-number class)))
340 (cond
74821f75 341 ((not (foreign-size-p class))
342 (setf (foreign-size class) (type-instance-size type-number)))
1eaa1bd6 343 ((and
74821f75 344 (foreign-size-p class)
345 (not (= (type-instance-size type-number) (foreign-size class))))
1eaa1bd6 346 (warn "Size mismatch for class ~A" class)))))
347
09f6e237 348
cd859052 349(defmethod finalize-inheritance ((class ginstance-class))
74821f75 350 (prog1
351 #+clisp(call-next-method)
352 (let* ((class-name (class-name class))
353 (super (most-specific-proxy-superclass class))
354 (gtype (or
355 (first (ginstance-class-gtype class))
356 (default-alien-type-name class-name)))
357 (type-number
358 (or
359 (find-type-number class-name)
360 (let ((type-number
361 (if (or
362 (symbolp gtype)
363 (type-number-from-glib-name gtype nil))
364 (register-type class-name gtype)
365 (register-new-type class-name (class-name super) gtype))))
366 (type-class-ref type-number)
367 type-number))))
584285fb 368 #+nil
74821f75 369 (when (and
370 (supertype type-number)
371 (not (eq (class-name super) (supertype type-number))))
372 (warn "Super class mismatch between CLOS and GObject for ~A"
373 class-name)))
374 (update-size class))
375 #-clisp(call-next-method))
1eaa1bd6 376
377
378(defmethod shared-initialize ((class ginstance-class) names &rest initargs)
74821f75 379 (declare (ignore names initargs))
1eaa1bd6 380 (call-next-method)
381 (when (class-finalized-p class)
382 (update-size class)))
383
4de90d10 384
21299acf 385(defmethod validate-superclass ((class ginstance-class) (super standard-class))
386 (subtypep (class-name super) 'ginstance))
387
560af5c5 388
93aa67db 389;;;; Superclass for wrapping types in the glib type system
560af5c5 390
391(eval-when (:compile-toplevel :load-toplevel :execute)
af338f4a 392 (defclass ginstance (ref-counted-object)
09f6e237 393 (;(class :allocation :alien :type pointer :offset 0)
394 )
395 (:metaclass proxy-class)
396 (:size #.(size-of 'pointer))))
560af5c5 397
74821f75 398(defun ref-type-number (location &optional offset)
399 (declare (ignore location offset)))
400
401(setf (symbol-function 'ref-type-number) (reader-function 'type-number))
402
895c9a9e 403(defun %type-number-of-ginstance (location)
74821f75 404 (let ((class (ref-pointer location)))
405 (ref-type-number class)))
560af5c5 406
74821f75 407(defmethod make-proxy-instance :around ((class ginstance-class) location
408 &rest initargs)
d168bafd 409 (declare (ignore class))
895c9a9e 410 (let ((class (labels ((find-known-class (type-number)
411 (or
412 (find-class (type-from-number type-number) nil)
413 (unless (zerop type-number)
414 (find-known-class (type-parent type-number))))))
415 (find-known-class (%type-number-of-ginstance location)))))
b929328d 416 ;; Note that changing the class argument must not alter "the
8958fa4a 417 ;; ordered set of applicable methods" as specified in the
418 ;; Hyperspec
d168bafd 419 (if class
8958fa4a 420 (apply #'call-next-method class location initargs)
421 (error "Object at ~A has an unkown type number: ~A"
422 location (%type-number-of-ginstance location)))))
423
560af5c5 424
d4b21b08 425;;;; Registering fundamental types
426
63752532 427(register-type 'nil "void")
d4b21b08 428(register-type 'pointer "gpointer")
429(register-type 'char "gchar")
430(register-type 'unsigned-char "guchar")
431(register-type 'boolean "gboolean")
d4b21b08 432(register-type 'int "gint")
73383a9e 433(register-type-alias 'integer 'int)
dfa4f314 434(register-type-alias 'fixnum 'int)
d4b21b08 435(register-type 'unsigned-int "guint")
436(register-type 'long "glong")
437(register-type 'unsigned-long "gulong")
438(register-type 'single-float "gfloat")
439(register-type 'double-float "gdouble")
4de90d10 440(register-type 'string "gchararray")
1d1ff9a5 441(register-type-alias 'pathname 'string)
d4b21b08 442
443
62f12808 444;;;; Introspection of type information
d4b21b08 445
e77e7713 446(defvar *derivable-type-info* (make-hash-table))
d4b21b08 447
62f12808 448(defun register-derivable-type (type id expander &optional dependencies)
d4b21b08 449 (register-type type id)
e77e7713 450 (let ((type-number (register-type type id)))
62f12808 451 (setf
452 (gethash type-number *derivable-type-info*)
453 (list expander dependencies))))
d4b21b08 454
4de90d10 455(defun find-type-info (type)
456 (dolist (super (cdr (type-hierarchy type)))
e77e7713 457 (let ((info (gethash super *derivable-type-info*)))
4de90d10 458 (return-if info))))
459
62f12808 460(defun expand-type-definition (type forward-p options)
461 (let ((expander (first (find-type-info type))))
462 (funcall expander (find-type-number type t) forward-p options)))
d4b21b08 463
74821f75 464
d4b21b08 465(defbinding type-parent (type) type-number
466 ((find-type-number type t) type-number))
467
468(defun supertype (type)
469 (type-from-number (type-parent type)))
470
337933d8 471(defbinding %type-interfaces (type) pointer
472 ((find-type-number type t) type-number)
473 (n-interfaces unsigned-int :out))
474
475(defun type-interfaces (type)
476 (multiple-value-bind (array length) (%type-interfaces type)
477 (unwind-protect
d168bafd 478 (map-c-vector 'list #'identity array 'type-number length)
337933d8 479 (deallocate-memory array))))
480
481(defun implements (type)
482 (mapcar #'type-from-number (type-interfaces type)))
483
d4b21b08 484(defun type-hierarchy (type)
485 (let ((type-number (find-type-number type t)))
486 (unless (= type-number 0)
487 (cons type-number (type-hierarchy (type-parent type-number))))))
488
489(defbinding (type-is-p "g_type_is_a") (type super) boolean
490 ((find-type-number type) type-number)
491 ((find-type-number super) type-number))
492
493(defbinding %type-children () pointer
494 (type-number type-number)
495 (num-children unsigned-int :out))
496
497(defun map-subtypes (function type &optional prefix)
498 (let ((type-number (find-type-number type t)))
499 (multiple-value-bind (array length) (%type-children type-number)
500 (unwind-protect
d168bafd 501 (map-c-vector
d4b21b08 502 'nil
503 #'(lambda (type-number)
504 (when (or
505 (not prefix)
dfa4f314 506 (string-prefix-p prefix (find-foreign-type-name type-number)))
d4b21b08 507 (funcall function type-number))
508 (map-subtypes function type-number prefix))
509 array 'type-number length)
510 (deallocate-memory array)))))
511
512(defun find-types (prefix)
513 (let ((type-list nil))
e77e7713 514 (maphash
515 #'(lambda (type-number expander)
516 (declare (ignore expander))
517 (map-subtypes
518 #'(lambda (type-number)
519 (pushnew type-number type-list))
520 type-number prefix))
521 *derivable-type-info*)
d4b21b08 522 type-list))
523
74821f75 524(defun find-type-dependencies (type &optional options)
525 (let ((find-dependencies (second (find-type-info type))))
526 (when find-dependencies
527 (remove-duplicates
528 (mapcar #'find-type-number
529 (funcall find-dependencies (find-type-number type t) options))))))
530
531
532;; The argument is a list where each elements is on the form
584285fb 533;; (type . dependencies). This function will not handle indirect
8f12a0ff 534;; dependencies and types depending on them selves.
74821f75 535(defun sort-types-topologicaly (unsorted)
536 (flet ((depend-p (type1)
537 (find-if #'(lambda (type2)
538 (and
539 ;; If a type depends a subtype it has to be
540 ;; forward defined
541 (not (type-is-p (car type2) (car type1)))
542 (find (car type2) (cdr type1))))
543 unsorted)))
544 (let ((sorted
545 (loop
546 while unsorted
547 nconc (multiple-value-bind (sorted remaining)
548 (delete-collect-if
549 #'(lambda (type)
550 (or (not (cdr type)) (not (depend-p type))))
551 unsorted)
552 (cond
553 ((not sorted)
554 ;; We have a circular dependency which have to
555 ;; be resolved
556 (let ((selected
557 (find-if
558 #'(lambda (type)
559 (every
560 #'(lambda (dep)
561 (or
562 (not (type-is-p (car type) dep))
563 (not (find dep unsorted :key #'car))))
564 (cdr type)))
565 unsorted)))
566 (unless selected
567 (error "Couldn't resolve circular dependency"))
568 (setq unsorted (delete selected unsorted))
569 (list selected)))
570 (t
571 (setq unsorted remaining)
572 sorted))))))
573
574 ;; Mark types which have to be forward defined
575 (loop
576 for tmp on sorted
577 as (type . dependencies) = (first tmp)
578 collect (cons type (and
579 dependencies
580 (find-if #'(lambda (type)
581 (find (car type) dependencies))
582 (rest tmp))
583 t))))))
d4b21b08 584
585
586(defun expand-type-definitions (prefix &optional args)
dfa4f314 587 (flet ((type-options (type-number)
588 (let ((name (find-foreign-type-name type-number)))
4de90d10 589 (cdr (assoc name args :test #'string=)))))
d4b21b08 590
e77e7713 591 (let ((type-list
592 (delete-if
593 #'(lambda (type-number)
dfa4f314 594 (let ((name (find-foreign-type-name type-number)))
e77e7713 595 (or
596 (getf (type-options type-number) :ignore)
597 (find-if
598 #'(lambda (options)
599 (and
600 (string-prefix-p (first options) name)
80a09c29 601 (getf (cdr options) :ignore-prefix)
602 (not (some
603 #'(lambda (exception)
604 (string= name exception))
605 (getf (cdr options) :except)))))
e77e7713 606 args))))
607 (find-types prefix))))
21299acf 608
e77e7713 609 (dolist (type-number type-list)
dfa4f314 610 (let ((name (find-foreign-type-name type-number)))
e77e7713 611 (register-type
612 (getf (type-options type-number) :type (default-type-name name))
735a29da 613 (register-type-as type-number))))
21299acf 614
74821f75 615 ;; This is needed for some unknown reason to get type numbers right
616 (mapc #'find-type-dependencies type-list)
617
618 (let ((sorted-type-list
619 #+clisp (mapcar #'list type-list)
620 #-clisp
621 (sort-types-topologicaly
622 (mapcar
623 #'(lambda (type)
624 (cons type (find-type-dependencies type (type-options type))))
625 type-list))))
62f12808 626 `(progn
627 ,@(mapcar
21299acf 628 #'(lambda (pair)
629 (destructuring-bind (type . forward-p) pair
630 (expand-type-definition type forward-p (type-options type))))
631 sorted-type-list)
62f12808 632 ,@(mapcar
21299acf 633 #'(lambda (pair)
634 (destructuring-bind (type . forward-p) pair
635 (when forward-p
636 (expand-type-definition type nil (type-options type)))))
62f12808 637 sorted-type-list))))))
e77e7713 638
d4b21b08 639(defmacro define-types-by-introspection (prefix &rest args)
4de90d10 640 (expand-type-definitions prefix args))
21299acf 641
74821f75 642(defexport define-types-by-introspection (prefix &rest args)
fbd2b3d9 643 (list-autoexported-symbols (expand-type-definitions prefix args)))
74821f75 644
21299acf 645
646;;;; Initialize all non static types in GObject
647
8f12a0ff 648(init-types-in-library glib "libgobject-2.0")