(in-package :gobject)
-(defvar *lisp-name-package* (find-package :gobject))
+(defvar *lisp-name-package* nil
+ "For internal use (used by class definitions generator). Specifies the package in which symbols are interned.")
(defvar *strip-prefix* "")
(defvar *lisp-name-exceptions* nil)
(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 `(foreign-funcall ,type-initializer g-type))
+ (string `(if (foreign-symbol-pointer ,type-initializer)
+ (foreign-funcall-pointer
+ (foreign-symbol-pointer ,type-initializer) ()
+ g-type)
+ (warn "Type initializer '~A' is not available" ,type-initializer)))
(symbol `(funcall ',type-initializer))))
(defun meta-property->slot (class-name property)
: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 ((name (g-name->name (g-class-property-definition-name property)))
(accessor-name (accessor-name class-name (g-class-property-definition-name property)))
(g-name (g-class-property-definition-name property))
- (type (g-type-name (g-class-property-definition-type property)))
+ (type (gtype-name (g-class-property-definition-type property)))
(readable (g-class-property-definition-readable property))
(writable (and (g-class-property-definition-writable property)
(not (g-class-property-definition-constructor-only property)))))
(write-char (char-downcase c) stream))
(write-string "_get_type" stream)))
-(defun get-g-class-definition (type)
- (let* ((g-type (ensure-g-type type))
- (g-name (g-type-name g-type))
+(defun get-g-class-definition (type &optional lisp-name-package)
+ (when (and (stringp type) (null (ignore-errors (gtype 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 (gtype-name (gtype type)) *generated-types*) t))
+ (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
+ (g-type (gtype type))
+ (g-name (gtype-name g-type))
(name (g-name->name g-name))
(superclass-g-type (g-type-parent g-type))
- (superclass-name (g-name->name (g-type-name superclass-g-type)))
+ (superclass-name (g-name->name (gtype-name superclass-g-type)))
(interfaces (g-type-interfaces g-type))
(properties (class-properties g-type))
(type-init-name (probable-type-init-name g-name))
(own-properties
- (remove-if-not (lambda (property)
- (= g-type
- (g-class-property-definition-owner-type property)))
- properties)))
+ (sort (copy-list (remove g-type properties :key #'g-class-property-definition-owner-type :test-not #'g-type=))
+ #'string< :key #'g-class-property-definition-name)))
`(define-g-object-class ,g-name ,name
(:superclass ,superclass-name
:export t
- :interfaces (,@(sort (mapcar #'g-type-name interfaces) 'string<))
+ :interfaces (,@(sort (mapcar #'gtype-name interfaces) 'string<))
,@(when (and (foreign-symbol-pointer type-init-name)
(not (null-pointer-p (foreign-symbol-pointer type-init-name))))
`(:type-initializer ,type-init-name)))
own-properties)
,@(cdr (find g-name *additional-properties* :key 'car :test 'string=))))))
-(defun get-g-interface-definition (interface)
- (let* ((type (ensure-g-type interface))
- (g-name (g-type-name type))
+(defun get-g-interface-definition (interface &optional lisp-name-package)
+ (when (and (stringp interface) (null (ignore-errors (gtype interface))))
+ (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 (gtype-name (gtype interface)) *generated-types*) t))
+ (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
+ (type (gtype interface))
+ (g-name (gtype-name type))
(name (g-name->name g-name))
- (properties (interface-properties type))
+ (properties (sort (copy-list (interface-properties type))
+ #'string< :key #'g-class-property-definition-name))
(probable-type-initializer (probable-type-init-name g-name)))
`(define-g-interface ,g-name ,name
(:export t
(cdr (find g-name *additional-properties* :key 'car :test 'string=))))))
(defun get-g-class-definitions-for-root-1 (type)
- (unless (member (ensure-g-type type) *generation-exclusions* :test '=)
- (cons (get-g-class-definition type)
- (reduce #'append
- (mapcar #'get-g-class-definitions-for-root-1
- (g-type-children type))))))
+ (unless (member (gtype type) *generation-exclusions* :test 'g-type=)
+ (iter (when (first-iteration-p)
+ (unless (and *generated-types*
+ (gethash (gtype-name (gtype type)) *generated-types*))
+ (appending (list (get-g-class-definition type)))))
+ (for child-type in (sort (copy-list (g-type-children type)) #'string< :key #'gtype-name))
+ (appending (get-g-class-definitions-for-root-1 child-type)))))
(defun get-g-class-definitions-for-root (type)
- (setf type (ensure-g-type type))
+ (setf type (gtype type))
(get-g-class-definitions-for-root-1 type))
(defvar *referenced-types*)
(defun class-or-interface-properties (type)
- (setf type (ensure-g-type type))
+ (setf type (gtype type))
(cond
- ((= (g-type-fundamental type) +g-type-object+) (class-properties type))
- ((= (g-type-fundamental type) +g-type-interface+) (interface-properties type))))
+ ((g-type= (g-type-fundamental type) (gtype +g-type-object+)) (class-properties type))
+ ((g-type= (g-type-fundamental type) (gtype +g-type-interface+)) (interface-properties type))))
(defun get-shallow-referenced-types (type)
- (setf type (ensure-g-type type))
+ (setf type (gtype type))
(remove-duplicates (sort (loop
for property in (class-or-interface-properties type)
- when (= type (g-class-property-definition-owner-type property))
+ when (g-type= type (g-class-property-definition-owner-type property))
collect (g-class-property-definition-type property))
- #'<)
+ #'string<
+ :key #'gtype-name)
:test 'equal))
(defun get-referenced-types-1 (type)
- (setf type (ensure-g-type type))
+ (setf type (gtype type))
(loop
- for property-type in (get-shallow-referenced-types type)
- do (pushnew property-type *referenced-types* :test '=))
+ for property-type in (sort (copy-list (get-shallow-referenced-types type)) #'string> :key #'gtype-name)
+ do (pushnew property-type *referenced-types* :test 'g-type=))
(loop
- for type in (g-type-children type)
+ for type in (sort (copy-list (g-type-children type)) #'string< :key #'gtype-name)
do (get-referenced-types-1 type)))
(defun get-referenced-types (root-type)
(let (*referenced-types*)
- (get-referenced-types-1 (ensure-g-type root-type))
+ (get-referenced-types-1 (gtype root-type))
*referenced-types*))
(defun filter-types-by-prefix (types prefix)
(remove-if-not
(lambda (type)
- (starts-with (g-type-name (ensure-g-type type)) prefix))
+ (starts-with (gtype-name (gtype type)) prefix))
types))
(defun filter-types-by-fund-type (types fund-type)
- (setf fund-type (ensure-g-type fund-type))
+ (setf fund-type (gtype fund-type))
(remove-if-not
(lambda (type)
- (equal (g-type-fundamental (ensure-g-type type)) fund-type))
+ (equal (g-type-fundamental (gtype type)) fund-type))
types))
-(defmacro define-g-enum (g-name name (&key (export t) type-initializer) &body values)
+(defmacro define-g-enum (g-name name (&key (export t) type-initializer) &body values)
+ "Defines a GEnum type for enumeration. Generates corresponding CFFI definition.
+
+Example:
+@begin{pre}
+\(define-g-enum \"GdkGrabStatus\" grab-status () :success :already-grabbed :invalid-time :not-viewable :frozen)
+\(define-g-enum \"GdkExtensionMode\" gdk-extension-mode (:export t :type-initializer \"gdk_extension_mode_get_type\")
+ (:none 0) (:all 1) (:cursor 2))
+@end{pre}
+@arg[g-name]{a string. Specifies the GEnum name}
+@arg[name]{a symbol. Names the enumeration type.}
+@arg[export]{a boolean. If true, @code{name} will be exported.}
+@arg[type-initializer]{a @code{NIL} or a string or a function designator.
+
+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.}
+@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)}"
`(progn
(defcenum ,name ,@values)
(register-enum-type ,g-name ',name)
,@(when export
(list `(export ',name (find-package ,(package-name (symbol-package name))))))
,@(when type-initializer
- (list (type-initializer-call type-initializer)))))
+ (list `(at-init () ,(type-initializer-call type-initializer))))))
(defun enum-value->definition (enum-value)
(let ((value-name (intern (lispify-name (enum-item-nick enum-value))
(numeric-value (enum-item-value enum-value)))
`(,value-name ,numeric-value)))
-(defun get-g-enum-definition (type)
- (let* ((g-type (ensure-g-type type))
- (g-name (g-type-name g-type))
+(defun get-g-enum-definition (type &optional lisp-name-package)
+ (when (and (stringp type) (null (gtype 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 (gtype-name (gtype type)) *generated-types*) t))
+ (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
+ (g-type (gtype type))
+ (g-name (gtype-name g-type))
(name (g-name->name g-name))
(items (get-enum-items g-type))
(probable-type-initializer (probable-type-init-name g-name)))
,@(mapcar #'enum-value->definition items))))
(defmacro define-g-flags (g-name name (&key (export t) type-initializer) &body values)
+ "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.
+
+Example:
+@begin{pre}
+\(define-g-flags \"GdkWindowState\" window-state ()
+ (:withdrawn 1)
+ (:iconified 2) (:maximized 4) (:sticky 8) (:fullscreen 16)
+ (:above 32) (:below 64))
+@end{pre}
+@arg[g-name]{a string. Specifies the GEnum name}
+@arg[name]{a symbol. Names the enumeration type.}
+@arg[export]{a boolean. If true, @code{name} will be exported.}
+@arg[type-initializer]{a @code{NIL} or a string or a function designator.
+
+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.}
+@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)}"
`(progn
(defbitfield ,name ,@values)
- (register-enum-type ,g-name ',name)
+ (register-flags-type ,g-name ',name)
,@(when export
(list `(export ',name (find-package ,(package-name (symbol-package name))))))
,@(when type-initializer
- (list (type-initializer-call type-initializer)))))
+ (list `(at-init () ,(type-initializer-call type-initializer))))))
(defun flags-value->definition (flags-value)
(let ((value-name (intern (lispify-name (flags-item-nick flags-value))
(numeric-value (flags-item-value flags-value)))
`(,value-name ,numeric-value)))
-(defun get-g-flags-definition (type)
- (let* ((g-type (ensure-g-type type))
- (g-name (g-type-name g-type))
+(defun get-g-flags-definition (type &optional lisp-name-package)
+ (when (and (stringp type) (null (gtype 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 (gtype-name (gtype type)) *generated-types*) t))
+ (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
+ (g-type (gtype type))
+ (g-name (gtype-name g-type))
(name (g-name->name g-name))
(items (get-flags-items g-type))
(probable-type-initializer (probable-type-init-name g-name)))
probable-type-initializer)))
,@(mapcar #'flags-value->definition items))))
+(defun maybe-call-type-init (type)
+ (when (and (stringp type) (null (gtype 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 (gtype +g-type-enum+)) (get-g-enum-definition type lisp-name-package))
+ ((g-type-is-a type (gtype +g-type-flags+)) (get-g-flags-definition type lisp-name-package))
+ ((g-type-is-a type (gtype +g-type-interface+)) (get-g-interface-definition type lisp-name-package))
+ ((g-type-is-a type (gtype +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"
+ (gtype-name (g-type-fundamental type))
+ (or (ignore-errors (gtype-name (gtype 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)
:objects objects
:exclusions exclusions
:additional-properties additional-properties))
- (let* ((*generation-exclusions* (mapcar #'ensure-g-type exclusions))
+ (let* ((*generation-exclusions* (mapcar #'gtype exclusions))
(*lisp-name-package* (or package *package*))
(*package* *lisp-name-package*)
(*strip-prefix* (or prefix ""))
(*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)
prefix))))
- (setf exclusions (mapcar #'ensure-g-type exclusions))
+ (setf exclusions (mapcar #'gtype exclusions))
(when prologue
(write-string prologue file)
(terpri file))
for interface in interfaces
do (loop
for referenced-type in (get-shallow-referenced-types interface)
- do (pushnew referenced-type referenced-types :test 'equal)))
+ do (pushnew referenced-type referenced-types :test 'g-type=)))
(loop
for object in objects
do (loop
for referenced-type in (get-shallow-referenced-types object)
- do (pushnew referenced-type referenced-types :test 'equal)))
+ do (pushnew referenced-type referenced-types :test 'g-type=)))
(loop
for enum-type in (filter-types-by-fund-type
referenced-types "GEnum")
for def = (get-g-enum-definition enum-type)
- unless (member (ensure-g-type enum-type) exclusions :test '=)
+ unless (member enum-type exclusions :test 'g-type=)
do (format file "~S~%~%" def))
(loop
for flags-type in (filter-types-by-fund-type
referenced-types "GFlags")
for def = (get-g-flags-definition flags-type)
- unless (member (ensure-g-type flags-type) exclusions :test '=)
+ unless (member flags-type exclusions :test 'g-type=)
do (format file "~S~%~%" def)))
(loop
with auto-enums = (and include-referenced
referenced-types "GEnum"))
for enum in enums
for def = (get-g-enum-definition enum)
- unless (find (ensure-g-type enum) auto-enums :test 'equal)
+ unless (find enum auto-enums :test 'g-type=)
do (format file "~S~%~%" def))
(loop
with auto-flags = (and include-referenced
referenced-types "GFlags"))
for flags-type in flags
for def = (get-g-flags-definition flags-type)
- unless (find (ensure-g-type flags-type) auto-flags :test 'equal)
+ unless (find flags-type auto-flags :test 'g-type=)
do (format file "~S~%~%" def))
(loop
for interface in interfaces
(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 (gtype-name (gtype object)) *generated-types*)
+ (for def = (get-g-class-definition object))
+ (format file "~S~%~%" def))))))
\ No newline at end of file