X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.generating.lisp;h=7c3a807149cf153e99225e6250bdbc52f71940f6;hb=b8b6be84993178319789e864ae1d9f9f65c8e4c7;hp=fe100a90760a0bdaa8e62802854f40fce853e686;hpb=071f38e5719e1f6273a9d0c35bf3e981fe2124c4;p=cl-gtk2.git diff --git a/glib/gobject.generating.lisp b/glib/gobject.generating.lisp index fe100a9..7c3a807 100644 --- a/glib/gobject.generating.lisp +++ b/glib/gobject.generating.lisp @@ -1,6 +1,7 @@ (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) @@ -8,8 +9,7 @@ (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) @@ -36,13 +36,6 @@ :reader ',(cffi-property-reader object) :writer ',(cffi-property-writer object))) -(defun parse-accessor (spec) - (ecase (first spec) - (:cffi (destructuring-bind (&key reader writer) (rest spec) - (make-cffi-property-accessor :reader reader :writer writer))) - (:gobject (destructuring-bind (property-name) (rest spec) - (make-gobject-property-accessor :property-name property-name))))) - (defun parse-gobject-property (spec) (destructuring-bind (name accessor-name gname type readable writable) spec (make-gobject-property :name name @@ -94,43 +87,43 @@ (lispify-name property-name)) *lisp-name-package*)) -(defgeneric property->reader (property)) -(defgeneric property->writer (property)) +(defgeneric property->reader (class property)) +(defgeneric property->writer (class property)) -(defmethod property->reader ((property gobject-property)) +(defmethod property->reader (class (property gobject-property)) (with-slots (accessor-name type gname) property - `(defun ,accessor-name (object) + `(defmethod ,accessor-name ((object ,class)) (g-object-call-get-property object ,gname ,type)))) -(defmethod property->reader ((property cffi-property)) +(defmethod property->reader (class (property cffi-property)) (with-slots (accessor-name type reader) property (etypecase reader - (string `(defun ,accessor-name (object) + (string `(defmethod ,accessor-name ((object ,class)) (foreign-funcall ,reader g-object object ,type))) - (symbol `(defun ,accessor-name (object) + (symbol `(defmethod ,accessor-name ((object ,class)) (funcall ',reader object)))))) -(defmethod property->writer ((property gobject-property)) +(defmethod property->writer (class (property gobject-property)) (with-slots (accessor-name type gname) property - `(defun (setf ,accessor-name) (new-value object) + `(defmethod (setf ,accessor-name) (new-value (object ,class)) (g-object-call-set-property object ,gname new-value ,type) new-value))) -(defmethod property->writer ((property cffi-property)) +(defmethod property->writer (class (property cffi-property)) (with-slots (accessor-name type writer) property (etypecase writer - (string `(defun (setf ,accessor-name) (new-value object) + (string `(defmethod (setf ,accessor-name) (new-value (object ,class)) (foreign-funcall ,writer g-object object ,type new-value :void) new-value)) - (symbol `(defun (setf ,accessor-name) (new-value object) + (symbol `(defmethod (setf ,accessor-name) (new-value (object ,class)) (funcall ',writer object new-value) new-value))))) -(defun property->accessors (property export) +(defun property->accessors (class property export) (append (when (property-readable property) - (list (property->reader property))) + (list (property->reader class property))) (when (property-writable property) - (list (property->writer property))) + (list (property->writer class property))) (when export (list `(export ',(property-accessor-name property) (find-package ,(package-name (symbol-package (property-accessor-name property))))))))) @@ -146,6 +139,17 @@ (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) @@ -153,52 +157,38 @@ 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 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))) @@ -277,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 '=) @@ -336,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)) @@ -365,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))