(in-package :gobject)
-(defvar *lisp-name-package* (find-package :gobject))
+(defvar *lisp-name-package* (find-package :gobject)
+ "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 *additional-properties* nil)
(defun name->supplied-p (name)
- (intern (format nil "~A-SUPPLIED-P" (symbol-name name))
- *lisp-name-package*))
+ (make-symbol (format nil "~A-SUPPLIED-P" (symbol-name name))))
(defstruct property name accessor-name readable writable)
(string `(foreign-funcall ,type-initializer g-type))
(symbol `(funcall ',type-initializer))))
+(defun meta-property->slot (class-name property)
+ `(,(property-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))
+ ,@(if (gobject-property-p property)
+ `(:g-property-name ,(gobject-property-gname property))
+ `(:g-getter ,(cffi-property-reader property)
+ :g-setter ,(cffi-property-writer property)))))
+
(defmacro define-g-object-class (g-type-name name
(&key (superclass 'g-object)
(export t)
type-initializer)
(&rest properties))
(setf properties (mapcar #'parse-property properties))
- (let* ((superclass-properties (get superclass 'properties))
- (combined-properties (append superclass-properties properties)))
- `(progn
- (defclass ,name (,superclass ,@(mapcar #'interface->lisp-class-name interfaces)) ())
- (register-object-type ,g-type-name ',name)
+ `(progn
+ (defclass ,name (,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)
,@(when type-initializer
- (list (type-initializer-call type-initializer)))
- ,@(when export
- (list `(export ',name (find-package ,(package-name (symbol-package name))))))
- (defmethod initialize-instance :before
- ((object ,name) &key pointer
- ,@(remove nil (mapcar #'property->method-arg
- combined-properties)))
- (unless (or pointer (and (slot-boundp object 'pointer)
- (not (null-pointer-p (pointer object)))))
- (let (arg-names arg-values arg-types)
- ,@(mapcar #'gobject-property->arg-push (remove-if-not #'gobject-property-p combined-properties))
- (setf (pointer object)
- (g-object-call-constructor ,g-type-name
- arg-names
- arg-values
- arg-types)
- (g-object-has-reference object) t)
- ,@(mapcar #'cffi-property->initarg (remove-if-not #'cffi-property-p combined-properties)))))
- ,@(loop
- for property in properties
- append (property->accessors name property export))
-
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (setf (get ',name 'superclass) ',superclass
- (get ',name 'properties) ',combined-properties)))))
-
-(defmacro define-g-interface (g-name name (&key (export t) type-initializer) &body properties)
+ (list `(:g-type-initializer . ,type-initializer))))
+ ,@(when export
+ (cons `(export ',name (find-package ,(package-name (symbol-package name))))
+ (mapcar (lambda (property)
+ `(export ',(intern (format nil "~A-~A" (symbol-name name) (property-name property)) (symbol-package name))
+ (find-package ,(package-name (symbol-package name)))))
+ properties)))))
+
+(defmacro define-g-interface (g-type-name name (&key (export t) type-initializer) &body properties)
(setf properties (mapcar #'parse-property properties))
`(progn
- (defclass ,name () ())
+ (defclass ,name ()
+ (,@(mapcar (lambda (property) (meta-property->slot name property)) properties))
+ (:metaclass gobject-class)
+ (:g-type-name . ,g-type-name)
+ (:g-interface-p . t)
+ ,@(when type-initializer
+ (list `(:g-type-initializer . ,type-initializer))))
,@(when export
- (list `(export ',name (find-package ,(package-name (symbol-package name))))))
- ,@(when type-initializer
- (list (type-initializer-call type-initializer)))
- ,@(loop
- for property in properties
- append (property->accessors name property export))
+ (cons `(export ',name (find-package ,(package-name (symbol-package name))))
+ (mapcar (lambda (property)
+ `(export ',(intern (format nil "~A-~A" (symbol-name name) (property-name property)) (symbol-package name))
+ (find-package ,(package-name (symbol-package name)))))
+ properties)))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (setf (get ',name 'properties) ',properties)
- (setf (gethash ,g-name *known-interfaces*) ',name))))
+ (setf (gethash ,g-type-name *known-interfaces*) ',name))))
(defun starts-with (name prefix)
(and prefix (> (length name) (length prefix)) (string= (subseq name 0 (length prefix)) prefix)))
(:export t
,@(when (foreign-symbol-pointer probable-type-initializer)
`(:type-initializer ,probable-type-initializer)))
- ,@(mapcar (lambda (property)
- (property->property-definition name property))
- properties))))
+ ,@(append (mapcar (lambda (property)
+ (property->property-definition name property))
+ properties)
+ (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 '=)
(equal (g-type-fundamental (ensure-g-type 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))
,@(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))
projects / cl-gtk2.git / blobdiff