Introspected classes now defined in propper order

diff --git a/glib/gboxed.lisp b/glib/gboxed.lisp
index c2daeb54aaa5ce38a19ffdfe77b7f56ab24ce30e..64ea49fcbb8bfcf0a75e8df96bcd5fbfdc978514 100644 (file)
--- a/glib/gboxed.lisp
+++ b/glib/gboxed.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gboxed.lisp,v 1.13 2004-11-09 10:10:59 espen Exp $
+;; $Id: gboxed.lisp,v 1.14 2005-02-01 15:24:52 espen Exp $
 
 (in-package "GLIB")
 
@@ -76,9 +76,10 @@ (defmethod unreference-foreign ((class boxed-class) location)
 
 ;;;; 
 
-(defun expand-boxed-type (type-number &optional slots)
+(defun expand-boxed-type (type-number forward-p slots)
   `(defclass ,(type-from-number type-number) (boxed)
-     ,slots
+     ,(unless forward-p
+       slots)
      (:metaclass boxed-class)
      (:alien-name ,(find-type-name type-number))))
 

diff --git a/glib/genums.lisp b/glib/genums.lisp
index 02fbe76d405fb30eb9d0d5ecb30e8caa58245774..7f379485759622576fab8141c5b3b2961a631d77 100644 (file)
--- a/glib/genums.lisp
+++ b/glib/genums.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: genums.lisp,v 1.5 2004-12-19 18:18:05 espen Exp $
+;; $Id: genums.lisp,v 1.6 2005-02-01 15:24:52 espen Exp $
 
 (in-package "GLIB")
 
@@ -213,7 +213,8 @@ (defun query-flags-values (type)
 
 ;;;;
 
-(defun expand-enum-type (type-number &optional options)
+(defun expand-enum-type (type-number forward-p options)
+  (declare (ignore forward))
   (let* ((super (supertype type-number))
         (type (type-from-number type-number))
         (mappings (getf options :mappings))

diff --git a/glib/ginterface.lisp b/glib/ginterface.lisp
index b54c665e860637ca4e9620f8c50ffdc3fe02af7d..17ced81de955c525cb12a16b3dcc9e278fd9c42c 100644 (file)
--- a/glib/ginterface.lisp
+++ b/glib/ginterface.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: ginterface.lisp,v 1.5 2004-11-07 15:54:15 espen Exp $
+;; $Id: ginterface.lisp,v 1.6 2005-02-01 15:24:52 espen Exp $
 
 (in-package "GLIB")
 
@@ -136,14 +136,17 @@ (defun query-object-interface-properties (type &optional inherited-p)
       )))
 
 
-(defun expand-ginterface-type (type options &rest args)
+(defun expand-ginterface-type (type forward-p options &rest args)
   (declare (ignore args))
   (let ((class (type-from-number type))
-       (slots (getf options :slots)))    
+       (slots (getf options :slots))) 
     `(defclass ,class (,(supertype type))
-      ,(slot-definitions class (query-object-interface-properties type) slots)
+       ,(unless forward-p
+         (slot-definitions class (query-object-interface-properties type) slots))
       (:metaclass ginterface-class)
       (:alien-name ,(find-type-name type)))))
 
+(defun ginterface-dependencies (type)
+  (delete-duplicates (mapcar #'param-value-type (query-object-interface-properties type))))
 
-(register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type)
+(register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type 'ginterface-dependencies)

diff --git a/glib/gobject.lisp b/glib/gobject.lisp
index b07a620590a712a2230ab5b38fe82d8f4021574e..a722174e7f2fdb639eb7dfd1c700b08f3a1d3bf3 100644 (file)
--- a/glib/gobject.lisp
+++ b/glib/gobject.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gobject.lisp,v 1.29 2005-01-30 14:30:30 espen Exp $
+;; $Id: gobject.lisp,v 1.30 2005-02-01 15:24:52 espen Exp $
 
 (in-package "GLIB")
 
@@ -354,7 +354,7 @@ (defun default-slot-accessor (class-name slot-name type)
 (defun slot-definition-from-property (class property &optional slot-name args)
   (with-slots (name flags value-type documentation) property
     (let* ((slot-name (or slot-name (default-slot-name name)))
-          (slot-type (or (getf args :type) (type-from-number value-type) value-type))
+          (slot-type (or (getf args :type) (type-from-number value-type) 'pointer))
           (accessor (default-slot-accessor class slot-name slot-type)))
       
       `(,slot-name
@@ -415,17 +415,21 @@ (defun slot-definitions (class properties slots)
   (delete-if #'(lambda (slot) (getf (rest slot) :ignore)) slots))
 
 
-(defun expand-gobject-type (type &optional options (metaclass 'gobject-class))
+(defun expand-gobject-type (type forward-p options &optional (metaclass 'gobject-class))
   (let ((supers (cons (supertype type) (implements type)))
        (class  (type-from-number type))
        (slots (getf options :slots)))    
     `(defclass ,class ,supers
-      ,(slot-definitions class (query-object-class-properties type) slots)
+       ,(unless forward-p
+         (slot-definitions class (query-object-class-properties type) slots))
       (:metaclass ,metaclass)
       (:alien-name ,(find-type-name type)))))
 
+(defun gobject-dependencies (type)
+  (delete-duplicates (mapcar #'param-value-type (query-object-class-properties type))))
 
-(register-derivable-type 'gobject "GObject" 'expand-gobject-type)
+
+(register-derivable-type 'gobject "GObject" 'expand-gobject-type 'gobject-dependencies)
 
 
 ;;; Pseudo type for gobject instances which have their reference count

diff --git a/glib/gtype.lisp b/glib/gtype.lisp
index 165c06e36faa49c09984c91b4af0b2e935a7c93d..5c7e5a0d078c465a34da9ed36a5c98dd723e81a4 100644 (file)
--- a/glib/gtype.lisp
+++ b/glib/gtype.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gtype.lisp,v 1.23 2005-01-12 13:33:06 espen Exp $
+;; $Id: gtype.lisp,v 1.24 2005-02-01 15:24:52 espen Exp $
 
 (in-package "GLIB")
 
@@ -260,23 +260,25 @@ (register-type 'pathname "gchararray")
 (register-type 'string "gchararray")
 
 
-;;;; 
+;;;; Introspection of type information
 
 (defvar *derivable-type-info* (make-hash-table))
 
-(defun register-derivable-type (type id expander)
+(defun register-derivable-type (type id expander &optional dependencies)
   (register-type type id)
   (let ((type-number (register-type type id)))
-    (setf (gethash type-number *derivable-type-info*) expander)))
+    (setf 
+     (gethash type-number *derivable-type-info*) 
+     (list expander dependencies))))
 
 (defun find-type-info (type)
   (dolist (super (cdr (type-hierarchy type)))
     (let ((info (gethash super *derivable-type-info*)))
       (return-if info))))
 
-(defun expand-type-definition (type options)
-  (let ((expander (find-type-info type)))
-    (funcall expander (find-type-number type t) options)))
+(defun expand-type-definition (type forward-p options)
+  (let ((expander (first (find-type-info type))))
+    (funcall expander (find-type-number type t) forward-p options)))
 
 (defbinding type-parent (type) type-number
   ((find-type-number type t) type-number))
@@ -337,24 +339,37 @@ (defun find-types (prefix)
      *derivable-type-info*)
     type-list))
 
-(defun %sort-types-topologicaly (unsorted)
-  (let ((sorted ()))
-    (loop while unsorted do
-      (dolist (type unsorted)
-       (let ((dependencies
-              (append (rest (type-hierarchy type)) (type-interfaces type))))
+(defun find-type-dependencies (type)
+  (let ((list-dependencies (second (find-type-info type))))
+    (when list-dependencies
+      (funcall list-dependencies (find-type-number type t)))))
+
+(defun %sort-types-topologicaly (types)
+  (let ((unsorted (mapcar 
+                  #'(lambda (type)
+                      (cons type (remove-if #'(lambda (dep)
+                                                (not (find dep types)))
+                                            (find-type-dependencies type))))
+                  types))
+       (forward-define ())
+       (sorted ()))
+
+    (loop
+     as tmp = unsorted then (or (rest tmp) unsorted)
+     while tmp
+     do (destructuring-bind (type . dependencies) (first tmp)
          (cond
-          ((null dependencies)
+          ((every #'(lambda (dep)
+                      (or (find dep forward-define) (find dep sorted)))
+                  dependencies)
            (push type sorted)
-           (setq unsorted (delete type unsorted)))
-          (t
-           (unless (dolist (dep dependencies)
-                     (when (find type (rest (type-hierarchy dep)))
-                       (error "Cyclic type dependencie"))
-                     (return-if (find dep unsorted)))
-             (push type sorted)
-             (setq unsorted (delete type unsorted))))))))
-    (nreverse sorted)))
+           (setq unsorted (delete type unsorted :key #'first)))
+          ((some #'(lambda (dep)
+                     (find type (find-type-dependencies dep)))
+                 dependencies)
+           (push type forward-define)))))
+
+    (values (nreverse sorted) forward-define)))
 
 
 (defun expand-type-definitions (prefix &optional args)
@@ -385,15 +400,18 @@ (defun expand-type-definitions (prefix &optional args)
         (register-type
          (getf (type-options type-number) :type (default-type-name name))
          type-number)))
-    
-     `(progn
-       ,@(mapcar
-          #'(lambda (type)
-              (expand-type-definition type (type-options type)))
-          (%sort-types-topologicaly type-list))))))
+     
+     (multiple-value-bind  (sorted-type-list forward-define)
+        (%sort-types-topologicaly type-list)
+       `(progn
+         ,@(mapcar
+            #'(lambda (type)
+                (expand-type-definition type t (type-options type)))
+            forward-define)
+         ,@(mapcar
+            #'(lambda (type)
+                (expand-type-definition type nil (type-options type)))
+            sorted-type-list))))))
 
 (defmacro define-types-by-introspection (prefix &rest args)
   (expand-type-definitions prefix args))
-
-
-

diff --git a/gtk/gtkobject.lisp b/gtk/gtkobject.lisp
index eb6cdb2acc5c23787e05d01468aaac73eb9f7d33..d03e975a34a9f08661de0931d18c56f2e38e8065 100644 (file)
--- a/gtk/gtkobject.lisp
+++ b/gtk/gtkobject.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gtkobject.lisp,v 1.21 2004-12-20 20:09:53 espen Exp $
+;; $Id: gtkobject.lisp,v 1.22 2005-02-01 15:24:56 espen Exp $
 
 
 (in-package "GTK")
@@ -208,17 +208,19 @@ (defun query-container-class-child-properties (type-number)
 (defun default-container-child-name (container-class)
   (intern (format nil "~A-CHILD" container-class)))
 
-(defun expand-container-type (type &optional options)
+(defun expand-container-type (type forward-p options)
   (let* ((class (type-from-number type))
         (super (supertype type))
         (child-class (default-container-child-name class)))
-    `(progn
-       ,(expand-gobject-type type options)
-       (defclass ,child-class (,(default-container-child-name super))
-        ,(slot-definitions child-class 
-          (query-container-class-child-properties type) nil)
-        (:metaclass child-class)
-        (:container ,class)))))
-
-
-(register-derivable-type 'container "GtkContainer" 'expand-container-type)
+    (if forward-p 
+       (expand-gobject-type type t options)
+      `(progn
+        ,(expand-gobject-type type nil options)
+        (defclass ,child-class (,(default-container-child-name super))
+          ,(slot-definitions child-class 
+            (query-container-class-child-properties type) nil)
+          (:metaclass child-class)
+          (:container ,class))))))
+
+
+(register-derivable-type 'container "GtkContainer" 'expand-container-type 'gobject-dependencies)