From 4c22e03a95b43c06f3518c27df8ebccae04cb2c6 Mon Sep 17 00:00:00 2001 From: Dmitry Kalyanov Date: Thu, 16 Apr 2009 03:26:50 +0400 Subject: [PATCH] Added gobject metaclasses --- glib/glib.asd | 3 +- glib/gobject.generating.lisp | 86 ++++++++---------- glib/gobject.meta.lisp | 203 ++++++++++++++++++++++++++++++++++++++++++ glib/gobject.package.lisp | 2 +- 4 files changed, 245 insertions(+), 49 deletions(-) create mode 100644 glib/gobject.meta.lisp diff --git a/glib/glib.asd b/glib/glib.asd index 5612f1b..43fc30c 100644 --- a/glib/glib.asd +++ b/glib/glib.asd @@ -23,7 +23,8 @@ (:file "gobject.foreign-gboxed") (:file "gobject.gvalue-parser") (:file "gobject.gobject-query") + (:file "gobject.meta") (:file "gobject.generating") (:file "gobject.object-defs") (:file "gobject.foreign-gobject-subclassing")) - :depends-on (:cffi :trivial-garbage :metabang-bind :iterate :anaphora :bordeaux-threads :iterate)) \ No newline at end of file + :depends-on (:cffi :trivial-garbage :metabang-bind :iterate :anaphora :bordeaux-threads :iterate :closer-mop)) \ No newline at end of file diff --git a/glib/gobject.generating.lisp b/glib/gobject.generating.lisp index bad13b2..5fe1cfa 100644 --- a/glib/gobject.generating.lisp +++ b/glib/gobject.generating.lisp @@ -8,8 +8,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) @@ -139,6 +138,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) @@ -146,56 +156,38 @@ type-initializer) (&rest properties)) (setf properties (mapcar #'parse-property properties)) - (let* ((superclass-properties (get superclass 'properties)) - (interface-properties (map-append (lambda (iface-name) - (get (gethash iface-name *known-interfaces*) 'properties)) - interfaces)) - (combined-properties (append superclass-properties properties interface-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) - (register-object-type ,g-type-name ',name) - (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))) diff --git a/glib/gobject.meta.lisp b/glib/gobject.meta.lisp new file mode 100644 index 0000000..c448d37 --- /dev/null +++ b/glib/gobject.meta.lisp @@ -0,0 +1,203 @@ +(in-package :gobject) + +(defclass gobject-class (standard-class) + ((g-type-name :initform (error "G-TYPE-NAME must be specified") + :initarg :g-type-name + :reader gobject-class-g-type-name) + (g-type-initializer :initform nil + :initarg :g-type-initializer + :reader gobject-class-g-type-initializer) + (interface-p :initform nil + :initarg :g-interface-p + :reader gobject-class-interface-p))) + +(defmethod initialize-instance :after ((object gobject-class) &key &allow-other-keys) + (register-object-type (gobject-class-g-type-name object) (class-name object)) + (when (gobject-class-g-type-initializer object) + (let ((type (foreign-funcall-pointer (foreign-symbol-pointer (gobject-class-g-type-initializer object)) nil + g-type))) + (assert (/= +g-type-invalid+ type) nil "Declared GType name '~A' for class '~A' is invalid (g_type_name returned 0)" + (gobject-class-g-type-name object) (class-name object)) + (assert (string= (gobject-class-g-type-name object) + (g-type-name type)) + nil "Declared GType name '~A' for class '~A' does not match actual GType name '~A'" + (gobject-class-g-type-name object) + (class-name object) + (g-type-name type))))) + +(defclass gobject-direct-slot-definition (standard-direct-slot-definition) + ((g-property-type :initform nil + :initarg :g-property-type + :reader gobject-direct-slot-definition-g-property-type))) + +(defclass gobject-effective-slot-definition (standard-effective-slot-definition) + ((g-property-type :initform nil + :initarg :g-property-type + :accessor gobject-effective-slot-definition-g-property-type))) + +(defclass gobject-property-direct-slot-definition (gobject-direct-slot-definition) + ((g-property-name :initform nil + :initarg :g-property-name + :reader gobject-property-direct-slot-definition-g-property-name))) + +(defclass gobject-property-effective-slot-definition (gobject-effective-slot-definition) + ((g-property-name :initform nil + :initarg :g-property-name + :accessor gobject-property-effective-slot-definition-g-property-name))) + +(defclass gobject-fn-direct-slot-definition (gobject-direct-slot-definition) + ((g-getter-name :initform nil + :initarg :g-getter + :reader gobject-fn-direct-slot-definition-g-getter-name) + (g-setter-name :initform nil + :initarg :g-setter + :reader gobject-fn-direct-slot-definition-g-setter-name))) + +(defclass gobject-fn-effective-slot-definition (gobject-effective-slot-definition) + ((g-getter-name :initform nil + :initarg :g-getter + :accessor gobject-fn-effective-slot-definition-g-getter-name) + (g-setter-name :initform nil + :initarg :g-setter + :accessor gobject-fn-effective-slot-definition-g-setter-name) + (g-getter-fn :initform nil + :accessor gobject-fn-effective-slot-definition-g-getter-fn) + (g-setter-fn :initform nil + :accessor gobject-fn-effective-slot-definition-g-setter-fn))) + +(defmethod validate-superclass ((class gobject-class) (superclass standard-class)) + t) + +(defmethod validate-superclass ((class standard-class) (superclass gobject-class)) + t) + +(defmethod compute-class-precedence-list ((class gobject-class)) + (let ((classes (call-next-method))) + (if (member (find-class 'g-object) classes) + classes + `(,class ,(find-class 'g-object) ,@(rest classes))))) + +(defmethod direct-slot-definition-class ((class gobject-class) &rest initargs &key allocation) + (declare (ignore initargs)) + (case allocation + (:gobject-property 'gobject-property-direct-slot-definition) + (:gobject-fn 'gobject-fn-direct-slot-definition) + (otherwise (call-next-method)))) + +(defmethod effective-slot-definition-class ((class gobject-class) &rest initargs &key allocation) + (declare (ignore initargs)) + (case allocation + (:gobject-property 'gobject-property-effective-slot-definition) + (:gobject-fn 'gobject-fn-effective-slot-definition) + (otherwise (call-next-method)))) + +(defmethod compute-effective-slot-definition ((class gobject-class) name direct-slots) + (let ((effective-slot (call-next-method))) + (when (typep effective-slot 'gobject-effective-slot-definition) + (let ((allocation (loop + for direct-slot in direct-slots + when (slot-definition-allocation direct-slot) + return (slot-definition-allocation direct-slot))) + (property-name (loop + for direct-slot in direct-slots + when (and (typep direct-slot 'gobject-property-direct-slot-definition) (gobject-property-direct-slot-definition-g-property-name direct-slot)) + return (gobject-property-direct-slot-definition-g-property-name direct-slot))) + (property-type (loop + for direct-slot in direct-slots + when (gobject-direct-slot-definition-g-property-type direct-slot) + return (gobject-direct-slot-definition-g-property-type direct-slot))) + (property-getter (loop + for direct-slot in direct-slots + when (and (typep direct-slot 'gobject-fn-direct-slot-definition) (gobject-fn-direct-slot-definition-g-getter-name direct-slot)) + return (gobject-fn-direct-slot-definition-g-getter-name direct-slot))) + (property-setter (loop + for direct-slot in direct-slots + when (and (typep direct-slot 'gobject-fn-direct-slot-definition) (gobject-fn-direct-slot-definition-g-setter-name direct-slot)) + return (gobject-fn-direct-slot-definition-g-setter-name direct-slot)))) + (setf (gobject-effective-slot-definition-g-property-type effective-slot) + (gobject-effective-slot-definition-g-property-type effective-slot)) + (ecase allocation + (:gobject-property (assert property-name nil "G-PROPERTY-NAME for slot ~A on class ~A must be specified" name (class-name class)) + (setf (gobject-property-effective-slot-definition-g-property-name effective-slot) + property-name)) + (:gobject-fn (assert (or property-getter property-setter) nil "At least one of G-PROPERTY-GETTER or G-PROPERTY-SETTER for slot ~A on class ~A must be specified" + name (class-name class)) + (when (or (and property-getter (stringp property-getter)) + (and property-setter (stringp property-setter))) + (assert property-type nil "G-PROPERTY-TYPE for slot ~A on class ~A must be specified because at least one of accessor is specified as a foreign function" name (class-name class))) + + (setf (gobject-fn-effective-slot-definition-g-getter-name effective-slot) property-getter + (gobject-fn-effective-slot-definition-g-setter-name effective-slot) property-setter + (gobject-fn-effective-slot-definition-g-getter-fn effective-slot) + (and property-getter + (if (stringp property-getter) + (compile nil `(lambda (object) + (foreign-funcall ,property-getter + g-object object + ,property-type))) + property-getter)) + (gobject-fn-effective-slot-definition-g-setter-fn effective-slot) + (and property-setter + (if (stringp property-setter) + (compile nil `(lambda (object new-value) + (foreign-funcall ,property-setter + g-object object + ,property-type new-value + :void))) + property-setter))))))) + effective-slot)) + +(defun create-gobject-from-class-and-initargs (class initargs) + (when (gobject-class-interface-p class) + (error "Trying to create instance of GInterface '~A' (class '~A')" (gobject-class-g-type-name class) (class-name class))) + (let (arg-names arg-values arg-types nc-setters nc-arg-values) + (declare (dynamic-extent arg-names arg-values arg-types nc-setters nc-arg-values)) + (loop + for (arg-name arg-value) on initargs by #'cddr + for slot = (find arg-name (class-slots class) :key 'slot-definition-initargs :test 'member) + when (and slot (typep slot 'gobject-effective-slot-definition)) + do (typecase slot + (gobject-property-effective-slot-definition + (push (gobject-property-effective-slot-definition-g-property-name slot) arg-names) + (push arg-value arg-values) + (push (gobject-effective-slot-definition-g-property-type slot) arg-types)) + (gobject-fn-effective-slot-definition + (push (gobject-fn-effective-slot-definition-g-setter-fn slot) nc-setters) + (push arg-value nc-arg-values)))) + (let ((object (g-object-call-constructor (gobject-class-g-type-name class) arg-names arg-values arg-types))) + (loop + for fn in nc-setters + for value in nc-arg-values + do (funcall fn object value)) + object))) + +(defmethod make-instance ((class gobject-class) &rest initargs &key pointer) + (if pointer + (progn + (assert (= (length initargs) 2) nil "POINTER can not be combined with other initargs (~A)" initargs) + (call-next-method)) + (let ((pointer (create-gobject-from-class-and-initargs class initargs))) + (call-next-method class :pointer pointer)))) + +(defmethod slot-value-using-class ((class gobject-class) object (slot gobject-property-effective-slot-definition)) + (g-object-call-get-property object + (gobject-property-effective-slot-definition-g-property-name slot) + (gobject-effective-slot-definition-g-property-type slot))) + +(defmethod (setf slot-value-using-class) (new-value (class gobject-class) object (slot gobject-property-effective-slot-definition)) + (g-object-call-set-property object + (gobject-property-effective-slot-definition-g-property-name slot) + new-value + (gobject-effective-slot-definition-g-property-type slot))) + +(defmethod slot-value-using-class ((class gobject-class) object (slot gobject-fn-effective-slot-definition)) + (funcall (gobject-fn-effective-slot-definition-g-getter-fn slot) object)) + +(defmethod (setf slot-value-using-class) (new-value (class gobject-class) object (slot gobject-fn-effective-slot-definition)) + (funcall (gobject-fn-effective-slot-definition-g-setter-fn slot) object new-value)) + +(defmethod slot-boundp-using-class ((class gobject-class) object (slot gobject-effective-slot-definition)) + t) + +(defmethod slot-makunbound-using-class ((class gobject-class) object (slot gobject-effective-slot-definition)) + nil) diff --git a/glib/gobject.package.lisp b/glib/gobject.package.lisp index 8bf5caf..f077581 100644 --- a/glib/gobject.package.lisp +++ b/glib/gobject.package.lisp @@ -1,5 +1,5 @@ (defpackage :gobject - (:use :cl :glib :cffi :tg :bind :anaphora :bordeaux-threads :iter) + (:use :cl :glib :cffi :tg :bind :anaphora :bordeaux-threads :iter :closer-mop) (:export #:g-object #:register-object-type #:g-object-call-constructor -- 1.7.10.4