chiark / gitweb /
New macro DEFINE-TYPES-IN-LIBRARY
[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
fb7dd5b9 23;; $Id: gtype.lisp,v 1.67 2008-12-10 02:54:17 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
fb7dd5b9 131(defun type-registered-p (type)
132 (nth-value 1 (gethash type *lisp-type-to-type-number*)))
133
dfa4f314 134(defun register-type (type id)
74821f75 135 (cond
fb7dd5b9 136 ((type-registered-p type) (find-type-number type))
74821f75 137 ((not id) (warn "Can't register type with no foreign id: ~A" type))
138 (t
139 (pushnew (cons type id) *registered-types* :key #'car)
140 (let ((type-number
141 (typecase id
142 (string (type-number-from-glib-name id))
143 (symbol (funcall id)))))
144 (setf (gethash type *lisp-type-to-type-number*) type-number)
145 (setf (gethash type-number *type-number-to-lisp-type*) type)
146 type-number))))
dfa4f314 147
148(defun register-type-alias (type alias)
149 (pushnew (cons type alias) *registered-type-aliases* :key #'car)
150 (setf
151 (gethash type *lisp-type-to-type-number*)
152 (find-type-number alias t)))
153
154(defun reinitialize-all-types ()
155 (clrhash *lisp-type-to-type-number*)
156 (clrhash *type-number-to-lisp-type*)
157 (type-init) ; initialize the glib type system
158 (mapc #'(lambda (type)
159 (register-type (car type) (cdr type)))
160 *registered-types*)
161 (mapc #'(lambda (type)
74821f75 162 (apply #'register-new-type type))
d32cbb7a 163 (reverse *registered-static-types*))
58a1fb1d 164 (mapc #'(lambda (type)
dfa4f314 165 (register-type-alias (car type) (cdr type)))
166 *registered-type-aliases*))
167
168(pushnew 'reinitialize-all-types
169 #+cmu *after-save-initializations*
74821f75 170 #+sbcl *init-hooks*
171 #+clisp custom:*init-hooks*)
dfa4f314 172
173#+cmu
174(pushnew 'system::reinitialize-global-table ; we shouldn't have to do this?
175 *after-save-initializations*)
176
177
178(defun find-type-number (type &optional error-p)
560af5c5 179 (etypecase type
180 (integer type)
dfa4f314 181 (string (type-number-from-glib-name type error-p))
d4b21b08 182 (symbol
dfa4f314 183 (or
184 (gethash type *lisp-type-to-type-number*)
fb7dd5b9 185 (let ((class (find-class type nil)))
186 (when (and class (not (class-finalized-p class)))
187 (finalize-inheritance class)
188 (gethash type *lisp-type-to-type-number*)))
dfa4f314 189 (and error-p (error "Type not registered: ~A" type))))
fb7dd5b9 190 (class
191 (find-type-number (class-name type) error-p))))
560af5c5 192
4de90d10 193(defun type-from-number (type-number &optional error)
194 (multiple-value-bind (type found)
dfa4f314 195 (gethash type-number *type-number-to-lisp-type*)
e7dbc3bf 196 (if found
197 type
dfa4f314 198 (let ((name (find-foreign-type-name type-number)))
e7dbc3bf 199 (cond
cd859052 200 ((and name (not (= (type-number-from-glib-name name nil) type-number)))
e7dbc3bf 201 ;; This is a hack because GdkEvent seems to be registered
202 ;; multiple times
203 (type-from-number (type-number-from-glib-name name)))
204 ((and error name)
205 (error "Type number not registered: ~A (~A)" type-number name))
206 ((and error)
207 (error "Invalid type number: ~A" type-number)))))))
560af5c5 208
dfa4f314 209(defbinding (find-foreign-type-name "g_type_name") (type) (copy-of string)
d4b21b08 210 ((find-type-number type t) type-number))
211
212(defun type-number-of (object)
213 (find-type-number (type-of object) t))
214
4323cc97 215;; For #+(SBCL WIN32):
216;; The first 2 lines of the output from "pexports" are:
217;; LIBRARY XXX.dll
218;; EXPORTS
219;; We don't do anything to skip these 2 lines because they won't pass the
220;; WHEN (AND ...) in the LOOP
221;; - cph 19-May-2007
222
21299acf 223(eval-when (:compile-toplevel :load-toplevel :execute)
dfa4f314 224 (defvar *type-initializers* ())
fb7dd5b9 225
226 (defun library-filename (system library)
227 (let ((component (asdf:find-component (asdf:find-system system) library)))
228 (etypecase component
229 (asdf:shared-object
230 (first (asdf:output-files (make-instance 'asdf:compile-op) component)))
231 (asdf:library (asdf:component-pathname component)))))
232
dfa4f314 233 (defun %find-types-in-library (pathname prefixes ignore)
4323cc97 234 (let ((outname (tmpname "types")))
21299acf 235 (unwind-protect
4323cc97 236 (let ((asdf::*verbose-out* nil))
b2dfffb9 237 #-win32
4323cc97 238 (asdf:run-shell-command "nm ~A ~A > ~A"
239 #-darwin "--defined-only --dynamic --extern-only"
240 #+darwin "-f -s __TEXT __text"
241 (namestring (truename pathname)) outname)
242 ;; Note about win32 port:
243 ;; 1. (TRUENAME PATHNAME) will bomb.
244 ;; 2. either
245 ;; pexports "d:\\whatever\\bin\\zlib1.dll"
246 ;; or
247 ;; pexports d:/whatever/bin/zlib1.dll
248 ;; anything else will bomb. this is why ~S is used below.
249 #+win32
250 (asdf:run-shell-command "pexports ~S > ~A"
251 (namestring pathname) outname)
252
253 (with-open-file (output outname)
254 (loop
255 as line = (read-line output nil)
256 as symbol = (when line
257 #-win32
258 (let ((pos (position #\space line :from-end t)))
259 #-darwin(subseq line (1+ pos))
260 #+darwin
261 (when (char= (char line (1- pos)) #\T)
262 (subseq line (+ pos 2))))
263 #+win32
264 (subseq line 0 (1- (length line))))
265 while line
266 when (and
267 symbol (> (length symbol) 9)
268 (not (char= (char symbol 0) #\_))
269 (or
270 (not prefixes)
271 (some #'(lambda (prefix)
272 (and
273 (> (length symbol) (length prefix))
274 (string= prefix symbol :end2 (length prefix))))
275 (mklist prefixes)))
276 (string= "_get_type" symbol :start2 (- (length symbol) 9))
277 (not (member symbol ignore :test #'string=)))
278 collect symbol)))
279 (delete-file outname)))))
21299acf 280
560af5c5 281
fb7dd5b9 282(defun car-eq-p (ob1 ob2)
283 (eq (car ob1) (car ob2)))
284
8f12a0ff 285(defmacro init-types-in-library (system library &key prefix ignore)
fb7dd5b9 286 (let* ((filename (library-filename system library))
8f12a0ff 287 (names (%find-types-in-library filename prefix ignore)))
21299acf 288 `(progn
fb7dd5b9 289 ,@(mapcar
290 #'(lambda (name)
291 `(progn
292 (defbinding (,(intern name) ,name) () type-number)
293 (,(intern name))
294 (pushnew (cons ',(intern name) ,filename) *type-initializers*
295 :test #'car-eq-p)))
296 names))))
21299acf 297
dfa4f314 298(defun find-type-init-function (type-number)
735a29da 299 (loop
fb7dd5b9 300 for (type-init) in *type-initializers*
735a29da 301 when (= type-number (funcall type-init))
302 do (return type-init)))
303
304(defun register-type-as (type-number)
305 (or
306 (find-type-init-function type-number)
307 (find-foreign-type-name type-number)
308 (error "Unknown type-number: ~A" type-number)))
dfa4f314 309
310(defun default-type-init-name (type)
311 (find-symbol (format nil "~A_~A_get_type"
312 (package-prefix *package*)
313 (substitute #\_ #\- (string-downcase type)))))
314
21299acf 315
15cbdefc 316(eval-when (:compile-toplevel :load-toplevel :execute)
317 (defclass type-info (struct)
318 ((class-size :allocation :alien :type (unsigned 16) :initarg :class-size)
319 (base-init :allocation :alien :type pointer)
320 (base-finalize :allocation :alien :type pointer)
321 (class-init :allocation :alien :type pointer)
322 (class-finalize :allocation :alien :type pointer)
323 (class-data :allocation :alien :type pointer)
324 (instance-size :allocation :alien :type (unsigned 16)
325 :initarg :instance-size)
326 (n-preallocs :allocation :alien :type (unsigned 16))
327 (instance-init :allocation :alien :type pointer)
328 (value-table :allocation :alien :type pointer))
329 (:metaclass struct-class)))
330
331(defbinding %type-register-static () type-number
e7dbc3bf 332 (parent-type type-number)
15cbdefc 333 (name string)
334 (info type-info)
335 (0 unsigned-int))
336
92a07e63 337(defun register-new-type (type parent &optional foreign-name)
15cbdefc 338 (let ((parent-info (type-query parent)))
339 (with-slots ((parent-number type-number) class-size instance-size) parent-info
340 (let ((type-number
341 (%type-register-static
342 parent-number
92a07e63 343 (or foreign-name (default-alien-type-name type))
15cbdefc 344 (make-instance 'type-info :class-size class-size :instance-size instance-size))))
44f47f3d 345 (pushnew (list type parent foreign-name) *registered-static-types* :key #'car)
346 (setf (gethash type *lisp-type-to-type-number*) type-number)
347 (setf (gethash type-number *type-number-to-lisp-type*) type)
348 type-number))))
15cbdefc 349
350
21299acf 351
352;;;; Metaclass for subclasses of ginstance
353
354(eval-when (:compile-toplevel :load-toplevel :execute)
355 (defclass ginstance-class (proxy-class)
6497583a 356 ((gtype :initarg :gtype :initform nil :reader ginstance-class-gtype))))
cd859052 357
358
1eaa1bd6 359(defun update-size (class)
360 (let ((type-number (find-type-number class)))
361 (cond
74821f75 362 ((not (foreign-size-p class))
363 (setf (foreign-size class) (type-instance-size type-number)))
1eaa1bd6 364 ((and
74821f75 365 (foreign-size-p class)
366 (not (= (type-instance-size type-number) (foreign-size class))))
1eaa1bd6 367 (warn "Size mismatch for class ~A" class)))))
368
09f6e237 369
cd859052 370(defmethod finalize-inheritance ((class ginstance-class))
74821f75 371 (prog1
372 #+clisp(call-next-method)
373 (let* ((class-name (class-name class))
374 (super (most-specific-proxy-superclass class))
375 (gtype (or
376 (first (ginstance-class-gtype class))
fb7dd5b9 377 (default-alien-type-name class-name))))
378 (unless (type-registered-p class-name)
379 (type-class-ref
380 (if (or (symbolp gtype) (type-number-from-glib-name gtype nil))
381 (register-type class-name gtype)
382 (register-new-type class-name (class-name super) gtype))))
584285fb 383 #+nil
74821f75 384 (when (and
fb7dd5b9 385 (supertype (find-type-number class))
386 (not (eq (class-name super) (supertype (find-type-number class)))))
74821f75 387 (warn "Super class mismatch between CLOS and GObject for ~A"
388 class-name)))
389 (update-size class))
390 #-clisp(call-next-method))
1eaa1bd6 391
392
393(defmethod shared-initialize ((class ginstance-class) names &rest initargs)
74821f75 394 (declare (ignore names initargs))
1eaa1bd6 395 (call-next-method)
396 (when (class-finalized-p class)
397 (update-size class)))
398
4de90d10 399
21299acf 400(defmethod validate-superclass ((class ginstance-class) (super standard-class))
401 (subtypep (class-name super) 'ginstance))
402
560af5c5 403
93aa67db 404;;;; Superclass for wrapping types in the glib type system
560af5c5 405
406(eval-when (:compile-toplevel :load-toplevel :execute)
af338f4a 407 (defclass ginstance (ref-counted-object)
09f6e237 408 (;(class :allocation :alien :type pointer :offset 0)
409 )
410 (:metaclass proxy-class)
411 (:size #.(size-of 'pointer))))
560af5c5 412
74821f75 413(defun ref-type-number (location &optional offset)
414 (declare (ignore location offset)))
415
416(setf (symbol-function 'ref-type-number) (reader-function 'type-number))
417
895c9a9e 418(defun %type-number-of-ginstance (location)
74821f75 419 (let ((class (ref-pointer location)))
420 (ref-type-number class)))
560af5c5 421
74821f75 422(defmethod make-proxy-instance :around ((class ginstance-class) location
423 &rest initargs)
d168bafd 424 (declare (ignore class))
895c9a9e 425 (let ((class (labels ((find-known-class (type-number)
426 (or
427 (find-class (type-from-number type-number) nil)
428 (unless (zerop type-number)
429 (find-known-class (type-parent type-number))))))
430 (find-known-class (%type-number-of-ginstance location)))))
b929328d 431 ;; Note that changing the class argument must not alter "the
8958fa4a 432 ;; ordered set of applicable methods" as specified in the
433 ;; Hyperspec
d168bafd 434 (if class
8958fa4a 435 (apply #'call-next-method class location initargs)
436 (error "Object at ~A has an unkown type number: ~A"
437 location (%type-number-of-ginstance location)))))
438
560af5c5 439
d4b21b08 440;;;; Registering fundamental types
441
63752532 442(register-type 'nil "void")
d4b21b08 443(register-type 'pointer "gpointer")
444(register-type 'char "gchar")
445(register-type 'unsigned-char "guchar")
446(register-type 'boolean "gboolean")
d4b21b08 447(register-type 'int "gint")
73383a9e 448(register-type-alias 'integer 'int)
dfa4f314 449(register-type-alias 'fixnum 'int)
d4b21b08 450(register-type 'unsigned-int "guint")
451(register-type 'long "glong")
452(register-type 'unsigned-long "gulong")
453(register-type 'single-float "gfloat")
454(register-type 'double-float "gdouble")
4de90d10 455(register-type 'string "gchararray")
1d1ff9a5 456(register-type-alias 'pathname 'string)
d4b21b08 457
458
62f12808 459;;;; Introspection of type information
d4b21b08 460
e77e7713 461(defvar *derivable-type-info* (make-hash-table))
d4b21b08 462
62f12808 463(defun register-derivable-type (type id expander &optional dependencies)
d4b21b08 464 (register-type type id)
e77e7713 465 (let ((type-number (register-type type id)))
62f12808 466 (setf
467 (gethash type-number *derivable-type-info*)
468 (list expander dependencies))))
d4b21b08 469
4de90d10 470(defun find-type-info (type)
471 (dolist (super (cdr (type-hierarchy type)))
e77e7713 472 (let ((info (gethash super *derivable-type-info*)))
4de90d10 473 (return-if info))))
474
62f12808 475(defun expand-type-definition (type forward-p options)
476 (let ((expander (first (find-type-info type))))
477 (funcall expander (find-type-number type t) forward-p options)))
d4b21b08 478
74821f75 479
d4b21b08 480(defbinding type-parent (type) type-number
481 ((find-type-number type t) type-number))
482
483(defun supertype (type)
484 (type-from-number (type-parent type)))
485
337933d8 486(defbinding %type-interfaces (type) pointer
487 ((find-type-number type t) type-number)
488 (n-interfaces unsigned-int :out))
489
490(defun type-interfaces (type)
491 (multiple-value-bind (array length) (%type-interfaces type)
492 (unwind-protect
d168bafd 493 (map-c-vector 'list #'identity array 'type-number length)
337933d8 494 (deallocate-memory array))))
495
496(defun implements (type)
497 (mapcar #'type-from-number (type-interfaces type)))
498
d4b21b08 499(defun type-hierarchy (type)
500 (let ((type-number (find-type-number type t)))
501 (unless (= type-number 0)
502 (cons type-number (type-hierarchy (type-parent type-number))))))
503
504(defbinding (type-is-p "g_type_is_a") (type super) boolean
505 ((find-type-number type) type-number)
506 ((find-type-number super) type-number))
507
508(defbinding %type-children () pointer
509 (type-number type-number)
510 (num-children unsigned-int :out))
511
512(defun map-subtypes (function type &optional prefix)
513 (let ((type-number (find-type-number type t)))
514 (multiple-value-bind (array length) (%type-children type-number)
515 (unwind-protect
d168bafd 516 (map-c-vector
d4b21b08 517 'nil
518 #'(lambda (type-number)
519 (when (or
520 (not prefix)
dfa4f314 521 (string-prefix-p prefix (find-foreign-type-name type-number)))
d4b21b08 522 (funcall function type-number))
523 (map-subtypes function type-number prefix))
524 array 'type-number length)
525 (deallocate-memory array)))))
526
527(defun find-types (prefix)
528 (let ((type-list nil))
e77e7713 529 (maphash
530 #'(lambda (type-number expander)
531 (declare (ignore expander))
532 (map-subtypes
533 #'(lambda (type-number)
534 (pushnew type-number type-list))
535 type-number prefix))
536 *derivable-type-info*)
d4b21b08 537 type-list))
538
74821f75 539(defun find-type-dependencies (type &optional options)
540 (let ((find-dependencies (second (find-type-info type))))
541 (when find-dependencies
542 (remove-duplicates
543 (mapcar #'find-type-number
544 (funcall find-dependencies (find-type-number type t) options))))))
545
546
547;; The argument is a list where each elements is on the form
584285fb 548;; (type . dependencies). This function will not handle indirect
8f12a0ff 549;; dependencies and types depending on them selves.
74821f75 550(defun sort-types-topologicaly (unsorted)
551 (flet ((depend-p (type1)
552 (find-if #'(lambda (type2)
553 (and
554 ;; If a type depends a subtype it has to be
555 ;; forward defined
556 (not (type-is-p (car type2) (car type1)))
557 (find (car type2) (cdr type1))))
558 unsorted)))
559 (let ((sorted
560 (loop
561 while unsorted
562 nconc (multiple-value-bind (sorted remaining)
563 (delete-collect-if
564 #'(lambda (type)
565 (or (not (cdr type)) (not (depend-p type))))
566 unsorted)
567 (cond
568 ((not sorted)
569 ;; We have a circular dependency which have to
570 ;; be resolved
571 (let ((selected
572 (find-if
573 #'(lambda (type)
574 (every
575 #'(lambda (dep)
576 (or
577 (not (type-is-p (car type) dep))
578 (not (find dep unsorted :key #'car))))
579 (cdr type)))
580 unsorted)))
581 (unless selected
582 (error "Couldn't resolve circular dependency"))
583 (setq unsorted (delete selected unsorted))
584 (list selected)))
585 (t
586 (setq unsorted remaining)
587 sorted))))))
588
589 ;; Mark types which have to be forward defined
590 (loop
591 for tmp on sorted
592 as (type . dependencies) = (first tmp)
593 collect (cons type (and
594 dependencies
595 (find-if #'(lambda (type)
596 (find (car type) dependencies))
597 (rest tmp))
598 t))))))
d4b21b08 599
600
fb7dd5b9 601(defun expand-type-definitions (type-list &optional args)
dfa4f314 602 (flet ((type-options (type-number)
603 (let ((name (find-foreign-type-name type-number)))
4de90d10 604 (cdr (assoc name args :test #'string=)))))
d4b21b08 605
fb7dd5b9 606 (setq type-list
607 (delete-if
608 #'(lambda (type-number)
609 (let ((name (find-foreign-type-name type-number)))
610 (or
611 (getf (type-options type-number) :ignore)
612 (find-if
613 #'(lambda (options)
614 (and
615 (string-prefix-p (first options) name)
616 (getf (cdr options) :ignore-prefix)
617 (not (some
618 #'(lambda (exception)
619 (string= name exception))
620 (getf (cdr options) :except)))))
621 args))))
622 type-list))
623
624 (dolist (type-number type-list)
625 (let ((name (find-foreign-type-name type-number)))
626 (register-type
627 (getf (type-options type-number) :type (default-type-name name))
628 (register-type-as type-number))))
629
630 ;; This is needed for some unknown reason to get type numbers right
631 (mapc #'find-type-dependencies type-list)
632
633 (let ((sorted-type-list
634 #+clisp (mapcar #'list type-list)
635 #-clisp
636 (sort-types-topologicaly
637 (mapcar
638 #'(lambda (type)
639 (cons type (find-type-dependencies type (type-options type))))
640 type-list))))
641 `(progn
642 ,@(mapcar
643 #'(lambda (pair)
644 (destructuring-bind (type . forward-p) pair
645 (expand-type-definition type forward-p (type-options type))))
646 sorted-type-list)
647 ,@(mapcar
648 #'(lambda (pair)
649 (destructuring-bind (type . forward-p) pair
650 (when forward-p
651 (expand-type-definition type nil (type-options type)))))
652 sorted-type-list)))))
653
654(defun expand-types-with-prefix (prefix args)
655 (expand-type-definitions (find-types prefix) args))
656
657(defun expand-types-in-library (system library args)
658 (let* ((filename (library-filename system library))
659 (types (loop
660 for (type-init . %filename) in *type-initializers*
661 when (equal filename %filename)
662 collect (funcall type-init))))
663 (expand-type-definitions types args)))
664
665(defun list-types-in-library (system library)
666 (let ((filename (library-filename system library)))
667 (loop
668 for (type-init . %filename) in *type-initializers*
669 when (equal filename %filename)
670 collect type-init)))
e77e7713 671
d4b21b08 672(defmacro define-types-by-introspection (prefix &rest args)
fb7dd5b9 673 (expand-types-with-prefix prefix args))
21299acf 674
74821f75 675(defexport define-types-by-introspection (prefix &rest args)
fb7dd5b9 676 (list-autoexported-symbols (expand-types-with-prefix prefix args)))
677
678(defmacro define-types-in-library (system library &rest args)
679 (expand-types-in-library system library args))
680
681(defexport define-types-in-library (system library &rest args)
682 (list-autoexported-symbols (expand-types-in-library system library args)))
74821f75 683
21299acf 684
685;;;; Initialize all non static types in GObject
686
8f12a0ff 687(init-types-in-library glib "libgobject-2.0")