Added gobject metaclasses

diff --git a/glib/glib.asd b/glib/glib.asd
index 5612f1b..43fc30c 100644 (file)
--- 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 (file)
--- 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 (file)
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 (file)
--- 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