(defvar *generation-exclusions* nil)
(defvar *known-interfaces* (make-hash-table :test 'equal))
(defvar *additional-properties* nil)
+(defvar *generated-types* nil)
(defun name->supplied-p (name)
(make-symbol (format nil "~A-SUPPLIED-P" (symbol-name name))))
(defun type-initializer-call (type-initializer)
(etypecase type-initializer
(string `(if (foreign-symbol-pointer ,type-initializer)
- (foreign-funcall ,type-initializer g-type)
+ (foreign-funcall-pointer
+ (foreign-symbol-pointer ,type-initializer) ()
+ g-type)
(warn "Type initializer '~A' is not available" ,type-initializer)))
(symbol `(funcall ',type-initializer))))
:allocation ,(if (gobject-property-p property) :gobject-property :gobject-fn)
:g-property-type ,(if (gobject-property-p property) (gobject-property-type property) (cffi-property-type property))
:accessor ,(intern (format nil "~A-~A" (symbol-name class-name) (property-name property)) (symbol-package class-name))
- :initarg ,(intern (string-upcase (property-name property)) (find-package :keyword))
+ ,@(when (if (gobject-property-p property)
+ t
+ (not (null (cffi-property-writer property))))
+ `(:initarg
+ ,(intern (string-upcase (property-name property)) (find-package :keyword))))
,@(if (gobject-property-p property)
`(:g-property-name ,(gobject-property-gname property))
`(:g-getter ,(cffi-property-reader property)
- :g-setter ,(cffi-property-writer property)))))
+ :g-setter ,(cffi-property-writer property)))))
(defmacro define-g-object-class (g-type-name name
(&key (superclass 'g-object)
(&rest properties))
(setf properties (mapcar #'parse-property properties))
`(progn
- (defclass ,name (,superclass ,@(mapcar #'interface->lisp-class-name interfaces))
+ (defclass ,name (,@(when (and superclass (not (eq superclass 'g-object))) (list superclass)) ,@(mapcar #'interface->lisp-class-name interfaces))
(,@(mapcar (lambda (property) (meta-property->slot name property)) properties))
(:metaclass gobject-class)
(:g-type-name . ,g-type-name)
(let ((type-init-name (probable-type-init-name type)))
(when (foreign-symbol-pointer type-init-name)
(foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
+ (when *generated-types*
+ (setf (gethash (g-type-string type) *generated-types*) t))
(let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
(g-type (ensure-g-type type))
(g-name (g-type-name g-type))
(let ((type-init-name (probable-type-init-name interface)))
(when (foreign-symbol-pointer type-init-name)
(foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
+ (when *generated-types*
+ (setf (gethash (g-type-string interface) *generated-types*) t))
(let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
(type (ensure-g-type interface))
(g-name (g-type-name type))
(defun get-g-class-definitions-for-root-1 (type)
(unless (member type *generation-exclusions* :test 'g-type=)
- (cons (get-g-class-definition type)
- (reduce #'append
- (mapcar #'get-g-class-definitions-for-root-1
- (sort (copy-list (g-type-children type)) #'string< :key #'g-type-string))))))
+ (iter (when (first-iteration-p)
+ (unless (and *generated-types*
+ (gethash (g-type-string type) *generated-types*))
+ (appending (list (get-g-class-definition type)))))
+ (for child-type in (sort (copy-list (g-type-children type)) #'string< :key #'g-type-string))
+ (appending (get-g-class-definitions-for-root-1 child-type)))))
(defun get-g-class-definitions-for-root (type)
(setf type (ensure-g-type type))
(let ((type-init-name (probable-type-init-name type)))
(when (foreign-symbol-pointer type-init-name)
(foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
+ (when *generated-types*
+ (setf (gethash (g-type-string type) *generated-types*) t))
(let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
(g-type (ensure-g-type type))
(g-name (g-type-name g-type))
(let ((type-init-name (probable-type-init-name type)))
(when (foreign-symbol-pointer type-init-name)
(foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
+ (when *generated-types*
+ (setf (gethash (g-type-string type) *generated-types*) t))
(let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
(g-type (ensure-g-type type))
(g-name (g-type-name g-type))
probable-type-initializer)))
,@(mapcar #'flags-value->definition items))))
+(defun maybe-call-type-init (type)
+ (when (and (stringp type) (zerop (g-type-numeric type)))
+ (let ((type-init-name (probable-type-init-name type)))
+ (when (foreign-symbol-pointer type-init-name)
+ (foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int)))))
+
+(defun get-g-type-definition (type &optional lisp-name-package)
+ (maybe-call-type-init type)
+ (cond
+ ((g-type-is-a type +g-type-enum+) (get-g-enum-definition type lisp-name-package))
+ ((g-type-is-a type +g-type-flags+) (get-g-flags-definition type lisp-name-package))
+ ((g-type-is-a type +g-type-interface+) (get-g-interface-definition type lisp-name-package))
+ ((g-type-is-a type +g-type-object+) (get-g-class-definition type lisp-name-package))
+ (t (error "Do not know how to automatically generate type definition for ~A type ~A"
+ (g-type-string (g-type-fundamental type))
+ (or (g-type-string type) type)))))
+
(defun generate-types-hierarchy-to-file (file root-type &key include-referenced prefix package exceptions prologue interfaces enums flags objects exclusions additional-properties)
(if (not (streamp file))
(with-open-file (stream file :direction :output :if-exists :supersede)
(*lisp-name-exceptions* exceptions)
(*print-case* :downcase)
(*additional-properties* additional-properties)
+ (*generated-types* (make-hash-table :test 'equalp))
(referenced-types (and include-referenced
(filter-types-by-prefix
(get-referenced-types root-type)
(loop
for def in (get-g-class-definitions-for-root root-type)
do (format file "~S~%~%" def))
- (loop
- for object in objects
- for def = (get-g-class-definition object)
- do (format file "~S~%~%" def)))))
\ No newline at end of file
+ (iter (for object in objects)
+ (unless (gethash (g-type-string object) *generated-types*)
+ (for def = (get-g-class-definition object))
+ (format file "~S~%~%" def))))))
\ No newline at end of file