mdw@git.distorted.org.uk Git - clg/blob - glib/gtype.lisp

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