X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.generating.lisp;h=7c3a807149cf153e99225e6250bdbc52f71940f6;hb=2715350f7cc545171a3df81315b758df9ee89969;hp=3dc68fe1638052235c13e065729aa3a41ddd3e54;hpb=0ae2966882842ac995de2ddd4c5da3138e2283ce;p=cl-gtk2.git diff --git a/glib/gobject.generating.lisp b/glib/gobject.generating.lisp index 3dc68fe..7c3a807 100644 --- a/glib/gobject.generating.lisp +++ b/glib/gobject.generating.lisp @@ -1,56 +1,132 @@ (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 *known-interfaces* (make-hash-table :test 'equal)) +(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) + +(defstruct (gobject-property (:include property)) gname type) + +(defstruct (cffi-property (:include property)) type reader writer) + +(defmethod make-load-form ((object gobject-property) &optional env) + (declare (ignore env)) + `(make-gobject-property :name ',(property-name object) + :accessor-name ',(property-accessor-name object) + :readable ',(property-readable object) + :writable ',(property-writable object) + :gname ',(gobject-property-gname object) + :type ',(gobject-property-type object))) + +(defmethod make-load-form ((object cffi-property) &optional env) + (declare (ignore env)) + `(make-cffi-property :name ',(property-name object) + :accessor-name ',(property-accessor-name object) + :readable ',(property-readable object) + :writable ',(property-writable object) + :type ',(cffi-property-type object) + :reader ',(cffi-property-reader object) + :writer ',(cffi-property-writer object))) + +(defun parse-gobject-property (spec) + (destructuring-bind (name accessor-name gname type readable writable) spec + (make-gobject-property :name name + :accessor-name accessor-name + :gname gname + :type type + :readable readable + :writable writable))) + +(defun parse-cffi-property (spec) + (destructuring-bind (name accessor-name type reader writer) spec + (make-cffi-property :name name + :accessor-name accessor-name + :type type + :reader reader + :writer writer + :readable (not (null reader)) + :writable (not (null writer))))) + +(defun parse-property (spec) + (cond + ((eq (first spec) :cffi) (parse-cffi-property (rest spec))) + (t (parse-gobject-property spec)))) (defun property->method-arg (property) - (destructuring-bind (name accessor-name g-name type readable writable) property - (declare (ignore accessor-name g-name type readable writable)) - `(,name nil ,(name->supplied-p name)))) - -(defun property->arg-push (property) - (destructuring-bind (name accessor-name g-name type readable writable) property - (declare (ignore accessor-name readable writable)) + (when (or (gobject-property-p property) + (and (cffi-property-p property) + (property-writable property))) + (let ((name (property-name property))) + `(,name nil ,(name->supplied-p name))))) + +(defun gobject-property->arg-push (property) + (assert (typep property 'gobject-property)) + (with-slots (name type gname) property `(when ,(name->supplied-p name) - (push ,g-name arg-names) + (push ,gname arg-names) (push ,type arg-types) (push ,name arg-values)))) +(defun cffi-property->initarg (property) + (assert (typep property 'cffi-property)) + (when (property-writable property) + (with-slots (accessor-name name type writer) property + `(when ,(name->supplied-p name) + (setf (,accessor-name object) ,name))))) + (defun accessor-name (class-name property-name) (intern (format nil "~A-~A" (symbol-name class-name) (lispify-name property-name)) *lisp-name-package*)) -(defun property->reader (property) - (let ((name (nth 1 property)) - (prop-name (nth 2 property)) - (prop-type (nth 3 property))) - `(defun ,name (object) - (g-object-call-get-property object ,prop-name ,prop-type)))) - -(defun property->writer (property) - (let ((name (nth 1 property)) - (prop-name (nth 2 property)) - (prop-type (nth 3 property))) - `(defun (setf ,name) (new-value object) - (g-object-call-set-property object ,prop-name new-value ,prop-type) +(defgeneric property->reader (class property)) +(defgeneric property->writer (class property)) + +(defmethod property->reader (class (property gobject-property)) + (with-slots (accessor-name type gname) property + `(defmethod ,accessor-name ((object ,class)) + (g-object-call-get-property object ,gname ,type)))) + +(defmethod property->reader (class (property cffi-property)) + (with-slots (accessor-name type reader) property + (etypecase reader + (string `(defmethod ,accessor-name ((object ,class)) + (foreign-funcall ,reader g-object object ,type))) + (symbol `(defmethod ,accessor-name ((object ,class)) + (funcall ',reader object)))))) + +(defmethod property->writer (class (property gobject-property)) + (with-slots (accessor-name type gname) property + `(defmethod (setf ,accessor-name) (new-value (object ,class)) + (g-object-call-set-property object ,gname new-value ,type) new-value))) -(defun property->accessors (property export) - (append (when (nth 4 property) - (list (property->reader property))) - (when (nth 5 property) - (list (property->writer property))) +(defmethod property->writer (class (property cffi-property)) + (with-slots (accessor-name type writer) property + (etypecase writer + (string `(defmethod (setf ,accessor-name) (new-value (object ,class)) + (foreign-funcall ,writer g-object object ,type new-value :void) + new-value)) + (symbol `(defmethod (setf ,accessor-name) (new-value (object ,class)) + (funcall ',writer object new-value) + new-value))))) + +(defun property->accessors (class property export) + (append (when (property-readable property) + (list (property->reader class property))) + (when (property-writable property) + (list (property->writer class property))) (when export - (list `(export ',(nth 1 property) - (find-package ,(package-name (symbol-package (nth 1 property))))))))) + (list `(export ',(property-accessor-name property) + (find-package ,(package-name (symbol-package (property-accessor-name property))))))))) (defun interface->lisp-class-name (interface) (etypecase interface @@ -63,56 +139,56 @@ (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) interfaces type-initializer) (&rest 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) + (setf properties (mapcar #'parse-property properties)) + `(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 - ,@(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 #'property->arg-push combined-properties) - (setf (pointer object) - (g-object-call-constructor ,g-type-name - arg-names - arg-values - arg-types) - (g-object-has-reference object) t)))) - ,@(loop - for property in properties - append (property->accessors 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 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))) @@ -172,14 +248,14 @@ `(define-g-object-class ,g-name ,name (:superclass ,superclass-name :export t - :interfaces (,@(mapcar #'g-type-name interfaces)) + :interfaces (,@(sort (mapcar #'g-type-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))) (,@(mapcar (lambda (property) (property->property-definition name property)) - own-properties)) - ))) + own-properties) + ,@(cdr (find g-name *additional-properties* :key 'car :test 'string=)))))) (defun get-g-interface-definition (interface) (let* ((type (ensure-g-type interface)) @@ -191,9 +267,10 @@ (: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 '=) @@ -250,14 +327,29 @@ (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)) @@ -279,13 +371,29 @@ ,@(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)) @@ -306,7 +414,7 @@ probable-type-initializer))) ,@(mapcar #'flags-value->definition items)))) -(defun generate-types-hierarchy-to-file (file root-type &key include-referenced prefix package exceptions prologue interfaces enums flags objects exclusions) +(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) (generate-types-hierarchy-to-file stream root-type @@ -319,13 +427,15 @@ :enums enums :flags flags :objects objects - :exclusions exclusions)) + :exclusions exclusions + :additional-properties additional-properties)) (let* ((*generation-exclusions* (mapcar #'ensure-g-type 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) (referenced-types (and include-referenced (filter-types-by-prefix (get-referenced-types root-type)