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)
11 (defun name->supplied-p (name)
12 (make-symbol (format nil "~A-SUPPLIED-P" (symbol-name name))))
14 (defstruct property name accessor-name readable writable)
16 (defstruct (gobject-property (:include property)) gname type)
18 (defstruct (cffi-property (:include property)) type reader writer)
20 (defmethod make-load-form ((object gobject-property) &optional env)
21 (declare (ignore env))
22 `(make-gobject-property :name ',(property-name object)
23 :accessor-name ',(property-accessor-name object)
24 :readable ',(property-readable object)
25 :writable ',(property-writable object)
26 :gname ',(gobject-property-gname object)
27 :type ',(gobject-property-type object)))
29 (defmethod make-load-form ((object cffi-property) &optional env)
30 (declare (ignore env))
31 `(make-cffi-property :name ',(property-name object)
32 :accessor-name ',(property-accessor-name object)
33 :readable ',(property-readable object)
34 :writable ',(property-writable object)
35 :type ',(cffi-property-type object)
36 :reader ',(cffi-property-reader object)
37 :writer ',(cffi-property-writer object)))
39 (defun parse-gobject-property (spec)
40 (destructuring-bind (name accessor-name gname type readable writable) spec
41 (make-gobject-property :name name
42 :accessor-name accessor-name
48 (defun parse-cffi-property (spec)
49 (destructuring-bind (name accessor-name type reader writer) spec
50 (make-cffi-property :name name
51 :accessor-name accessor-name
55 :readable (not (null reader))
56 :writable (not (null writer)))))
58 (defun parse-property (spec)
60 ((eq (first spec) :cffi) (parse-cffi-property (rest spec)))
61 (t (parse-gobject-property spec))))
63 (defun property->method-arg (property)
64 (when (or (gobject-property-p property)
65 (and (cffi-property-p property)
66 (property-writable property)))
67 (let ((name (property-name property)))
68 `(,name nil ,(name->supplied-p name)))))
70 (defun gobject-property->arg-push (property)
71 (assert (typep property 'gobject-property))
72 (with-slots (name type gname) property
73 `(when ,(name->supplied-p name)
74 (push ,gname arg-names)
75 (push ,type arg-types)
76 (push ,name arg-values))))
78 (defun cffi-property->initarg (property)
79 (assert (typep property 'cffi-property))
80 (when (property-writable property)
81 (with-slots (accessor-name name type writer) property
82 `(when ,(name->supplied-p name)
83 (setf (,accessor-name object) ,name)))))
85 (defun accessor-name (class-name property-name)
86 (intern (format nil "~A-~A" (symbol-name class-name)
87 (lispify-name property-name))
90 (defgeneric property->reader (class property))
91 (defgeneric property->writer (class property))
93 (defmethod property->reader (class (property gobject-property))
94 (with-slots (accessor-name type gname) property
95 `(defmethod ,accessor-name ((object ,class))
96 (g-object-call-get-property object ,gname ,type))))
98 (defmethod property->reader (class (property cffi-property))
99 (with-slots (accessor-name type reader) property
101 (string `(defmethod ,accessor-name ((object ,class))
102 (foreign-funcall ,reader g-object object ,type)))
103 (symbol `(defmethod ,accessor-name ((object ,class))
104 (funcall ',reader object))))))
106 (defmethod property->writer (class (property gobject-property))
107 (with-slots (accessor-name type gname) property
108 `(defmethod (setf ,accessor-name) (new-value (object ,class))
109 (g-object-call-set-property object ,gname new-value ,type)
112 (defmethod property->writer (class (property cffi-property))
113 (with-slots (accessor-name type writer) property
115 (string `(defmethod (setf ,accessor-name) (new-value (object ,class))
116 (foreign-funcall ,writer g-object object ,type new-value :void)
118 (symbol `(defmethod (setf ,accessor-name) (new-value (object ,class))
119 (funcall ',writer object new-value)
122 (defun property->accessors (class property export)
123 (append (when (property-readable property)
124 (list (property->reader class property)))
125 (when (property-writable property)
126 (list (property->writer class property)))
128 (list `(export ',(property-accessor-name property)
129 (find-package ,(package-name (symbol-package (property-accessor-name property)))))))))
131 (defun interface->lisp-class-name (interface)
134 (string (or (gethash interface *known-interfaces*)
135 (error "Unknown interface ~A" interface)))))
137 (defun type-initializer-call (type-initializer)
138 (etypecase type-initializer
139 (string `(if (foreign-symbol-pointer ,type-initializer)
140 (foreign-funcall ,type-initializer g-type)
141 (warn "Type initializer '~A' is not available" ,type-initializer)))
142 (symbol `(funcall ',type-initializer))))
144 (defun meta-property->slot (class-name property)
145 `(,(property-name property)
146 :allocation ,(if (gobject-property-p property) :gobject-property :gobject-fn)
147 :g-property-type ,(if (gobject-property-p property) (gobject-property-type property) (cffi-property-type property))
148 :accessor ,(intern (format nil "~A-~A" (symbol-name class-name) (property-name property)) (symbol-package class-name))
149 ,@(when (if (gobject-property-p property)
151 (not (null (cffi-property-writer property))))
153 ,(intern (string-upcase (property-name property)) (find-package :keyword))))
154 ,@(if (gobject-property-p property)
155 `(:g-property-name ,(gobject-property-gname property))
156 `(:g-getter ,(cffi-property-reader property)
157 :g-setter ,(cffi-property-writer property)))))
159 (defmacro define-g-object-class (g-type-name name
160 (&key (superclass 'g-object)
165 (setf properties (mapcar #'parse-property properties))
167 (defclass ,name (,superclass ,@(mapcar #'interface->lisp-class-name interfaces))
168 (,@(mapcar (lambda (property) (meta-property->slot name property)) properties))
169 (:metaclass gobject-class)
170 (:g-type-name . ,g-type-name)
171 ,@(when type-initializer
172 (list `(:g-type-initializer . ,type-initializer))))
174 (cons `(export ',name (find-package ,(package-name (symbol-package name))))
175 (mapcar (lambda (property)
176 `(export ',(intern (format nil "~A-~A" (symbol-name name) (property-name property)) (symbol-package name))
177 (find-package ,(package-name (symbol-package name)))))
180 (defmacro define-g-interface (g-type-name name (&key (export t) type-initializer) &body properties)
181 (setf properties (mapcar #'parse-property properties))
184 (,@(mapcar (lambda (property) (meta-property->slot name property)) properties))
185 (:metaclass gobject-class)
186 (:g-type-name . ,g-type-name)
188 ,@(when type-initializer
189 (list `(:g-type-initializer . ,type-initializer))))
191 (cons `(export ',name (find-package ,(package-name (symbol-package name))))
192 (mapcar (lambda (property)
193 `(export ',(intern (format nil "~A-~A" (symbol-name name) (property-name property)) (symbol-package name))
194 (find-package ,(package-name (symbol-package name)))))
196 (eval-when (:compile-toplevel :load-toplevel :execute)
197 (setf (gethash ,g-type-name *known-interfaces*) ',name))))
199 (defun starts-with (name prefix)
200 (and prefix (> (length name) (length prefix)) (string= (subseq name 0 (length prefix)) prefix)))
202 (defun strip-start (name prefix)
203 (if (starts-with name prefix)
204 (subseq name (length prefix))
207 (defun lispify-name (name)
208 (with-output-to-string (stream)
209 (loop for c across (strip-start name *strip-prefix*)
210 for firstp = t then nil
211 do (when (and (not firstp) (upper-case-p c)) (write-char #\- stream))
212 do (write-char (char-upcase c) stream))))
214 (defun g-name->name (name)
215 (or (second (assoc name *lisp-name-exceptions* :test 'equal))
216 (intern (string-upcase (lispify-name name)) *lisp-name-package*)))
218 (defun property->property-definition (class-name property)
219 (let ((name (g-name->name (g-class-property-definition-name property)))
220 (accessor-name (accessor-name class-name (g-class-property-definition-name property)))
221 (g-name (g-class-property-definition-name property))
222 (type (g-type-name (g-class-property-definition-type property)))
223 (readable (g-class-property-definition-readable property))
224 (writable (and (g-class-property-definition-writable property)
225 (not (g-class-property-definition-constructor-only property)))))
226 `(,name ,accessor-name ,g-name ,type ,readable ,writable)))
228 (defun probable-type-init-name (type-name)
229 (with-output-to-string (stream)
230 (iter (for c in-string type-name)
231 (for prev-c previous c)
232 (when (and (not (first-iteration-p))
234 (not (upper-case-p prev-c))
235 (not (char= prev-c #\_)))
236 (write-char #\_ stream))
237 (write-char (char-downcase c) stream))
238 (write-string "_get_type" stream)))
240 (defun get-g-class-definition (type &optional lisp-name-package)
241 (when (and (stringp type) (zerop (g-type-numeric type)))
242 (let ((type-init-name (probable-type-init-name type)))
243 (when (foreign-symbol-pointer type-init-name)
244 (foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
245 (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
246 (g-type (ensure-g-type type))
247 (g-name (g-type-name g-type))
248 (name (g-name->name g-name))
249 (superclass-g-type (g-type-parent g-type))
250 (superclass-name (g-name->name (g-type-name superclass-g-type)))
251 (interfaces (g-type-interfaces g-type))
252 (properties (class-properties g-type))
253 (type-init-name (probable-type-init-name g-name))
255 (sort (copy-list (remove g-type properties :key #'g-class-property-definition-owner-type :test-not #'g-type=))
256 #'string< :key #'g-class-property-definition-name)))
257 `(define-g-object-class ,g-name ,name
258 (:superclass ,superclass-name
260 :interfaces (,@(sort (mapcar #'g-type-name interfaces) 'string<))
261 ,@(when (and (foreign-symbol-pointer type-init-name)
262 (not (null-pointer-p (foreign-symbol-pointer type-init-name))))
263 `(:type-initializer ,type-init-name)))
264 (,@(mapcar (lambda (property)
265 (property->property-definition name property))
267 ,@(cdr (find g-name *additional-properties* :key 'car :test 'string=))))))
269 (defun get-g-interface-definition (interface &optional lisp-name-package)
270 (when (and (stringp interface) (zerop (g-type-numeric interface)))
271 (let ((type-init-name (probable-type-init-name interface)))
272 (when (foreign-symbol-pointer type-init-name)
273 (foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
274 (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
275 (type (ensure-g-type interface))
276 (g-name (g-type-name type))
277 (name (g-name->name g-name))
278 (properties (sort (copy-list (interface-properties type))
279 #'string< :key #'g-class-property-definition-name))
280 (probable-type-initializer (probable-type-init-name g-name)))
281 `(define-g-interface ,g-name ,name
283 ,@(when (foreign-symbol-pointer probable-type-initializer)
284 `(:type-initializer ,probable-type-initializer)))
285 ,@(append (mapcar (lambda (property)
286 (property->property-definition name property))
288 (cdr (find g-name *additional-properties* :key 'car :test 'string=))))))
290 (defun get-g-class-definitions-for-root-1 (type)
291 (unless (member type *generation-exclusions* :test 'g-type=)
292 (cons (get-g-class-definition type)
294 (mapcar #'get-g-class-definitions-for-root-1
295 (sort (copy-list (g-type-children type)) #'string< :key #'g-type-string))))))
297 (defun get-g-class-definitions-for-root (type)
298 (setf type (ensure-g-type type))
299 (get-g-class-definitions-for-root-1 type))
301 (defvar *referenced-types*)
303 (defun class-or-interface-properties (type)
304 (setf type (ensure-g-type type))
306 ((g-type= (g-type-fundamental type) +g-type-object+) (class-properties type))
307 ((g-type= (g-type-fundamental type) +g-type-interface+) (interface-properties type))))
309 (defun get-shallow-referenced-types (type)
310 (setf type (ensure-g-type type))
311 (remove-duplicates (sort (loop
312 for property in (class-or-interface-properties type)
313 when (g-type= type (g-class-property-definition-owner-type property))
314 collect (g-class-property-definition-type property))
316 :key #'g-type-string)
319 (defun get-referenced-types-1 (type)
320 (setf type (ensure-g-type type))
322 for property-type in (sort (copy-list (get-shallow-referenced-types type)) #'string> :key #'g-type-string)
323 do (pushnew property-type *referenced-types* :test 'g-type=))
325 for type in (sort (copy-list (g-type-children type)) #'string< :key #'g-type-string)
326 do (get-referenced-types-1 type)))
328 (defun get-referenced-types (root-type)
329 (let (*referenced-types*)
330 (get-referenced-types-1 (ensure-g-type root-type))
333 (defun filter-types-by-prefix (types prefix)
336 (starts-with (g-type-name (ensure-g-type type)) prefix))
339 (defun filter-types-by-fund-type (types fund-type)
340 (setf fund-type (ensure-g-type fund-type))
343 (equal (g-type-fundamental (ensure-g-type type)) fund-type))
346 (defmacro define-g-enum (g-name name (&key (export t) type-initializer) &body values)
347 "Defines a GEnum type for enumeration. Generates corresponding CFFI definition.
351 \(define-g-enum \"GdkGrabStatus\" grab-status () :success :already-grabbed :invalid-time :not-viewable :frozen)
352 \(define-g-enum \"GdkExtensionMode\" gdk-extension-mode (:export t :type-initializer \"gdk_extension_mode_get_type\")
353 (:none 0) (:all 1) (:cursor 2))
355 @arg[g-name]{a string. Specifies the GEnum name}
356 @arg[name]{a symbol. Names the enumeration type.}
357 @arg[export]{a boolean. If true, @code{name} will be exported.}
358 @arg[type-initializer]{a @code{NIL} or a string or a function designator.
360 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.}
361 @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)}"
363 (defcenum ,name ,@values)
364 (register-enum-type ,g-name ',name)
366 (list `(export ',name (find-package ,(package-name (symbol-package name))))))
367 ,@(when type-initializer
368 (list `(at-init () ,(type-initializer-call type-initializer))))))
370 (defun enum-value->definition (enum-value)
371 (let ((value-name (intern (lispify-name (enum-item-nick enum-value))
372 (find-package :keyword)))
373 (numeric-value (enum-item-value enum-value)))
374 `(,value-name ,numeric-value)))
376 (defun get-g-enum-definition (type &optional lisp-name-package)
377 (when (and (stringp type) (zerop (g-type-numeric type)))
378 (let ((type-init-name (probable-type-init-name type)))
379 (when (foreign-symbol-pointer type-init-name)
380 (foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
381 (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
382 (g-type (ensure-g-type type))
383 (g-name (g-type-name g-type))
384 (name (g-name->name g-name))
385 (items (get-enum-items g-type))
386 (probable-type-initializer (probable-type-init-name g-name)))
387 `(define-g-enum ,g-name ,name
389 ,@(when (foreign-symbol-pointer probable-type-initializer)
390 (list :type-initializer
391 probable-type-initializer)))
392 ,@(mapcar #'enum-value->definition items))))
394 (defmacro define-g-flags (g-name name (&key (export t) type-initializer) &body values)
395 "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.
399 \(define-g-flags \"GdkWindowState\" window-state ()
401 (:iconified 2) (:maximized 4) (:sticky 8) (:fullscreen 16)
402 (:above 32) (:below 64))
404 @arg[g-name]{a string. Specifies the GEnum name}
405 @arg[name]{a symbol. Names the enumeration type.}
406 @arg[export]{a boolean. If true, @code{name} will be exported.}
407 @arg[type-initializer]{a @code{NIL} or a string or a function designator.
409 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.}
410 @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)}"
412 (defbitfield ,name ,@values)
413 (register-flags-type ,g-name ',name)
415 (list `(export ',name (find-package ,(package-name (symbol-package name))))))
416 ,@(when type-initializer
417 (list `(at-init () ,(type-initializer-call type-initializer))))))
419 (defun flags-value->definition (flags-value)
420 (let ((value-name (intern (lispify-name (flags-item-nick flags-value))
421 (find-package :keyword)))
422 (numeric-value (flags-item-value flags-value)))
423 `(,value-name ,numeric-value)))
425 (defun get-g-flags-definition (type &optional lisp-name-package)
426 (when (and (stringp type) (zerop (g-type-numeric type)))
427 (let ((type-init-name (probable-type-init-name type)))
428 (when (foreign-symbol-pointer type-init-name)
429 (foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
430 (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
431 (g-type (ensure-g-type type))
432 (g-name (g-type-name g-type))
433 (name (g-name->name g-name))
434 (items (get-flags-items g-type))
435 (probable-type-initializer (probable-type-init-name g-name)))
436 `(define-g-flags ,g-name ,name
438 ,@(when (foreign-symbol-pointer probable-type-initializer)
439 (list :type-initializer
440 probable-type-initializer)))
441 ,@(mapcar #'flags-value->definition items))))
443 (defun generate-types-hierarchy-to-file (file root-type &key include-referenced prefix package exceptions prologue interfaces enums flags objects exclusions additional-properties)
444 (if (not (streamp file))
445 (with-open-file (stream file :direction :output :if-exists :supersede)
446 (generate-types-hierarchy-to-file stream root-type
449 :exceptions exceptions
451 :include-referenced include-referenced
452 :interfaces interfaces
456 :exclusions exclusions
457 :additional-properties additional-properties))
458 (let* ((*generation-exclusions* (mapcar #'ensure-g-type exclusions))
459 (*lisp-name-package* (or package *package*))
460 (*package* *lisp-name-package*)
461 (*strip-prefix* (or prefix ""))
462 (*lisp-name-exceptions* exceptions)
463 (*print-case* :downcase)
464 (*additional-properties* additional-properties)
465 (referenced-types (and include-referenced
466 (filter-types-by-prefix
467 (get-referenced-types root-type)
469 (setf exclusions (mapcar #'ensure-g-type exclusions))
471 (write-string prologue file)
473 (when include-referenced
475 for interface in interfaces
477 for referenced-type in (get-shallow-referenced-types interface)
478 do (pushnew referenced-type referenced-types :test 'g-type=)))
480 for object in objects
482 for referenced-type in (get-shallow-referenced-types object)
483 do (pushnew referenced-type referenced-types :test 'g-type=)))
485 for enum-type in (filter-types-by-fund-type
486 referenced-types "GEnum")
487 for def = (get-g-enum-definition enum-type)
488 unless (member enum-type exclusions :test 'g-type=)
489 do (format file "~S~%~%" def))
492 for flags-type in (filter-types-by-fund-type
493 referenced-types "GFlags")
494 for def = (get-g-flags-definition flags-type)
495 unless (member flags-type exclusions :test 'g-type=)
496 do (format file "~S~%~%" def)))
498 with auto-enums = (and include-referenced
499 (filter-types-by-fund-type
500 referenced-types "GEnum"))
502 for def = (get-g-enum-definition enum)
503 unless (find enum auto-enums :test 'g-type=)
504 do (format file "~S~%~%" def))
506 with auto-flags = (and include-referenced
507 (filter-types-by-fund-type
508 referenced-types "GFlags"))
509 for flags-type in flags
510 for def = (get-g-flags-definition flags-type)
511 unless (find flags-type auto-flags :test 'g-type=)
512 do (format file "~S~%~%" def))
514 for interface in interfaces
515 for def = (get-g-interface-definition interface)
516 do (format file "~S~%~%" def))
518 for def in (get-g-class-definitions-for-root root-type)
519 do (format file "~S~%~%" def))
521 for object in objects
522 for def = (get-g-class-definition object)
523 do (format file "~S~%~%" def)))))