fix compilation order issue with child-properties

[cl-gtk2.git] / glib / gobject.generating.lisp

diff --git a/glib/gobject.generating.lisp b/glib/gobject.generating.lisp
index 15ce217..bad13b2 100644 (file)
--- a/glib/gobject.generating.lisp
+++ b/glib/gobject.generating.lisp
@@ -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,42 +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
-    `(defun ,accessor-name (object)
-       (foreign-funcall ,reader g-object object ,type))))
+    (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 ((property gobject-property))
+(defmethod property->writer (class (property gobject-property))
   (with-slots (accessor-name type gname) property
-    `(defun (setf ,accessor-name) (new-value object)
-       (g-object-call-set-property object ,gname new-value ,type))))
-
-(defmethod property->writer ((property cffi-property))
-  (with-slots (accessor-name type writer) property
-    `(defun (setf ,accessor-name) (new-value object)
-       (foreign-funcall ,writer g-object object ,type new-value :void))))
-
-(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)
+    `(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)
+(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 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)))))))))
@@ -153,7 +147,10 @@
                                  (&rest properties))
   (setf properties (mapcar #'parse-property properties))
   (let* ((superclass-properties (get superclass 'properties))
-         (combined-properties (append superclass-properties 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)
@@ -178,9 +175,10 @@
              ,@(mapcar #'cffi-property->initarg (remove-if-not #'cffi-property-p combined-properties)))))
        ,@(loop
             for property in properties
-            append (property->accessors property export))
+            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)))))
 
@@ -194,7 +192,7 @@
              (list (type-initializer-call type-initializer)))
      ,@(loop
           for property in properties
-          append (property->accessors property export))
+          append (property->accessors name property export))
      (eval-when (:compile-toplevel :load-toplevel :execute)
        (setf (get ',name 'properties) ',properties)
        (setf (gethash ,g-name *known-interfaces*) ',name))))
@@ -257,7 +255,7 @@
     `(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)))
@@ -276,9 +274,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 '=)