3 (defvar *lisp-name-package* (find-package :gobject))
4 (defvar *strip-prefix* "")
5 (defvar *lisp-name-exceptions* nil)
6 (defvar *generation-exclusions* nil)
7 (defvar *known-interfaces* (make-hash-table :test 'equal))
9 (defun name->supplied-p (name)
10 (intern (format nil "~A-SUPPLIED-P" (symbol-name name))
13 (defun property->method-arg (property)
14 (destructuring-bind (name accessor-name g-name type readable writable) property
15 (declare (ignore accessor-name g-name type readable writable))
16 `(,name nil ,(name->supplied-p name))))
18 (defun property->arg-push (property)
19 (destructuring-bind (name accessor-name g-name type readable writable) property
20 (declare (ignore accessor-name readable writable))
21 `(when ,(name->supplied-p name)
22 (push ,g-name arg-names)
23 (push ,type arg-types)
24 (push ,name arg-values))))
26 (defun accessor-name (class-name property-name)
27 (intern (format nil "~A-~A" (symbol-name class-name)
28 (lispify-name property-name))
31 (defun property->reader (property)
32 (let ((name (nth 1 property))
33 (prop-name (nth 2 property))
34 (prop-type (nth 3 property)))
35 `(defun ,name (object)
36 (g-object-call-get-property object ,prop-name ,prop-type))))
38 (defun property->writer (property)
39 (let ((name (nth 1 property))
40 (prop-name (nth 2 property))
41 (prop-type (nth 3 property)))
42 `(defun (setf ,name) (new-value object)
43 (g-object-call-set-property object ,prop-name new-value ,prop-type)
46 (defun property->accessors (property export)
47 (append (when (nth 4 property)
48 (list (property->reader property)))
49 (when (nth 5 property)
50 (list (property->writer property)))
52 (list `(export ',(nth 1 property)
53 (find-package ,(package-name (symbol-package (nth 1 property)))))))))
55 (defun interface->lisp-class-name (interface)
58 (string (or (gethash interface *known-interfaces*)
59 (error "Unknown interface ~A" interface)))))
61 (defun type-initializer-call (type-initializer)
62 (etypecase type-initializer
63 (string `(foreign-funcall ,type-initializer g-type))
64 (symbol `(funcall ',type-initializer))))
66 (defmacro define-g-object-class (g-type-name name
67 (&key (superclass 'g-object)
72 (let* ((superclass-properties (get superclass 'properties))
73 (combined-properties (append superclass-properties properties)))
75 (defclass ,name (,superclass ,@(mapcar #'interface->lisp-class-name interfaces)) ())
76 (register-object-type ,g-type-name ',name)
77 ,@(when type-initializer
78 (list (type-initializer-call type-initializer)))
80 (list `(export ',name (find-package ,(package-name (symbol-package name))))))
81 (defmethod initialize-instance :before
82 ((object ,name) &key pointer
83 ,@(mapcar #'property->method-arg
85 (unless (or pointer (and (slot-boundp object 'pointer)
86 (not (null-pointer-p (pointer object)))))
87 (let (arg-names arg-values arg-types)
88 ,@(mapcar #'property->arg-push combined-properties)
89 (setf (pointer object)
90 (g-object-call-constructor ,g-type-name
94 (g-object-has-reference object) t))))
96 for property in properties
97 append (property->accessors property export))
99 (eval-when (:compile-toplevel :load-toplevel :execute)
100 (setf (get ',name 'superclass) ',superclass
101 (get ',name 'properties) ',combined-properties)))))
103 (defmacro define-g-interface (g-name name (&key (export t) type-initializer) &body properties)
105 (defclass ,name () ())
107 (list `(export ',name (find-package ,(package-name (symbol-package name))))))
108 ,@(when type-initializer
109 (list (type-initializer-call type-initializer)))
111 for property in properties
112 append (property->accessors property export))
113 (eval-when (:compile-toplevel :load-toplevel :execute)
114 (setf (get ',name 'properties) ',properties)
115 (setf (gethash ,g-name *known-interfaces*) ',name))))
117 (defun starts-with (name prefix)
118 (and prefix (> (length name) (length prefix)) (string= (subseq name 0 (length prefix)) prefix)))
120 (defun strip-start (name prefix)
121 (if (starts-with name prefix)
122 (subseq name (length prefix))
125 (defun lispify-name (name)
126 (with-output-to-string (stream)
127 (loop for c across (strip-start name *strip-prefix*)
128 for firstp = t then nil
129 do (when (and (not firstp) (upper-case-p c)) (write-char #\- stream))
130 do (write-char (char-upcase c) stream))))
132 (defun g-name->name (name)
133 (or (second (assoc name *lisp-name-exceptions* :test 'equal))
134 (intern (string-upcase (lispify-name name)) *lisp-name-package*)))
136 (defun property->property-definition (class-name property)
137 (let ((name (g-name->name (g-class-property-definition-name property)))
138 (accessor-name (accessor-name class-name (g-class-property-definition-name property)))
139 (g-name (g-class-property-definition-name property))
140 (type (g-type-name (g-class-property-definition-type property)))
141 (readable (g-class-property-definition-readable property))
142 (writable (and (g-class-property-definition-writable property)
143 (not (g-class-property-definition-constructor-only property)))))
144 `(,name ,accessor-name ,g-name ,type ,readable ,writable)))
146 (defun probable-type-init-name (type-name)
147 (with-output-to-string (stream)
148 (iter (for c in-string type-name)
149 (for prev-c previous c)
150 (when (and (not (first-iteration-p))
152 (not (upper-case-p prev-c))
153 (not (char= prev-c #\_)))
154 (write-char #\_ stream))
155 (write-char (char-downcase c) stream))
156 (write-string "_get_type" stream)))
158 (defun get-g-class-definition (type)
159 (let* ((g-type (ensure-g-type type))
160 (g-name (g-type-name g-type))
161 (name (g-name->name g-name))
162 (superclass-g-type (g-type-parent g-type))
163 (superclass-name (g-name->name (g-type-name superclass-g-type)))
164 (interfaces (g-type-interfaces g-type))
165 (properties (class-properties g-type))
166 (type-init-name (probable-type-init-name g-name))
168 (remove-if-not (lambda (property)
170 (g-class-property-definition-owner-type property)))
172 `(define-g-object-class ,g-name ,name
173 (:superclass ,superclass-name
175 :interfaces (,@(mapcar #'g-type-name interfaces))
176 ,@(when (and (foreign-symbol-pointer type-init-name)
177 (not (null-pointer-p (foreign-symbol-pointer type-init-name))))
178 `(:type-initializer ,type-init-name)))
179 (,@(mapcar (lambda (property)
180 (property->property-definition name property))
184 (defun get-g-interface-definition (interface)
185 (let* ((type (ensure-g-type interface))
186 (g-name (g-type-name type))
187 (name (g-name->name g-name))
188 (properties (interface-properties type))
189 (probable-type-initializer (probable-type-init-name g-name)))
190 `(define-g-interface ,g-name ,name
192 ,@(when (foreign-symbol-pointer probable-type-initializer)
193 `(:type-initializer ,probable-type-initializer)))
194 ,@(mapcar (lambda (property)
195 (property->property-definition name property))
198 (defun get-g-class-definitions-for-root-1 (type)
199 (unless (member (ensure-g-type type) *generation-exclusions* :test '=)
200 (cons (get-g-class-definition type)
202 (mapcar #'get-g-class-definitions-for-root-1
203 (g-type-children type))))))
205 (defun get-g-class-definitions-for-root (type)
206 (setf type (ensure-g-type type))
207 (get-g-class-definitions-for-root-1 type))
209 (defvar *referenced-types*)
211 (defun class-or-interface-properties (type)
212 (setf type (ensure-g-type type))
214 ((= (g-type-fundamental type) +g-type-object+) (class-properties type))
215 ((= (g-type-fundamental type) +g-type-interface+) (interface-properties type))))
217 (defun get-shallow-referenced-types (type)
218 (setf type (ensure-g-type type))
219 (remove-duplicates (sort (loop
220 for property in (class-or-interface-properties type)
221 when (= type (g-class-property-definition-owner-type property))
222 collect (g-class-property-definition-type property))
226 (defun get-referenced-types-1 (type)
227 (setf type (ensure-g-type type))
229 for property-type in (get-shallow-referenced-types type)
230 do (pushnew property-type *referenced-types* :test '=))
232 for type in (g-type-children type)
233 do (get-referenced-types-1 type)))
235 (defun get-referenced-types (root-type)
236 (let (*referenced-types*)
237 (get-referenced-types-1 (ensure-g-type root-type))
240 (defun filter-types-by-prefix (types prefix)
243 (starts-with (g-type-name (ensure-g-type type)) prefix))
246 (defun filter-types-by-fund-type (types fund-type)
247 (setf fund-type (ensure-g-type fund-type))
250 (equal (g-type-fundamental (ensure-g-type type)) fund-type))
253 (defmacro define-g-enum (g-name name (&key (export t) type-initializer) &body values)
255 (defcenum ,name ,@values)
256 (register-enum-type ,g-name ',name)
258 (list `(export ',name (find-package ,(package-name (symbol-package name))))))
259 ,@(when type-initializer
260 (list (type-initializer-call type-initializer)))))
262 (defun enum-value->definition (enum-value)
263 (let ((value-name (intern (lispify-name (enum-item-nick enum-value))
264 (find-package :keyword)))
265 (numeric-value (enum-item-value enum-value)))
266 `(,value-name ,numeric-value)))
268 (defun get-g-enum-definition (type)
269 (let* ((g-type (ensure-g-type type))
270 (g-name (g-type-name g-type))
271 (name (g-name->name g-name))
272 (items (get-enum-items g-type))
273 (probable-type-initializer (probable-type-init-name g-name)))
274 `(define-g-enum ,g-name ,name
276 ,@(when (foreign-symbol-pointer probable-type-initializer)
277 (list :type-initializer
278 probable-type-initializer)))
279 ,@(mapcar #'enum-value->definition items))))
281 (defmacro define-g-flags (g-name name (&key (export t) type-initializer) &body values)
283 (defbitfield ,name ,@values)
284 (register-enum-type ,g-name ',name)
286 (list `(export ',name (find-package ,(package-name (symbol-package name))))))
287 ,@(when type-initializer
288 (list (type-initializer-call type-initializer)))))
290 (defun flags-value->definition (flags-value)
291 (let ((value-name (intern (lispify-name (flags-item-nick flags-value))
292 (find-package :keyword)))
293 (numeric-value (flags-item-value flags-value)))
294 `(,value-name ,numeric-value)))
296 (defun get-g-flags-definition (type)
297 (let* ((g-type (ensure-g-type type))
298 (g-name (g-type-name g-type))
299 (name (g-name->name g-name))
300 (items (get-flags-items g-type))
301 (probable-type-initializer (probable-type-init-name g-name)))
302 `(define-g-flags ,g-name ,name
304 ,@(when (foreign-symbol-pointer probable-type-initializer)
305 (list :type-initializer
306 probable-type-initializer)))
307 ,@(mapcar #'flags-value->definition items))))
309 (defun generate-types-hierarchy-to-file (file root-type &key include-referenced prefix package exceptions prologue interfaces enums flags objects exclusions)
310 (if (not (streamp file))
311 (with-open-file (stream file :direction :output :if-exists :supersede)
312 (generate-types-hierarchy-to-file stream root-type
315 :exceptions exceptions
317 :include-referenced include-referenced
318 :interfaces interfaces
322 :exclusions exclusions))
323 (let* ((*generation-exclusions* (mapcar #'ensure-g-type exclusions))
324 (*lisp-name-package* (or package *package*))
325 (*package* *lisp-name-package*)
326 (*strip-prefix* (or prefix ""))
327 (*lisp-name-exceptions* exceptions)
328 (*print-case* :downcase)
329 (referenced-types (and include-referenced
330 (filter-types-by-prefix
331 (get-referenced-types root-type)
333 (setf exclusions (mapcar #'ensure-g-type exclusions))
335 (write-string prologue file)
337 (when include-referenced
339 for interface in interfaces
341 for referenced-type in (get-shallow-referenced-types interface)
342 do (pushnew referenced-type referenced-types :test 'equal)))
344 for object in objects
346 for referenced-type in (get-shallow-referenced-types object)
347 do (pushnew referenced-type referenced-types :test 'equal)))
349 for enum-type in (filter-types-by-fund-type
350 referenced-types "GEnum")
351 for def = (get-g-enum-definition enum-type)
352 unless (member (ensure-g-type enum-type) exclusions :test '=)
353 do (format file "~S~%~%" def))
356 for flags-type in (filter-types-by-fund-type
357 referenced-types "GFlags")
358 for def = (get-g-flags-definition flags-type)
359 unless (member (ensure-g-type flags-type) exclusions :test '=)
360 do (format file "~S~%~%" def)))
362 with auto-enums = (and include-referenced
363 (filter-types-by-fund-type
364 referenced-types "GEnum"))
366 for def = (get-g-enum-definition enum)
367 unless (find (ensure-g-type enum) auto-enums :test 'equal)
368 do (format file "~S~%~%" def))
370 with auto-flags = (and include-referenced
371 (filter-types-by-fund-type
372 referenced-types "GFlags"))
373 for flags-type in flags
374 for def = (get-g-flags-definition flags-type)
375 unless (find (ensure-g-type flags-type) auto-flags :test 'equal)
376 do (format file "~S~%~%" def))
378 for interface in interfaces
379 for def = (get-g-interface-definition interface)
380 do (format file "~S~%~%" def))
382 for def in (get-g-class-definitions-for-root root-type)
383 do (format file "~S~%~%" def))
385 for object in objects
386 for def = (get-g-class-definition object)
387 do (format file "~S~%~%" def)))))