glib/gobject.generating.lisp

   1 (in-package :gobject)
   2
   3 (defvar *lisp-name-package* nil
   4   "For internal use (used by class definitions generator). Specifies the package in which symbols are interned.")
   5 (defvar *strip-prefix* "")
   6 (defvar *lisp-name-exceptions* nil)
   7 (defvar *generation-exclusions* nil)
   8 (defvar *known-interfaces* (make-hash-table :test 'equal))
   9 (defvar *additional-properties* nil)
  10 (defvar *generated-types* nil)
  11
  12 (defun name->supplied-p (name)
  13   (make-symbol (format nil "~A-SUPPLIED-P" (symbol-name name))))
  14
  15 (defstruct property name accessor-name readable writable)
  16
  17 (defstruct (gobject-property (:include property)) gname type)
  18
  19 (defstruct (cffi-property (:include property)) type reader writer)
  20
  21 (defmethod make-load-form ((object gobject-property) &optional env)
  22   (declare (ignore env))
  23   `(make-gobject-property :name ',(property-name object)
  24                           :accessor-name ',(property-accessor-name object)
  25                           :readable ',(property-readable object)
  26                           :writable ',(property-writable object)
  27                           :gname ',(gobject-property-gname object)
  28                           :type ',(gobject-property-type object)))
  29
  30 (defmethod make-load-form ((object cffi-property) &optional env)
  31   (declare (ignore env))
  32   `(make-cffi-property :name ',(property-name object)
  33                        :accessor-name ',(property-accessor-name object)
  34                        :readable ',(property-readable object)
  35                        :writable ',(property-writable object)
  36                        :type ',(cffi-property-type object)
  37                        :reader ',(cffi-property-reader object)
  38                        :writer ',(cffi-property-writer object)))
  39
  40 (defun parse-gobject-property (spec)
  41   (destructuring-bind (name accessor-name gname type readable writable) spec
  42       (make-gobject-property :name name
  43                              :accessor-name accessor-name
  44                              :gname gname
  45                              :type type
  46                              :readable readable
  47                              :writable writable)))
  48
  49 (defun parse-cffi-property (spec)
  50   (destructuring-bind (name accessor-name type reader writer) spec
  51     (make-cffi-property :name name
  52                         :accessor-name accessor-name
  53                         :type type
  54                         :reader reader
  55                         :writer writer
  56                         :readable (not (null reader))
  57                         :writable (not (null writer)))))
  58
  59 (defun parse-property (spec)
  60   (cond
  61     ((eq (first spec) :cffi) (parse-cffi-property (rest spec)))
  62     (t (parse-gobject-property spec))))
  63
  64 (defun property->method-arg (property)
  65   (when (or (gobject-property-p property)
  66             (and (cffi-property-p property)
  67                  (property-writable property)))
  68     (let ((name (property-name property)))
  69       `(,name nil ,(name->supplied-p name)))))
  70
  71 (defun gobject-property->arg-push (property)
  72   (assert (typep property 'gobject-property))
  73   (with-slots (name type gname) property
  74     `(when ,(name->supplied-p name)
  75        (push ,gname arg-names)
  76        (push ,type arg-types)
  77        (push ,name arg-values))))
  78
  79 (defun cffi-property->initarg (property)
  80   (assert (typep property 'cffi-property))
  81   (when (property-writable property)
  82     (with-slots (accessor-name name type writer) property
  83       `(when ,(name->supplied-p name)
  84          (setf (,accessor-name object) ,name)))))
  85
  86 (defun accessor-name (class-name property-name)
  87   (intern (format nil "~A-~A" (symbol-name class-name)
  88                   (lispify-name property-name))
  89           *lisp-name-package*))
  90
  91 (defgeneric property->reader (class property))
  92 (defgeneric property->writer (class property))
  93
  94 (defmethod property->reader (class (property gobject-property))
  95   (with-slots (accessor-name type gname) property
  96    `(defmethod ,accessor-name ((object ,class))
  97       (g-object-call-get-property object ,gname ,type))))
  98
  99 (defmethod property->reader (class (property cffi-property))
 100   (with-slots (accessor-name type reader) property
 101     (etypecase reader
 102       (string `(defmethod ,accessor-name ((object ,class))
 103                  (foreign-funcall ,reader g-object object ,type)))
 104       (symbol `(defmethod ,accessor-name ((object ,class))
 105                  (funcall ',reader object))))))
 106
 107 (defmethod property->writer (class (property gobject-property))
 108   (with-slots (accessor-name type gname) property
 109     `(defmethod (setf ,accessor-name) (new-value (object ,class))
 110        (g-object-call-set-property object ,gname new-value ,type)
 111        new-value)))
 112
 113 (defmethod property->writer (class (property cffi-property))
 114   (with-slots (accessor-name type writer) property
 115     (etypecase writer
 116       (string `(defmethod (setf ,accessor-name) (new-value (object ,class))
 117                  (foreign-funcall ,writer g-object object ,type new-value :void)
 118                  new-value))
 119       (symbol `(defmethod (setf ,accessor-name) (new-value (object ,class))
 120                  (funcall ',writer object new-value)
 121                  new-value)))))
 122
 123 (defun property->accessors (class property export)
 124   (append (when (property-readable property)
 125             (list (property->reader class property)))
 126           (when (property-writable property)
 127             (list (property->writer class property)))
 128           (when export
 129             (list `(export ',(property-accessor-name property)
 130                            (find-package ,(package-name (symbol-package (property-accessor-name property)))))))))
 131
 132 (defun interface->lisp-class-name (interface)
 133   (etypecase interface
 134     (symbol interface)
 135     (string (or (gethash interface *known-interfaces*)
 136                 (error "Unknown interface ~A" interface)))))
 137
 138 (defun type-initializer-call (type-initializer)
 139   (etypecase type-initializer
 140     (string `(if (foreign-symbol-pointer ,type-initializer)
 141                  (foreign-funcall-pointer
 142                   (foreign-symbol-pointer ,type-initializer) ()
 143                   g-type)
 144                  (warn "Type initializer '~A' is not available" ,type-initializer)))
 145     (symbol `(funcall ',type-initializer))))
 146
 147 (defun meta-property->slot (class-name property)
 148   `(,(property-name property)
 149      :allocation ,(if (gobject-property-p property) :gobject-property :gobject-fn)
 150      :g-property-type ,(if (gobject-property-p property) (gobject-property-type property) (cffi-property-type property))
 151      :accessor ,(intern (format nil "~A-~A" (symbol-name class-name) (property-name property)) (symbol-package class-name))
 152      ,@(when (if (gobject-property-p property)
 153                  t
 154                  (not (null (cffi-property-writer property))))
 155              `(:initarg
 156                ,(intern (string-upcase (property-name property)) (find-package :keyword))))
 157      ,@(if (gobject-property-p property)
 158            `(:g-property-name ,(gobject-property-gname property))
 159            `(:g-getter ,(cffi-property-reader property)
 160                        :g-setter ,(cffi-property-writer property)))))
 161
 162 (defmacro define-g-object-class (g-type-name name
 163                                  (&key (superclass 'g-object)
 164                                        (export t)
 165                                        interfaces
 166                                        type-initializer)
 167                                  (&rest properties))
 168   (setf properties (mapcar #'parse-property properties))
 169   `(progn
 170      (defclass ,name (,@(when (and superclass (not (eq superclass 'g-object))) (list superclass)) ,@(mapcar #'interface->lisp-class-name interfaces))
 171        (,@(mapcar (lambda (property) (meta-property->slot name property)) properties))
 172        (:metaclass gobject-class)
 173        (:g-type-name . ,g-type-name)
 174        ,@(when type-initializer
 175                (list `(:g-type-initializer . ,type-initializer))))
 176      ,@(when export
 177              (cons `(export ',name (find-package ,(package-name (symbol-package name))))
 178                    (mapcar (lambda (property)
 179                              `(export ',(intern (format nil "~A-~A" (symbol-name name) (property-name property)) (symbol-package name))
 180                                       (find-package ,(package-name (symbol-package name)))))
 181                            properties)))))
 182
 183 (defmacro define-g-interface (g-type-name name (&key (export t) type-initializer) &body properties)
 184   (setf properties (mapcar #'parse-property properties))
 185   `(progn
 186      (defclass ,name ()
 187        (,@(mapcar (lambda (property) (meta-property->slot name property)) properties))
 188        (:metaclass gobject-class)
 189        (:g-type-name . ,g-type-name)
 190        (:g-interface-p . t)
 191        ,@(when type-initializer
 192                (list `(:g-type-initializer . ,type-initializer))))
 193      ,@(when export
 194              (cons `(export ',name (find-package ,(package-name (symbol-package name))))
 195                    (mapcar (lambda (property)
 196                              `(export ',(intern (format nil "~A-~A" (symbol-name name) (property-name property)) (symbol-package name))
 197                                       (find-package ,(package-name (symbol-package name)))))
 198                            properties)))
 199      (eval-when (:compile-toplevel :load-toplevel :execute)
 200        (setf (gethash ,g-type-name *known-interfaces*) ',name))))
 201
 202 (defun starts-with (name prefix)
 203   (and prefix (> (length name) (length prefix)) (string= (subseq name 0 (length prefix)) prefix)))
 204
 205 (defun strip-start (name prefix)
 206   (if (starts-with name prefix)
 207       (subseq name (length prefix))
 208       name))
 209
 210 (defun lispify-name (name)
 211   (with-output-to-string (stream)
 212     (loop for c across (strip-start name *strip-prefix*)
 213        for firstp = t then nil
 214        do (when (and (not firstp) (upper-case-p c)) (write-char #\- stream))
 215        do (write-char (char-upcase c) stream))))
 216
 217 (defun g-name->name (name)
 218   (or (second (assoc name *lisp-name-exceptions* :test 'equal))
 219       (intern (string-upcase (lispify-name name)) *lisp-name-package*)))
 220
 221 (defun property->property-definition (class-name property)
 222   (let ((name (g-name->name (g-class-property-definition-name property)))
 223         (accessor-name (accessor-name class-name (g-class-property-definition-name property)))
 224         (g-name (g-class-property-definition-name property))
 225         (type (gtype-name (g-class-property-definition-type property)))
 226         (readable (g-class-property-definition-readable property))
 227         (writable (and (g-class-property-definition-writable property)
 228                        (not (g-class-property-definition-constructor-only property)))))
 229     `(,name ,accessor-name ,g-name ,type ,readable ,writable)))
 230
 231 (defun probable-type-init-name (type-name)
 232   (with-output-to-string (stream)
 233     (iter (for c in-string type-name)
 234           (for prev-c previous c)
 235           (when (and (not (first-iteration-p))
 236                      (upper-case-p c)
 237                      (not (upper-case-p prev-c))
 238                      (not (char= prev-c #\_)))
 239             (write-char #\_ stream))
 240           (write-char (char-downcase c) stream))
 241     (write-string "_get_type" stream)))
 242
 243 (defclass print-readtime-condition ()
 244   ((condition :initarg :condition)))
 245
 246 (defmethod print-object ((o print-readtime-condition) stream)
 247   (format stream "#~A" (slot-value o 'condition)))
 248
 249 (defun get-g-class-definition (type &optional lisp-name-package)
 250   (when (and (stringp type) (null (ignore-errors (gtype type))))
 251     (let ((type-init-name (probable-type-init-name type)))
 252       (when (foreign-symbol-pointer type-init-name)
 253         (foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
 254   (when *generated-types*
 255     (setf (gethash (gtype-name (gtype type)) *generated-types*) t))
 256   (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
 257          (g-type (gtype type))
 258          (g-name (gtype-name g-type))
 259          (name (g-name->name g-name))
 260          (superclass-g-type (g-type-parent g-type))
 261          (superclass-name (g-name->name (gtype-name superclass-g-type)))
 262          (interfaces (g-type-interfaces g-type))
 263          (properties (class-properties g-type))
 264          (type-init-name (probable-type-init-name g-name))
 265          (own-properties
 266           (sort (copy-list (remove g-type properties :key #'g-class-property-definition-owner-type :test-not #'g-type=))
 267                 #'string< :key #'g-class-property-definition-name)))
 268     `(define-g-object-class ,g-name ,name
 269          (:superclass ,superclass-name
 270                       :export t
 271                       :interfaces (,@(sort (mapcar #'gtype-name interfaces) 'string<))
 272                       ,@(when (and (foreign-symbol-pointer type-init-name)
 273                                    (not (null-pointer-p (foreign-symbol-pointer type-init-name))))
 274                               `(:type-initializer ,type-init-name)))
 275        (,@(mapcar (lambda (property)
 276                     (property->property-definition name property))
 277                   own-properties)
 278           ,@(mapcan (lambda (property-definition)
 279                       (if (eq :cond (car property-definition))
 280                           (list (make-instance 'print-readtime-condition :condition (cadr property-definition)) (cddr property-definition))
 281                           (list property-definition)))
 282                     (cdr (find g-name *additional-properties* :key 'car :test 'string=)))))))
 283
 284 (defun get-g-interface-definition (interface &optional lisp-name-package)
 285   (when (and (stringp interface) (null (ignore-errors (gtype interface))))
 286     (let ((type-init-name (probable-type-init-name interface)))
 287       (when (foreign-symbol-pointer type-init-name)
 288         (foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
 289   (when *generated-types*
 290     (setf (gethash (gtype-name (gtype interface)) *generated-types*) t))
 291   (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
 292          (type (gtype interface))
 293          (g-name (gtype-name type))
 294          (name (g-name->name g-name))
 295          (properties (sort (copy-list (interface-properties type))
 296                            #'string< :key #'g-class-property-definition-name))
 297          (probable-type-initializer (probable-type-init-name g-name)))
 298     `(define-g-interface ,g-name ,name
 299          (:export t
 300                   ,@(when (foreign-symbol-pointer probable-type-initializer)
 301                           `(:type-initializer ,probable-type-initializer)))
 302        ,@(append (mapcar (lambda (property)
 303                            (property->property-definition name property))
 304                          properties)
 305                  (mapcan (lambda (property-definition)
 306                            (if (eq :cond (car property-definition))
 307                                (list (make-instance 'print-readtime-condition :condition (cadr property-definition)) (cddr property-definition))
 308                                (list property-definition)))
 309                          (cdr (find g-name *additional-properties* :key 'car :test 'string=)))))))
 310
 311 (defun get-g-class-definitions-for-root-1 (type)
 312   (unless (member (gtype type) *generation-exclusions* :test 'g-type=)
 313     (iter (when (first-iteration-p)
 314             (unless (and *generated-types*
 315                          (gethash (gtype-name (gtype type)) *generated-types*))
 316               (appending (list (get-g-class-definition type)))))
 317           (for child-type in (sort (copy-list (g-type-children type)) #'string< :key #'gtype-name))
 318           (appending (get-g-class-definitions-for-root-1 child-type)))))
 319
 320 (defun get-g-class-definitions-for-root (type)
 321   (setf type (gtype type))
 322   (get-g-class-definitions-for-root-1 type))
 323
 324 (defvar *referenced-types*)
 325
 326 (defun class-or-interface-properties (type)
 327   (setf type (gtype type))
 328   (cond
 329     ((g-type= (g-type-fundamental type) (gtype +g-type-object+)) (class-properties type))
 330     ((g-type= (g-type-fundamental type) (gtype +g-type-interface+)) (interface-properties type))))
 331
 332 (defun get-shallow-referenced-types (type)
 333   (setf type (gtype type))
 334   (remove-duplicates (sort (loop
 335                               for property in (class-or-interface-properties type)
 336                               when (g-type= type (g-class-property-definition-owner-type property))
 337                               collect (g-class-property-definition-type property))
 338                            #'string<
 339                            :key #'gtype-name)
 340                      :test 'equal))
 341
 342 (defun get-referenced-types-1 (type)
 343   (setf type (gtype type))
 344   (loop
 345      for property-type in (sort (copy-list (get-shallow-referenced-types type)) #'string> :key #'gtype-name)
 346      do (pushnew property-type *referenced-types* :test 'g-type=))
 347   (loop
 348      for type in (sort (copy-list (g-type-children type)) #'string< :key #'gtype-name)
 349      do (get-referenced-types-1 type)))
 350
 351 (defun get-referenced-types (root-type)
 352   (let (*referenced-types*)
 353     (get-referenced-types-1 (gtype root-type))
 354     *referenced-types*))
 355
 356 (defun filter-types-by-prefix (types prefix)
 357   (remove-if-not
 358    (lambda (type)
 359      (starts-with (gtype-name (gtype type)) prefix))
 360    types))
 361
 362 (defun filter-types-by-fund-type (types fund-type)
 363   (setf fund-type (gtype fund-type))
 364   (remove-if-not
 365    (lambda (type)
 366      (equal (g-type-fundamental (gtype type)) fund-type))
 367    types))
 368
 369 (defmacro define-g-enum (g-name name (&key (export t) type-initializer) &body values)
 370   "Defines a GEnum type for enumeration. Generates corresponding CFFI definition.
 371
 372 Example:
 373 @begin{pre}
 374 \(define-g-enum \"GdkGrabStatus\" grab-status () :success :already-grabbed :invalid-time :not-viewable :frozen)
 375 \(define-g-enum \"GdkExtensionMode\" gdk-extension-mode (:export t :type-initializer \"gdk_extension_mode_get_type\")
 376   (:none 0) (:all 1) (:cursor 2))
 377 @end{pre}
 378 @arg[g-name]{a string. Specifies the GEnum name}
 379 @arg[name]{a symbol. Names the enumeration type.}
 380 @arg[export]{a boolean. If true, @code{name} will be exported.}
 381 @arg[type-initializer]{a @code{NIL} or a string or a function designator.
 382
 383 If non-@code{NIL}, specifies the function that initializes the type: string specifies a C function that returns the GType value and function designator specifies the Lisp function.}
 384 @arg[values]{values for enum. Each value is a keyword or a list @code{(keyword integer-value)}. @code{keyword} corresponds to Lisp value of enumeration, and @code{integer-value} is an C integer for enumeration item. If @code{integer-value} is not specified, it is generated automatically (see CFFI manual)}"
 385   `(progn
 386      (defcenum ,name ,@values)
 387      (register-enum-type ,g-name ',name)
 388      ,@(when export
 389              (list `(export ',name (find-package ,(package-name (symbol-package name))))))
 390      ,@(when type-initializer
 391              (list `(at-init () ,(type-initializer-call type-initializer))))))
 392
 393 (defun enum-value->definition (enum-value)
 394   (let ((value-name (intern (lispify-name (enum-item-nick enum-value))
 395                             (find-package :keyword)))
 396         (numeric-value (enum-item-value enum-value)))
 397     `(,value-name ,numeric-value)))
 398
 399 (defun get-g-enum-definition (type &optional lisp-name-package)
 400   (when (and (stringp type) (null (gtype type)))
 401     (let ((type-init-name (probable-type-init-name type)))
 402       (when (foreign-symbol-pointer type-init-name)
 403         (foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
 404   (when *generated-types*
 405     (setf (gethash (gtype-name (gtype type)) *generated-types*) t))
 406   (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
 407          (g-type (gtype type))
 408          (g-name (gtype-name g-type))
 409          (name (g-name->name g-name))
 410          (items (get-enum-items g-type))
 411          (probable-type-initializer (probable-type-init-name g-name)))
 412     `(define-g-enum ,g-name ,name
 413          (:export t
 414                   ,@(when (foreign-symbol-pointer probable-type-initializer)
 415                           (list :type-initializer
 416                                 probable-type-initializer)))
 417        ,@(mapcar #'enum-value->definition items))))
 418
 419 (defmacro define-g-flags (g-name name (&key (export t) type-initializer) &body values)
 420   "Defines a GFlags type for enumeration that can combine its values. Generates corresponding CFFI definition. Values of this type are lists of keywords that are combined.
 421
 422 Example:
 423 @begin{pre}
 424 \(define-g-flags \"GdkWindowState\" window-state ()
 425   (:withdrawn 1)
 426   (:iconified 2) (:maximized 4) (:sticky 8) (:fullscreen 16)
 427   (:above 32) (:below 64))
 428 @end{pre}
 429 @arg[g-name]{a string. Specifies the GEnum name}
 430 @arg[name]{a symbol. Names the enumeration type.}
 431 @arg[export]{a boolean. If true, @code{name} will be exported.}
 432 @arg[type-initializer]{a @code{NIL} or a string or a function designator.
 433
 434 If non-@code{NIL}, specifies the function that initializes the type: string specifies a C function that returns the GType value and function designator specifies the Lisp function.}
 435 @arg[values]{values for flags. Each value is a keyword or a list @code{(keyword integer-value)}. @code{keyword} corresponds to Lisp value of a flag, and @code{integer-value} is an C integer for flag. If @code{integer-value} is not specified, it is generated automatically (see CFFI manual)}"
 436   `(progn
 437      (defbitfield ,name ,@values)
 438      (register-flags-type ,g-name ',name)
 439      ,@(when export
 440              (list `(export ',name (find-package ,(package-name (symbol-package name))))))
 441      ,@(when type-initializer
 442              (list `(at-init () ,(type-initializer-call type-initializer))))))
 443
 444 (defun flags-value->definition (flags-value)
 445   (let ((value-name (intern (lispify-name (flags-item-nick flags-value))
 446                             (find-package :keyword)))
 447         (numeric-value (flags-item-value flags-value)))
 448     `(,value-name ,numeric-value)))
 449
 450 (defun get-g-flags-definition (type &optional lisp-name-package)
 451   (when (and (stringp type) (null (gtype type)))
 452     (let ((type-init-name (probable-type-init-name type)))
 453       (when (foreign-symbol-pointer type-init-name)
 454         (foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
 455   (when *generated-types*
 456     (setf (gethash (gtype-name (gtype type)) *generated-types*) t))
 457   (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
 458          (g-type (gtype type))
 459          (g-name (gtype-name g-type))
 460          (name (g-name->name g-name))
 461          (items (get-flags-items g-type))
 462          (probable-type-initializer (probable-type-init-name g-name)))
 463     `(define-g-flags ,g-name ,name
 464          (:export t
 465                   ,@(when (foreign-symbol-pointer probable-type-initializer)
 466                           (list :type-initializer
 467                                 probable-type-initializer)))
 468        ,@(mapcar #'flags-value->definition items))))
 469
 470 (defun maybe-call-type-init (type)
 471   (when (and (stringp type) (null (gtype type)))
 472     (let ((type-init-name (probable-type-init-name type)))
 473       (when (foreign-symbol-pointer type-init-name)
 474         (foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int)))))
 475
 476 (defun get-g-type-definition (type &optional lisp-name-package)
 477   (maybe-call-type-init type)
 478   (cond
 479     ((g-type-is-a type (gtype +g-type-enum+)) (get-g-enum-definition type lisp-name-package))
 480     ((g-type-is-a type (gtype +g-type-flags+)) (get-g-flags-definition type lisp-name-package))
 481     ((g-type-is-a type (gtype +g-type-interface+)) (get-g-interface-definition type lisp-name-package))
 482     ((g-type-is-a type (gtype +g-type-object+)) (get-g-class-definition type lisp-name-package))
 483     (t (error "Do not know how to automatically generate type definition for ~A type ~A"
 484               (gtype-name (g-type-fundamental type))
 485               (or (ignore-errors (gtype-name (gtype type))) type)))))
 486
 487 (defun generate-types-hierarchy-to-file (file root-type &key include-referenced prefix package exceptions prologue interfaces enums flags objects exclusions additional-properties)
 488   (if (not (streamp file))
 489       (with-open-file (stream file :direction :output :if-exists :supersede)
 490         (generate-types-hierarchy-to-file stream root-type
 491                                           :prefix prefix
 492                                           :package package
 493                                           :exceptions exceptions
 494                                           :prologue prologue
 495                                           :include-referenced include-referenced
 496                                           :interfaces interfaces
 497                                           :enums enums
 498                                           :flags flags
 499                                           :objects objects
 500                                           :exclusions exclusions
 501                                           :additional-properties additional-properties))
 502       (let* ((*generation-exclusions* (mapcar #'gtype exclusions))
 503              (*lisp-name-package* (or package *package*))
 504              (*package* *lisp-name-package*)
 505              (*strip-prefix* (or prefix ""))
 506              (*lisp-name-exceptions* exceptions)
 507              (*print-case* :downcase)
 508              (*additional-properties* additional-properties)
 509              (*generated-types* (make-hash-table :test 'equalp))
 510              (referenced-types (and include-referenced
 511                                     (filter-types-by-prefix
 512                                      (get-referenced-types root-type)
 513                                      prefix))))
 514         (setf exclusions (mapcar #'gtype exclusions))
 515         (when prologue
 516           (write-string prologue file)
 517           (terpri file))
 518         (when include-referenced
 519           (loop
 520              for interface in interfaces
 521              do (loop
 522                    for referenced-type in (get-shallow-referenced-types interface)
 523                    do (pushnew referenced-type referenced-types :test 'g-type=)))
 524           (loop
 525              for object in objects
 526              do (loop
 527                    for referenced-type in (get-shallow-referenced-types object)
 528                    do (pushnew referenced-type referenced-types :test 'g-type=)))
 529           (loop
 530              for enum-type in (filter-types-by-fund-type
 531                                referenced-types "GEnum")
 532              for def = (get-g-enum-definition enum-type)
 533              unless (member enum-type exclusions :test 'g-type=)
 534              do (format file "~S~%~%" def))
 535
 536           (loop
 537              for flags-type in (filter-types-by-fund-type
 538                                 referenced-types "GFlags")
 539              for def = (get-g-flags-definition flags-type)
 540              unless (member flags-type exclusions :test 'g-type=)
 541              do (format file "~S~%~%" def)))
 542         (loop
 543            with auto-enums = (and include-referenced
 544                                   (filter-types-by-fund-type
 545                                    referenced-types "GEnum"))
 546            for enum in enums
 547            for def = (get-g-enum-definition enum)
 548            unless (find enum auto-enums :test 'g-type=)
 549            do (format file "~S~%~%" def))
 550         (loop
 551            with auto-flags = (and include-referenced
 552                                   (filter-types-by-fund-type
 553                                    referenced-types "GFlags"))
 554            for flags-type in flags
 555            for def = (get-g-flags-definition flags-type)
 556            unless (find flags-type auto-flags :test 'g-type=)
 557            do (format file "~S~%~%" def))
 558         (loop
 559            for interface in interfaces
 560            for def = (get-g-interface-definition interface)
 561            do (format file "~S~%~%" def))
 562         (loop
 563            for def in (get-g-class-definitions-for-root root-type)
 564            do (format file "~S~%~%" def))
 565         (iter (for object in objects)
 566               (unless (gethash (gtype-name (gtype object)) *generated-types*)
 567                 (for def = (get-g-class-definition object))
 568                 (format file "~S~%~%" def))))))