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))
8 (defvar *additional-properties* nil)
10 (defun name->supplied-p (name)
11 (make-symbol (format nil "~A-SUPPLIED-P" (symbol-name name))))
13 (defstruct property name accessor-name readable writable)
15 (defstruct (gobject-property (:include property)) gname type)
17 (defstruct (cffi-property (:include property)) type reader writer)
19 (defmethod make-load-form ((object gobject-property) &optional env)
20 (declare (ignore env))
21 `(make-gobject-property :name ',(property-name object)
22 :accessor-name ',(property-accessor-name object)
23 :readable ',(property-readable object)
24 :writable ',(property-writable object)
25 :gname ',(gobject-property-gname object)
26 :type ',(gobject-property-type object)))
28 (defmethod make-load-form ((object cffi-property) &optional env)
29 (declare (ignore env))
30 `(make-cffi-property :name ',(property-name object)
31 :accessor-name ',(property-accessor-name object)
32 :readable ',(property-readable object)
33 :writable ',(property-writable object)
34 :type ',(cffi-property-type object)
35 :reader ',(cffi-property-reader object)
36 :writer ',(cffi-property-writer object)))
38 (defun parse-gobject-property (spec)
39 (destructuring-bind (name accessor-name gname type readable writable) spec
40 (make-gobject-property :name name
41 :accessor-name accessor-name
47 (defun parse-cffi-property (spec)
48 (destructuring-bind (name accessor-name type reader writer) spec
49 (make-cffi-property :name name
50 :accessor-name accessor-name
54 :readable (not (null reader))
55 :writable (not (null writer)))))
57 (defun parse-property (spec)
59 ((eq (first spec) :cffi) (parse-cffi-property (rest spec)))
60 (t (parse-gobject-property spec))))
62 (defun property->method-arg (property)
63 (when (or (gobject-property-p property)
64 (and (cffi-property-p property)
65 (property-writable property)))
66 (let ((name (property-name property)))
67 `(,name nil ,(name->supplied-p name)))))
69 (defun gobject-property->arg-push (property)
70 (assert (typep property 'gobject-property))
71 (with-slots (name type gname) property
72 `(when ,(name->supplied-p name)
73 (push ,gname arg-names)
74 (push ,type arg-types)
75 (push ,name arg-values))))
77 (defun cffi-property->initarg (property)
78 (assert (typep property 'cffi-property))
79 (when (property-writable property)
80 (with-slots (accessor-name name type writer) property
81 `(when ,(name->supplied-p name)
82 (setf (,accessor-name object) ,name)))))
84 (defun accessor-name (class-name property-name)
85 (intern (format nil "~A-~A" (symbol-name class-name)
86 (lispify-name property-name))
89 (defgeneric property->reader (class property))
90 (defgeneric property->writer (class property))
92 (defmethod property->reader (class (property gobject-property))
93 (with-slots (accessor-name type gname) property
94 `(defmethod ,accessor-name ((object ,class))
95 (g-object-call-get-property object ,gname ,type))))
97 (defmethod property->reader (class (property cffi-property))
98 (with-slots (accessor-name type reader) property
100 (string `(defmethod ,accessor-name ((object ,class))
101 (foreign-funcall ,reader g-object object ,type)))
102 (symbol `(defmethod ,accessor-name ((object ,class))
103 (funcall ',reader object))))))
105 (defmethod property->writer (class (property gobject-property))
106 (with-slots (accessor-name type gname) property
107 `(defmethod (setf ,accessor-name) (new-value (object ,class))
108 (g-object-call-set-property object ,gname new-value ,type)
111 (defmethod property->writer (class (property cffi-property))
112 (with-slots (accessor-name type writer) property
114 (string `(defmethod (setf ,accessor-name) (new-value (object ,class))
115 (foreign-funcall ,writer g-object object ,type new-value :void)
117 (symbol `(defmethod (setf ,accessor-name) (new-value (object ,class))
118 (funcall ',writer object new-value)
121 (defun property->accessors (class property export)
122 (append (when (property-readable property)
123 (list (property->reader class property)))
124 (when (property-writable property)
125 (list (property->writer class property)))
127 (list `(export ',(property-accessor-name property)
128 (find-package ,(package-name (symbol-package (property-accessor-name property)))))))))
130 (defun interface->lisp-class-name (interface)
133 (string (or (gethash interface *known-interfaces*)
134 (error "Unknown interface ~A" interface)))))
136 (defun type-initializer-call (type-initializer)
137 (etypecase type-initializer
138 (string `(foreign-funcall ,type-initializer g-type))
139 (symbol `(funcall ',type-initializer))))
141 (defun meta-property->slot (class-name property)
142 `(,(property-name property)
143 :allocation ,(if (gobject-property-p property) :gobject-property :gobject-fn)
144 :g-property-type ,(if (gobject-property-p property) (gobject-property-type property) (cffi-property-type property))
145 :accessor ,(intern (format nil "~A-~A" (symbol-name class-name) (property-name property)) (symbol-package class-name))
146 :initarg ,(intern (string-upcase (property-name property)) (find-package :keyword))
147 ,@(if (gobject-property-p property)
148 `(:g-property-name ,(gobject-property-gname property))
149 `(:g-getter ,(cffi-property-reader property)
150 :g-setter ,(cffi-property-writer property)))))
152 (defmacro define-g-object-class (g-type-name name
153 (&key (superclass 'g-object)
158 (setf properties (mapcar #'parse-property properties))
160 (defclass ,name (,superclass ,@(mapcar #'interface->lisp-class-name interfaces))
161 (,@(mapcar (lambda (property) (meta-property->slot name property)) properties))
162 (:metaclass gobject-class)
163 (:g-type-name . ,g-type-name)
164 ,@(when type-initializer
165 (list `(:g-type-initializer . ,type-initializer))))
167 (cons `(export ',name (find-package ,(package-name (symbol-package name))))
168 (mapcar (lambda (property)
169 `(export ',(intern (format nil "~A-~A" (symbol-name name) (property-name property)) (symbol-package name))
170 (find-package ,(package-name (symbol-package name)))))
173 (defmacro define-g-interface (g-type-name name (&key (export t) type-initializer) &body properties)
174 (setf properties (mapcar #'parse-property properties))
177 (,@(mapcar (lambda (property) (meta-property->slot name property)) properties))
178 (:metaclass gobject-class)
179 (:g-type-name . ,g-type-name)
181 ,@(when type-initializer
182 (list `(:g-type-initializer . ,type-initializer))))
184 (cons `(export ',name (find-package ,(package-name (symbol-package name))))
185 (mapcar (lambda (property)
186 `(export ',(intern (format nil "~A-~A" (symbol-name name) (property-name property)) (symbol-package name))
187 (find-package ,(package-name (symbol-package name)))))
189 (eval-when (:compile-toplevel :load-toplevel :execute)
190 (setf (gethash ,g-type-name *known-interfaces*) ',name))))
192 (defun starts-with (name prefix)
193 (and prefix (> (length name) (length prefix)) (string= (subseq name 0 (length prefix)) prefix)))
195 (defun strip-start (name prefix)
196 (if (starts-with name prefix)
197 (subseq name (length prefix))
200 (defun lispify-name (name)
201 (with-output-to-string (stream)
202 (loop for c across (strip-start name *strip-prefix*)
203 for firstp = t then nil
204 do (when (and (not firstp) (upper-case-p c)) (write-char #\- stream))
205 do (write-char (char-upcase c) stream))))
207 (defun g-name->name (name)
208 (or (second (assoc name *lisp-name-exceptions* :test 'equal))
209 (intern (string-upcase (lispify-name name)) *lisp-name-package*)))
211 (defun property->property-definition (class-name property)
212 (let ((name (g-name->name (g-class-property-definition-name property)))
213 (accessor-name (accessor-name class-name (g-class-property-definition-name property)))
214 (g-name (g-class-property-definition-name property))
215 (type (g-type-name (g-class-property-definition-type property)))
216 (readable (g-class-property-definition-readable property))
217 (writable (and (g-class-property-definition-writable property)
218 (not (g-class-property-definition-constructor-only property)))))
219 `(,name ,accessor-name ,g-name ,type ,readable ,writable)))
221 (defun probable-type-init-name (type-name)
222 (with-output-to-string (stream)
223 (iter (for c in-string type-name)
224 (for prev-c previous c)
225 (when (and (not (first-iteration-p))
227 (not (upper-case-p prev-c))
228 (not (char= prev-c #\_)))
229 (write-char #\_ stream))
230 (write-char (char-downcase c) stream))
231 (write-string "_get_type" stream)))
233 (defun get-g-class-definition (type)
234 (let* ((g-type (ensure-g-type type))
235 (g-name (g-type-name g-type))
236 (name (g-name->name g-name))
237 (superclass-g-type (g-type-parent g-type))
238 (superclass-name (g-name->name (g-type-name superclass-g-type)))
239 (interfaces (g-type-interfaces g-type))
240 (properties (class-properties g-type))
241 (type-init-name (probable-type-init-name g-name))
243 (remove-if-not (lambda (property)
245 (g-class-property-definition-owner-type property)))
247 `(define-g-object-class ,g-name ,name
248 (:superclass ,superclass-name
250 :interfaces (,@(sort (mapcar #'g-type-name interfaces) 'string<))
251 ,@(when (and (foreign-symbol-pointer type-init-name)
252 (not (null-pointer-p (foreign-symbol-pointer type-init-name))))
253 `(:type-initializer ,type-init-name)))
254 (,@(mapcar (lambda (property)
255 (property->property-definition name property))
257 ,@(cdr (find g-name *additional-properties* :key 'car :test 'string=))))))
259 (defun get-g-interface-definition (interface)
260 (let* ((type (ensure-g-type interface))
261 (g-name (g-type-name type))
262 (name (g-name->name g-name))
263 (properties (interface-properties type))
264 (probable-type-initializer (probable-type-init-name g-name)))
265 `(define-g-interface ,g-name ,name
267 ,@(when (foreign-symbol-pointer probable-type-initializer)
268 `(:type-initializer ,probable-type-initializer)))
269 ,@(append (mapcar (lambda (property)
270 (property->property-definition name property))
272 (cdr (find g-name *additional-properties* :key 'car :test 'string=))))))
274 (defun get-g-class-definitions-for-root-1 (type)
275 (unless (member (ensure-g-type type) *generation-exclusions* :test '=)
276 (cons (get-g-class-definition type)
278 (mapcar #'get-g-class-definitions-for-root-1
279 (g-type-children type))))))
281 (defun get-g-class-definitions-for-root (type)
282 (setf type (ensure-g-type type))
283 (get-g-class-definitions-for-root-1 type))
285 (defvar *referenced-types*)
287 (defun class-or-interface-properties (type)
288 (setf type (ensure-g-type type))
290 ((= (g-type-fundamental type) +g-type-object+) (class-properties type))
291 ((= (g-type-fundamental type) +g-type-interface+) (interface-properties type))))
293 (defun get-shallow-referenced-types (type)
294 (setf type (ensure-g-type type))
295 (remove-duplicates (sort (loop
296 for property in (class-or-interface-properties type)
297 when (= type (g-class-property-definition-owner-type property))
298 collect (g-class-property-definition-type property))
302 (defun get-referenced-types-1 (type)
303 (setf type (ensure-g-type type))
305 for property-type in (get-shallow-referenced-types type)
306 do (pushnew property-type *referenced-types* :test '=))
308 for type in (g-type-children type)
309 do (get-referenced-types-1 type)))
311 (defun get-referenced-types (root-type)
312 (let (*referenced-types*)
313 (get-referenced-types-1 (ensure-g-type root-type))
316 (defun filter-types-by-prefix (types prefix)
319 (starts-with (g-type-name (ensure-g-type type)) prefix))
322 (defun filter-types-by-fund-type (types fund-type)
323 (setf fund-type (ensure-g-type fund-type))
326 (equal (g-type-fundamental (ensure-g-type type)) fund-type))
329 (defmacro define-g-enum (g-name name (&key (export t) type-initializer) &body values)
331 (defcenum ,name ,@values)
332 (register-enum-type ,g-name ',name)
334 (list `(export ',name (find-package ,(package-name (symbol-package name))))))
335 ,@(when type-initializer
336 (list (type-initializer-call type-initializer)))))
338 (defun enum-value->definition (enum-value)
339 (let ((value-name (intern (lispify-name (enum-item-nick enum-value))
340 (find-package :keyword)))
341 (numeric-value (enum-item-value enum-value)))
342 `(,value-name ,numeric-value)))
344 (defun get-g-enum-definition (type)
345 (let* ((g-type (ensure-g-type type))
346 (g-name (g-type-name g-type))
347 (name (g-name->name g-name))
348 (items (get-enum-items g-type))
349 (probable-type-initializer (probable-type-init-name g-name)))
350 `(define-g-enum ,g-name ,name
352 ,@(when (foreign-symbol-pointer probable-type-initializer)
353 (list :type-initializer
354 probable-type-initializer)))
355 ,@(mapcar #'enum-value->definition items))))
357 (defmacro define-g-flags (g-name name (&key (export t) type-initializer) &body values)
359 (defbitfield ,name ,@values)
360 (register-flags-type ,g-name ',name)
362 (list `(export ',name (find-package ,(package-name (symbol-package name))))))
363 ,@(when type-initializer
364 (list (type-initializer-call type-initializer)))))
366 (defun flags-value->definition (flags-value)
367 (let ((value-name (intern (lispify-name (flags-item-nick flags-value))
368 (find-package :keyword)))
369 (numeric-value (flags-item-value flags-value)))
370 `(,value-name ,numeric-value)))
372 (defun get-g-flags-definition (type)
373 (let* ((g-type (ensure-g-type type))
374 (g-name (g-type-name g-type))
375 (name (g-name->name g-name))
376 (items (get-flags-items g-type))
377 (probable-type-initializer (probable-type-init-name g-name)))
378 `(define-g-flags ,g-name ,name
380 ,@(when (foreign-symbol-pointer probable-type-initializer)
381 (list :type-initializer
382 probable-type-initializer)))
383 ,@(mapcar #'flags-value->definition items))))
385 (defun generate-types-hierarchy-to-file (file root-type &key include-referenced prefix package exceptions prologue interfaces enums flags objects exclusions additional-properties)
386 (if (not (streamp file))
387 (with-open-file (stream file :direction :output :if-exists :supersede)
388 (generate-types-hierarchy-to-file stream root-type
391 :exceptions exceptions
393 :include-referenced include-referenced
394 :interfaces interfaces
398 :exclusions exclusions
399 :additional-properties additional-properties))
400 (let* ((*generation-exclusions* (mapcar #'ensure-g-type exclusions))
401 (*lisp-name-package* (or package *package*))
402 (*package* *lisp-name-package*)
403 (*strip-prefix* (or prefix ""))
404 (*lisp-name-exceptions* exceptions)
405 (*print-case* :downcase)
406 (*additional-properties* additional-properties)
407 (referenced-types (and include-referenced
408 (filter-types-by-prefix
409 (get-referenced-types root-type)
411 (setf exclusions (mapcar #'ensure-g-type exclusions))
413 (write-string prologue file)
415 (when include-referenced
417 for interface in interfaces
419 for referenced-type in (get-shallow-referenced-types interface)
420 do (pushnew referenced-type referenced-types :test 'equal)))
422 for object in objects
424 for referenced-type in (get-shallow-referenced-types object)
425 do (pushnew referenced-type referenced-types :test 'equal)))
427 for enum-type in (filter-types-by-fund-type
428 referenced-types "GEnum")
429 for def = (get-g-enum-definition enum-type)
430 unless (member (ensure-g-type enum-type) exclusions :test '=)
431 do (format file "~S~%~%" def))
434 for flags-type in (filter-types-by-fund-type
435 referenced-types "GFlags")
436 for def = (get-g-flags-definition flags-type)
437 unless (member (ensure-g-type flags-type) exclusions :test '=)
438 do (format file "~S~%~%" def)))
440 with auto-enums = (and include-referenced
441 (filter-types-by-fund-type
442 referenced-types "GEnum"))
444 for def = (get-g-enum-definition enum)
445 unless (find (ensure-g-type enum) auto-enums :test 'equal)
446 do (format file "~S~%~%" def))
448 with auto-flags = (and include-referenced
449 (filter-types-by-fund-type
450 referenced-types "GFlags"))
451 for flags-type in flags
452 for def = (get-g-flags-definition flags-type)
453 unless (find (ensure-g-type flags-type) auto-flags :test 'equal)
454 do (format file "~S~%~%" def))
456 for interface in interfaces
457 for def = (get-g-interface-definition interface)
458 do (format file "~S~%~%" def))
460 for def in (get-g-class-definitions-for-root root-type)
461 do (format file "~S~%~%" def))
463 for object in objects
464 for def = (get-g-class-definition object)
465 do (format file "~S~%~%" def)))))