Fixes needed to enable loading without first comiling work

diff --git a/glib/ginterface.lisp b/glib/ginterface.lisp
index 542351c61eb56de34187bb394a511475ccee1214..8001f72b43da932109f012f2a74124fb565aa45b 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
 
 ;; 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.7 2005/02/03 23:09:04 espen Exp $
+;; $Id: ginterface.lisp,v 1.8 2005/02/10 00:20:02 espen Exp $

 
 (in-package "GLIB")
 
 
 (in-package "GLIB")
 


@@ -128,9 +128,10 @@ (defun query-object-interface-properties (type &optional inherited-p)
     (unwind-protect
         (multiple-value-bind (array length)
             (%object-interface-list-properties iface)
     (unwind-protect
         (multiple-value-bind (array length)
             (%object-interface-list-properties iface)

-          (unwind-protect
-               (%map-params array length type-number inherited-p)
-            (deallocate-memory array)))
+          (unless (null-pointer-p array)
+            (unwind-protect
+                (%map-params array length type-number inherited-p)
+              (deallocate-memory array))))

 ;      (type-default-interface-unref type-number)
       )))
 
 ;      (type-default-interface-unref type-number)
       )))
 


@@ -146,6 +147,9 @@ (defun expand-ginterface-type (type forward-p options &rest args)
       (:alien-name ,(find-type-name type)))))
 
 (defun ginterface-dependencies (type)
       (:alien-name ,(find-type-name type)))))
 
 (defun ginterface-dependencies (type)

-  (delete-duplicates (mapcar #'param-value-type (query-object-interface-properties type))))
+  (delete-duplicates 
+   (cons
+    (supertype type)
+    (mapcar #'param-value-type (query-object-interface-properties type)))))

 
 (register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type 'ginterface-dependencies)
 
 (register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type 'ginterface-dependencies)

diff --git a/glib/gobject.lisp b/glib/gobject.lisp
index 621c370354954f59297602436859555950e94140..b0ac68f1f2d0ff66e34f769f7c557e7535a86ff6 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
 
 ;; 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.31 2005/02/03 23:09:04 espen Exp $
+;; $Id: gobject.lisp,v 1.32 2005/02/10 00:20:02 espen Exp $

 
 (in-package "GLIB")
 
 
 (in-package "GLIB")
 


@@ -108,8 +108,10 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de
     (when (and (not (slot-boundp slotd 'getter)) (slot-readable-p slotd))
       (setf 
        (slot-value slotd 'getter)
     (when (and (not (slot-boundp slotd 'getter)) (slot-readable-p slotd))
       (setf 
        (slot-value slotd 'getter)

-       (let ((reader (reader-function type)))
+       (let ((reader nil)) ;(reader-function type)))

         #'(lambda (object)
         #'(lambda (object)

+            (unless reader
+              (setq reader (reader-function type)))

             (let ((gvalue (gvalue-new type-number)))
               (%object-get-property object pname gvalue)
               (unwind-protect
             (let ((gvalue (gvalue-new type-number)))
               (%object-get-property object pname gvalue)
               (unwind-protect


@@ -119,8 +121,10 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de
     (when (and (not (slot-boundp slotd 'setter)) (slot-writable-p slotd))
       (setf 
        (slot-value slotd 'setter)
     (when (and (not (slot-boundp slotd 'setter)) (slot-writable-p slotd))
       (setf 
        (slot-value slotd 'setter)

-       (let ((writer (writer-function type)))
+       (let ((writer nil)) ;(writer-function type)))

         #'(lambda (value object)
         #'(lambda (value object)

+            (unless writer
+              (setq writer (writer-function type)))

             (let ((gvalue (gvalue-new type-number)))
               (funcall writer value gvalue +gvalue-value-offset+)
               (%object-set-property object pname gvalue)
             (let ((gvalue (gvalue-new type-number)))
               (funcall writer value gvalue +gvalue-value-offset+)
               (%object-set-property object pname gvalue)


@@ -334,9 +338,10 @@ (defun query-object-class-properties (type &optional inherited-p)
     (unwind-protect
         (multiple-value-bind (array length)
             (%object-class-list-properties class)
     (unwind-protect
         (multiple-value-bind (array length)
             (%object-class-list-properties class)

-          (unwind-protect
-               (%map-params array length type-number inherited-p)
-            (deallocate-memory array)))
+          (unless (null-pointer-p array)
+            (unwind-protect
+                (%map-params array length type-number inherited-p)
+              (deallocate-memory array))))

 ;      (type-class-unref type-number)
       )))
 
 ;      (type-class-unref type-number)
       )))
 


@@ -426,7 +431,12 @@ (defun expand-gobject-type (type forward-p options &optional (metaclass 'gobject
       (:alien-name ,(find-type-name type)))))
 
 (defun gobject-dependencies (type)
       (:alien-name ,(find-type-name type)))))
 
 (defun gobject-dependencies (type)

-  (delete-duplicates (mapcar #'param-value-type (query-object-class-properties type))))
+  (delete-duplicates 
+   (cons
+    (supertype type)
+    (append 
+     (type-interfaces type)
+     (mapcar #'param-value-type (query-object-class-properties type))))))

 
 
 (register-derivable-type 'gobject "GObject" 'expand-gobject-type 'gobject-dependencies)
 
 
 (register-derivable-type 'gobject "GObject" 'expand-gobject-type 'gobject-dependencies)

diff --git a/glib/gtype.lisp b/glib/gtype.lisp
index 3b9760af19296fbdaad8c74511eb9dc3160b9f37..8a3b275c0eea62d8c1390497106834a3e3c2bd68 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
 
 ;; 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.25 2005/02/03 23:09:04 espen Exp $
+;; $Id: gtype.lisp,v 1.26 2005/02/10 00:20:02 espen Exp $

 
 (in-package "GLIB")
 
 
 (in-package "GLIB")
 


@@ -153,36 +153,60 @@ (defbinding (find-type-name "g_type_name") (type) (copy-of string)
 (defun type-number-of (object)
   (find-type-number (type-of object) t))
 
 (defun type-number-of (object)
   (find-type-number (type-of object) t))
 

-(defun init-type (init)
-  (mapc
-   #'(lambda (fname)
-       (funcall (mkbinding fname 'type-number)))
-   (mklist init)))
-
-(defun %init-types-in-library (pathname prefix ignore)
-  (let ((process (run-program
-                 "/usr/bin/nm" (list "--defined-only" "-D" (namestring (truename pathname)))
-                 :output :stream :wait nil))
-       (fnames ()))
-    (labels ((read-symbols ()
-              (let ((line (read-line (process-output process) nil)))
-                (when line
-                  (let ((symbol (subseq line 11)))
-                    (when (and
-                           (> (length symbol) (length prefix))
-                           (string= prefix symbol :end2 (length prefix))
-                           (search "_get_type" symbol)
-                           (not (member symbol ignore :test #'string=)))
-                      (push symbol fnames)))
-                  (read-symbols)))))
-      (read-symbols)
-      (process-close process)
-      `(init-type ',fnames))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun %find-types-in-library (pathname prefix ignore)
+    (let ((process (run-program
+                   "/usr/bin/nm" (list "--defined-only" "-D" (namestring (truename pathname)))
+                   :output :stream :wait nil)))
+      (unwind-protect
+         (loop 
+          as symbol = (let ((line (read-line (process-output process) nil)))
+                        (when line (subseq line 11)))                    
+          while symbol
+          when (and
+                (> (length symbol) (length prefix))
+                (string= prefix symbol :end2 (length prefix))
+                (search "_get_type" symbol)
+                (not (member symbol ignore :test #'string=)))
+          collect symbol)
+       (process-close process)))))
+

 
 (defmacro init-types-in-library (filename &key (prefix "") ignore)
 
 (defmacro init-types-in-library (filename &key (prefix "") ignore)

-  (%init-types-in-library filename prefix ignore))
+  (let ((names (%find-types-in-library filename prefix ignore)))
+    `(progn
+       ,@(mapcar #'(lambda (name)
+                    `(progn
+                       (defbinding (,(intern name) ,name) () type-number)
+                       (,(intern name))))
+                names))))
+
+
+
+;;;; Metaclass for subclasses of ginstance
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defclass ginstance-class (proxy-class)
+    ()))
+
+
+(defmethod shared-initialize ((class ginstance-class) names
+                             &rest initargs &key name alien-name)
+  (declare (ignore names))
+  (let* ((class-name (or name (class-name class)))
+        (type-number
+         (find-type-number
+          (or (first alien-name) (default-alien-type-name class-name)) t)))
+    (register-type class-name type-number)
+    (if (getf initargs :size)
+       (call-next-method)
+      (let ((size (type-instance-size type-number)))
+       (apply #'call-next-method class names :size (list size) initargs)))))

 
 
 
 

+(defmethod validate-superclass ((class ginstance-class) (super standard-class))
+  (subtypep (class-name super) 'ginstance))
+

 
 ;;;; Superclass for wrapping types in the glib type system
 
 
 ;;;; Superclass for wrapping types in the glib type system
 


@@ -217,31 +241,6 @@ (defmethod reader-function ((class ginstance-class) &rest args)
       (ensure-proxy-instance class (sap-ref-sap location offset))))
 
 
       (ensure-proxy-instance class (sap-ref-sap location offset))))
 
 

-;;;; Metaclass for subclasses of ginstance
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass ginstance-class (proxy-class)
-    ()))
-
-
-(defmethod shared-initialize ((class ginstance-class) names
-                             &rest initargs &key name alien-name)
-  (declare (ignore names))
-  (let* ((class-name (or name (class-name class)))
-        (type-number
-         (find-type-number
-          (or (first alien-name) (default-alien-type-name class-name)) t)))
-    (register-type class-name type-number)
-    (if (getf initargs :size)
-       (call-next-method)
-      (let ((size (type-instance-size type-number)))
-       (apply #'call-next-method class names :size (list size) initargs)))))
-
-
-(defmethod validate-superclass ((class ginstance-class) (super standard-class))
-  (subtypep (class-name super) 'ginstance))
-
-

 ;;;; Registering fundamental types
 
 (register-type 'nil "void")
 ;;;; Registering fundamental types
 
 (register-type 'nil "void")


@@ -345,31 +344,33 @@ (defun find-type-dependencies (type)
       (funcall list-dependencies (find-type-number type t)))))
 
 (defun %sort-types-topologicaly (types)
       (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 ())
+  (let ((partial-sorted
+        (sort
+         (mapcar 
+          #'(lambda (type)
+              (cons type (remove-if #'(lambda (dep)
+                                        (not (find dep types)))
+                                    (find-type-dependencies type))))
+          types)
+         #'(lambda (type1 type2) (type-is-p type2 type1)) :key #'car))

        (sorted ()))
 
     (loop
        (sorted ()))
 
     (loop

-     as tmp = unsorted then (or (rest tmp) unsorted)
+     as tmp = partial-sorted then (or (rest tmp) partial-sorted)

      while tmp
      do (destructuring-bind (type . dependencies) (first tmp)
          (cond
           ((every #'(lambda (dep)
      while tmp
      do (destructuring-bind (type . dependencies) (first tmp)
          (cond
           ((every #'(lambda (dep)

-                      (or (find dep forward-define) (find dep sorted)))
+                      (assoc dep sorted))

                   dependencies)
                   dependencies)

-           (push type sorted)
-           (setq unsorted (delete type unsorted :key #'first)))
+           (push (cons type nil) sorted) ; no forward definition needed
+           (setq partial-sorted (delete type partial-sorted :key #'first)))

           ((some #'(lambda (dep)
                      (find type (find-type-dependencies dep)))
                  dependencies)
           ((some #'(lambda (dep)
                      (find type (find-type-dependencies dep)))
                  dependencies)

-           (push type forward-define)))))
-
-    (values (nreverse sorted) forward-define)))
+           (push (cons type t) sorted) ; forward definition needed
+           (setq partial-sorted (delete type partial-sorted :key #'first))))))
+    (nreverse sorted)))

 
 
 (defun expand-type-definitions (prefix &optional args)
 
 
 (defun expand-type-definitions (prefix &optional args)


@@ -394,24 +395,31 @@ (defun expand-type-definitions (prefix &optional args)
                              (getf (cdr options) :except)))))
                   args))))
           (find-types prefix))))
                              (getf (cdr options) :except)))))
                   args))))
           (find-types prefix))))

-             
+

      (dolist (type-number type-list)
        (let ((name (find-type-name type-number)))
         (register-type
          (getf (type-options type-number) :type (default-type-name name))
          type-number)))
      (dolist (type-number type-list)
        (let ((name (find-type-name type-number)))
         (register-type
          (getf (type-options type-number) :type (default-type-name name))
          type-number)))

-     
-     (multiple-value-bind  (sorted-type-list forward-define)
-        (%sort-types-topologicaly type-list)
+
+     (let ((sorted-type-list (%sort-types-topologicaly type-list)))

        `(progn
          ,@(mapcar
        `(progn
          ,@(mapcar

-            #'(lambda (type)
-                (expand-type-definition type t (type-options type)))
-            forward-define)
+            #'(lambda (pair)
+                (destructuring-bind (type . forward-p) pair
+                  (expand-type-definition type forward-p (type-options type))))
+            sorted-type-list)

          ,@(mapcar
          ,@(mapcar

-            #'(lambda (type)
-                (expand-type-definition type nil (type-options type)))
+            #'(lambda (pair)
+                (destructuring-bind (type . forward-p) pair
+                  (when forward-p
+                    (expand-type-definition type nil (type-options type)))))

             sorted-type-list))))))
 
 (defmacro define-types-by-introspection (prefix &rest args)
   (expand-type-definitions prefix args))
             sorted-type-list))))))
 
 (defmacro define-types-by-introspection (prefix &rest args)
   (expand-type-definitions prefix args))

+
+
+;;;; Initialize all non static types in GObject
+
+(init-types-in-library #.(concatenate 'string (pkg-config:pkg-variable "glib-2.0" "libdir") "/libgobject-2.0.so"))