chiark - git - mdw - 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.67 2008-12-10 02:54:17 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)
 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))
 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)))
 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 (pushnew 'reinitialize-all-types
 169   #+cmu *after-save-initializations*
 170   #+sbcl *init-hooks*
 171   #+clisp custom:*init-hooks*)
 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)
 179   (etypecase type
 180     (integer type)
 181     (string (type-number-from-glib-name type error-p))
 182     (symbol
 183      (or
 184       (gethash type *lisp-type-to-type-number*)
 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*)))
 189       (and error-p (error "Type not registered: ~A" type))))
 190     (class
 191      (find-type-number (class-name type) error-p))))
 192
 193 (defun type-from-number (type-number &optional error)
 194   (multiple-value-bind (type found)
 195       (gethash type-number *type-number-to-lisp-type*)
 196     (if found
 197         type
 198       (let ((name (find-foreign-type-name type-number)))
 199         (cond
 200          ((and name (not (= (type-number-from-glib-name name nil) type-number)))
 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)))))))
 208
 209 (defbinding (find-foreign-type-name "g_type_name") (type) (copy-of string)
 210   ((find-type-number type t) type-number))
 211
 212 (defun type-number-of (object)
 213   (find-type-number (type-of object) t))
 214
 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
 223 (eval-when (:compile-toplevel :load-toplevel :execute)
 224   (defvar *type-initializers* ())
 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
 233   (defun %find-types-in-library (pathname prefixes ignore)
 234     (let ((outname (tmpname "types")))
 235       (unwind-protect
 236           (let ((asdf::*verbose-out* nil))
 237             #-win32
 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)))))
 280
 281
 282 (defun car-eq-p (ob1 ob2)
 283   (eq (car ob1) (car ob2)))
 284
 285 (defmacro init-types-in-library (system library &key prefix ignore)
 286   (let* ((filename (library-filename system library))
 287          (names (%find-types-in-library filename prefix ignore)))
 288     `(progn
 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))))
 297
 298 (defun find-type-init-function (type-number)
 299   (loop
 300    for (type-init) in *type-initializers*
 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)))
 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
 315
 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
 332   (parent-type type-number)
 333   (name string)
 334   (info type-info)
 335   (0 unsigned-int))
 336
 337 (defun register-new-type (type parent &optional foreign-name)
 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
 343               (or foreign-name (default-alien-type-name type))
 344               (make-instance 'type-info :class-size class-size :instance-size instance-size))))
 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))))
 349
 350
 351
 352 ;;;; Metaclass for subclasses of ginstance
 353
 354 (eval-when (:compile-toplevel :load-toplevel :execute)
 355   (defclass ginstance-class (proxy-class)
 356     ((gtype :initarg :gtype :initform nil :reader ginstance-class-gtype))))
 357
 358
 359 (defun update-size (class)
 360   (let ((type-number (find-type-number class)))
 361     (cond
 362      ((not (foreign-size-p class))
 363       (setf (foreign-size class) (type-instance-size type-number)))
 364      ((and
 365        (foreign-size-p class)
 366        (not (= (type-instance-size type-number) (foreign-size class))))
 367       (warn "Size mismatch for class ~A" class)))))
 368
 369
 370 (defmethod finalize-inheritance ((class ginstance-class))
 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))
 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))))
 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
 393 (defmethod shared-initialize ((class ginstance-class) names &rest initargs)
 394   (declare (ignore names initargs))
 395   (call-next-method)
 396   (when (class-finalized-p class)
 397     (update-size class)))
 398
 399
 400 (defmethod validate-superclass ((class ginstance-class) (super standard-class))
 401   (subtypep (class-name super) 'ginstance))
 402
 403
 404 ;;;; Superclass for wrapping types in the glib type system
 405
 406 (eval-when (:compile-toplevel :load-toplevel :execute)
 407   (defclass ginstance (ref-counted-object)
 408     (;(class :allocation :alien :type pointer :offset 0)
 409      )
 410     (:metaclass proxy-class)
 411     (:size #.(size-of 'pointer))))
 412
 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
 418 (defun %type-number-of-ginstance (location)
 419   (let ((class (ref-pointer location)))
 420     (ref-type-number class)))
 421
 422 (defmethod make-proxy-instance :around ((class ginstance-class) location
 423                                         &rest initargs)
 424   (declare (ignore class))
 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)))))
 431     ;; Note that changing the class argument must not alter "the
 432     ;; ordered set of applicable methods" as specified in the
 433     ;; Hyperspec
 434     (if class
 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
 439
 440 ;;;; Registering fundamental types
 441
 442 (register-type 'nil "void")
 443 (register-type 'pointer "gpointer")
 444 (register-type 'char "gchar")
 445 (register-type 'unsigned-char "guchar")
 446 (register-type 'boolean "gboolean")
 447 (register-type 'int "gint")
 448 (register-type-alias 'integer 'int)
 449 (register-type-alias 'fixnum 'int)
 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")
 455 (register-type 'string "gchararray")
 456 (register-type-alias 'pathname 'string)
 457
 458
 459 ;;;; Introspection of type information
 460
 461 (defvar *derivable-type-info* (make-hash-table))
 462
 463 (defun register-derivable-type (type id expander &optional dependencies)
 464   (register-type type id)
 465   (let ((type-number (register-type type id)))
 466     (setf
 467      (gethash type-number *derivable-type-info*)
 468      (list expander dependencies))))
 469
 470 (defun find-type-info (type)
 471   (dolist (super (cdr (type-hierarchy type)))
 472     (let ((info (gethash super *derivable-type-info*)))
 473       (return-if info))))
 474
 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)))
 478
 479
 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
 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
 493         (map-c-vector 'list #'identity array 'type-number length)
 494       (deallocate-memory array))))
 495
 496 (defun implements (type)
 497   (mapcar #'type-from-number (type-interfaces type)))
 498
 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
 516           (map-c-vector
 517            'nil
 518            #'(lambda (type-number)
 519                (when (or
 520                       (not prefix)
 521                       (string-prefix-p prefix (find-foreign-type-name type-number)))
 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))
 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*)
 537     type-list))
 538
 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
 548 ;; (type . dependencies). This function will not handle indirect
 549 ;; dependencies and types depending on them selves.
 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))))))
 599
 600
 601 (defun expand-type-definitions (type-list &optional args)
 602   (flet ((type-options (type-number)
 603            (let ((name (find-foreign-type-name type-number)))
 604              (cdr (assoc name args :test #'string=)))))
 605
 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)))
 671
 672 (defmacro define-types-by-introspection (prefix &rest args)
 673   (expand-types-with-prefix prefix args))
 674
 675 (defexport define-types-by-introspection (prefix &rest args)
 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)))
 683
 684
 685 ;;;; Initialize all non static types in GObject
 686
 687 (init-types-in-library glib "libgobject-2.0")