X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/dfa4f31424800fdb6fb63514121b9cc893269276..13d35622e85876f34d62b22cfdf6f5d5e465c1de:/glib/gtype.lisp

diff --git a/glib/gtype.lisp b/glib/gtype.lisp
index 33c8baf..8c43347 100644
--- 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.27 2005-03-06 17:26:23 espen Exp $
+;; $Id: gtype.lisp,v 1.30 2005-03-12 19:38:12 espen Exp $
 
 (in-package "GLIB")
 
@@ -201,7 +201,7 @@
 	(process-close process)))))
 
 
-(defmacro init-types-in-library (filename &key (prefix "") ignore)
+(defmacro init-types-in-library (filename &key prefix ignore)
   (let ((names (%find-types-in-library filename prefix ignore)))
     `(progn
        ,@(mapcar #'(lambda (name)
@@ -212,12 +212,16 @@
 		 names))))
 
 (defun find-type-init-function (type-number)
-  (or
-   (loop
-    for type-init in *type-initializers*
-    when (= type-number (funcall type-init))
-    do (return type-init))
-   (error "Can't find init function for type number ~D" type-number)))
+  (loop
+   for type-init in *type-initializers*
+   when (= type-number (funcall type-init))
+   do (return type-init)))
+
+(defun register-type-as (type-number)
+  (or 
+   (find-type-init-function type-number)
+   (find-foreign-type-name type-number)
+   (error "Unknown type-number: ~A" type-number)))
 
 (defun default-type-init-name (type)
   (find-symbol (format nil "~A_~A_get_type" 
@@ -233,7 +237,7 @@
     ()))
 
 
-(defmethod shared-initialize ((class ginstance-class) names &key name gtype)
+(defmethod shared-initialize ((class ginstance-class) names &rest initargs &key name gtype)
   (declare (ignore names))
   (let* ((class-name (or name (class-name class)))
 	 (type-number 
@@ -241,9 +245,10 @@
 	   (find-type-number class-name)
 	   (register-type class-name 
 	     (or (first gtype) (default-type-init-name class-name))))))
-    (call-next-method)
-    (when (slot-boundp class 'size)
-      (setf (slot-value class 'size) (type-instance-size 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))
@@ -257,17 +262,22 @@
     ((class :allocation :alien :type pointer))
     (:metaclass proxy-class)))
 
-(defun %type-of-ginstance (location)
+(defun %type-number-of-ginstance (location)
   (let ((class (sap-ref-sap location 0)))
-    (type-from-number (sap-ref-32 class 0))))
+    (sap-ref-32 class 0)))
 
 (defmethod ensure-proxy-instance ((class ginstance-class) location)
   (declare (ignore class))
-  (let ((class (find-class (%type-of-ginstance location))))
+  (let ((class (labels ((find-known-class (type-number)
+		          (or
+			   (find-class (type-from-number type-number) nil)
+			   (unless (zerop type-number)
+			     (find-known-class (type-parent type-number))))))
+		 (find-known-class (%type-number-of-ginstance location)))))
     (if class
 	(make-instance class :location (reference-foreign class location))
-      ;; TODO: (make-instance 'ginstance ...)
-      location)))
+      (error "Object at ~A has an unkown type number: ~A" 
+        location (%type-number-of-ginstance location)))))
 
 (defmethod copy-from-alien-form (location (class ginstance-class) &rest args)
   (declare (ignore location class args))
@@ -442,7 +452,7 @@
        (let ((name (find-foreign-type-name type-number)))
 	 (register-type
 	  (getf (type-options type-number) :type (default-type-name name))
-	  (find-type-init-function type-number))))
+	  (register-type-as type-number))))
 
      (let ((sorted-type-list (%sort-types-topologicaly type-list)))
        `(progn