From: espen <espen>
Date: Wed, 27 Oct 2004 14:58:59 +0000 (+0000)
Subject: Updated for CMUCL 19a and glib-2.4
X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/commitdiff_plain/4d83a8a641bfaeb0d858fbf37524f3d3b9b81a6e

Updated for CMUCL 19a and glib-2.4
---

diff --git a/glib/gboxed.lisp b/glib/gboxed.lisp
index 31c2361..f3a6270 100644
--- 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.9 2002-03-19 17:06:11 espen Exp $
+;; $Id: gboxed.lisp,v 1.10 2004-10-27 14:58:59 espen Exp $
 
 (in-package "GLIB")
 
@@ -40,7 +40,8 @@ (defbinding %boxed-free (type location) nil
 ;;;; Metaclass for boxed classes
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass boxed-class (proxy-class))
+  (defclass boxed-class (proxy-class)
+    ())
 
 
   (defmethod shared-initialize ((class boxed-class) names
diff --git a/glib/gcallback.lisp b/glib/gcallback.lisp
index b872c4a..d2a5d78 100644
--- a/glib/gcallback.lisp
+++ b/glib/gcallback.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: gcallback.lisp,v 1.8 2002-03-24 15:43:16 espen Exp $
+;; $Id: gcallback.lisp,v 1.9 2004-10-27 14:58:59 espen Exp $
 
 (in-package "GLIB")
 
@@ -54,7 +54,7 @@ (defun callback-trampoline (callback-id params return-value)
 		   (unwind-protect
 		       (let ((result (apply callback-function (reverse args))))
 			 (when return-type
-			   (gvalue-set (print return-value) result))))
+			   (gvalue-set return-value result))))
 		
 		 (continue nil :report "Return from callback function"
 		  (when return-type
@@ -160,6 +160,11 @@ (defbinding signal-handler-disconnect () nil
 
 
 (defmethod signal-connect ((gobject gobject) signal function &key after object)
+"Connects a callback function to a signal for a particular object. If :OBJECT 
+ is T, the object connected to is passed as the first argument to the callback 
+ function, or if :OBJECT is any other non NIL value, it is passed as the first 
+ argument instead. If :AFTER is non NIL, the handler will be called after the 
+ default handler of the signal."
   (let ((callback-id
 	 (make-callback-closure
 	  (cond
diff --git a/glib/ginterface.lisp b/glib/ginterface.lisp
index ca61631..906606a 100644
--- 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.1 2002-01-20 14:05:27 espen Exp $
+;; $Id: ginterface.lisp,v 1.2 2004-10-27 14:58:59 espen Exp $
 
 (in-package "GLIB")
 
@@ -23,7 +23,8 @@ (use-prefix "g")
 
 ;;;; 
 
-(defclass ginterface ())
+(defclass ginterface ()
+  ())
 
 (deftype-method translate-type-spec ginterface (type-spec)
   (declare (ignore type-spec))
@@ -48,7 +49,8 @@ (deftype-method translate-to-alien
 ;;;; Metaclass for interfaces
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass ginterface-class (pcl::standard-class)))
+  (defclass ginterface-class (virtual-slot-class)
+    ()))
 
 
 (defmethod shared-initialize ((class ginterface-class) names
@@ -69,10 +71,10 @@ (defmethod validate-superclass
 
 ;;;;
 
-(defun expand-ginterface-type (type-number &rest args)
+(defun expand-ginterface-type (type-number options &rest args)
   (declare (ignore args))
   `(defclass ,(type-from-number type-number) (ginterface)
-     ()
+     ,(getf options :slots)
      (:metaclass ginterface-class)
      (:alien-name ,(find-type-name type-number))))
 
diff --git a/glib/glib.lisp b/glib/glib.lisp
index 9093a13..8817459 100644
--- a/glib/glib.lisp
+++ b/glib/glib.lisp
@@ -15,13 +15,14 @@
 ;; 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: glib.lisp,v 1.12 2002-01-20 14:06:50 espen Exp $
+;; $Id: glib.lisp,v 1.13 2004-10-27 14:58:59 espen Exp $
 
 
 (in-package "GLIB")
 
 (use-prefix "g")
 
+;(load-shared-library "libglib-2.0")
 
 ;;;; Memory management
 
@@ -351,10 +352,10 @@ (deftype-method unreference-alien vector (type-spec c-vector)
 		  `(dotimes (i ,length)
 		     (unreference-alien
 		      element-type (sap-ref-sap c-vector (* i ,element-size))))
-		`(do ((offset 0 (+ offset ,element-size))
+		`(do ((offset 0 (+ offset ,element-size)))
 		      ((sap=
 			(sap-ref-sap c-vector offset)
-			*magic-end-of-array*)))
+			*magic-end-of-array*))
 		     ,(unreference-alien
 		       element-type '(sap-ref-sap c-vector offset))))))
 	 (deallocate-memory c-vector)))))
diff --git a/glib/gobject.lisp b/glib/gobject.lisp
index e556238..dc6bd78 100644
--- 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.12 2002-04-02 14:57:19 espen Exp $
+;; $Id: gobject.lisp,v 1.13 2004-10-27 14:58:59 espen Exp $
 
 (in-package "GLIB")
 
@@ -28,22 +28,52 @@   (defclass gobject (ginstance)
     (:copy %object-ref)
     (:free %object-unref)))
 
+
 (defmethod initialize-instance ((object gobject) &rest initargs)
-  (declare (ignore initargs))
-  (setf  (slot-value object 'location) (%gobject-new (type-number-of object)))
-  (call-next-method))
+  (let ((slotds (class-slots (class-of object)))
+	(names (make-array 0 :adjustable t :fill-pointer t))
+	(values (make-array 0 :adjustable t :fill-pointer t)))
+
+    (loop 
+     as tmp = initargs then (cddr tmp) while tmp
+     as key = (first tmp)
+     as value = (second tmp)
+     as slotd = (find-if
+		 #'(lambda (slotd)
+		     (member key (slot-definition-initargs slotd)))
+		 slotds)
+     when (and (typep slotd 'effective-gobject-slot-definition)
+	       (slot-value slotd 'construct))
+     do (let ((type (find-type-number (slot-definition-type slotd))))
+	  (vector-push-extend (slot-definition-pname slotd) names)
+	  (vector-push-extend (gvalue-new type value) values)
+	  (remf initargs key)))
+
+    (setf  
+     (slot-value object 'location) 
+     (if (zerop (length names))
+	 (%gobject-new (type-number-of object))
+       (%gobject-newvv (type-number-of object) (length names) names values))))
+  (apply #'call-next-method object initargs))
+
+
 
 (defbinding (%gobject-new "g_object_new") () pointer
   (type type-number)
   (nil null))
 
+(defbinding (%gobject-newvv "g_object_newvv") () pointer
+  (type type-number)
+  (n-parameters unsigned-int)
+  (names (vector string))
+  (values (vector gvalue)))
 
-(defbinding %object-ref (type location) pointer
-  (location pointer))
 
-(defbinding %object-unref (type location) nil
+(defbinding %object-ref (type location) pointer
   (location pointer))
 
+ (defbinding %object-unref (type location) nil
+   (location pointer))
 
 (defun object-ref (object)
   (%object-ref nil (proxy-location object)))
@@ -103,15 +133,22 @@ (defun object-data (object key &key (test #'eq))
 ;;;; Metaclass used for subclasses of gobject
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass gobject-class (ginstance-class))
+  (defclass gobject-class (ginstance-class)
+    ())
 
   (defclass direct-gobject-slot-definition (direct-virtual-slot-definition)
-    ((pname :reader slot-definition-pname)))
+    ((pname :reader slot-definition-pname :initarg :pname)
+     (readable :initform t :reader slot-readable-p :initarg :readable)
+     (writable :initform t :reader slot-writable-p :initarg :writable)
+     (construct :initform nil :initarg :construct)))
+
+  (defclass effective-gobject-slot-definition (effective-virtual-slot-definition)
+    ((pname :reader slot-definition-pname :initarg :pname)
+     (readable :reader slot-readable-p :initarg :readable)
+     (writable :reader slot-writable-p :initarg :writable)
+     (construct :initarg :construct))))
 
-  (defclass effective-gobject-slot-definition
-    (effective-virtual-slot-definition)))
 
-  
 
 ; (defbinding object-class-install-param () nil
 ;   (class pointer)
@@ -125,51 +162,75 @@   (defclass effective-gobject-slot-definition
 (defun signal-name-to-string (name)
   (substitute #\_ #\- (string-downcase (string name))))
 
-(defmethod initialize-instance :after ((slotd direct-gobject-slot-definition)
-				       &rest initargs &key pname)
-  (declare (ignore initargs))
-  (when pname
-    (setf
-     (slot-value slotd 'pname)
-     (signal-name-to-string (slot-definition-name slotd)))))
 
-(defmethod direct-slot-definition-class ((class gobject-class) initargs)
+(defmethod direct-slot-definition-class ((class gobject-class) &rest initargs)
   (case (getf initargs :allocation)
     (:property (find-class 'direct-gobject-slot-definition))
     (t (call-next-method))))
 
-(defmethod effective-slot-definition-class ((class gobject-class) initargs)
+(defmethod effective-slot-definition-class ((class gobject-class) &rest initargs)
   (case (getf initargs :allocation)
     (:property (find-class 'effective-gobject-slot-definition))
     (t (call-next-method))))
 
-(defmethod compute-virtual-slot-accessors
-    ((class gobject-class) (slotd effective-gobject-slot-definition)
-     direct-slotds)
-  (with-slots (type) slotd
-    (let ((pname (slot-definition-pname (first direct-slotds)))
-	  (type-number (find-type-number type)))
-      (list
+(defmethod compute-effective-slot-definition-initargs ((class gobject-class) direct-slotds)
+  (if (eq (most-specific-slot-value direct-slotds 'allocation) :property)
+      (nconc 
+       (list :pname (signal-name-to-string 
+		     (most-specific-slot-value direct-slotds 'pname))
+	     :readable (most-specific-slot-value direct-slotds 'readable)
+	     :writable (most-specific-slot-value direct-slotds 'writable)
+	     :construct (most-specific-slot-value direct-slotds 'construct))
+       (call-next-method))
+    (call-next-method)))
+
+
+(defmethod initialize-internal-slot-functions ((slotd effective-gobject-slot-definition))
+  (let* ((type (slot-definition-type slotd))
+	 (pname (slot-definition-pname slotd))
+	 (type-number (find-type-number type)))
+    (unless (slot-boundp slotd 'reader-function)
+      (setf 
+       (slot-value slotd 'reader-function)
+       (if (slot-readable-p slotd)
+	   #'(lambda (object)
+	       (with-gc-disabled
+		   (let ((gvalue (gvalue-new type-number)))
+		     (%object-get-property object pname gvalue)
+		     (unwind-protect
+			  (funcall
+			   (intern-reader-function (type-from-number type-number)) gvalue +gvalue-value-offset+) ; temporary workaround for wrong topological sorting of types
+		       (gvalue-free gvalue t)))))
+	   #'(lambda (value object)
+	       (error "Slot is not readable: ~A" (slot-definition-name slotd))))))
+    
+    (unless (slot-boundp slotd 'writer-function)
+      (setf 
+       (slot-value slotd 'writer-function)
+       (if (slot-writable-p slotd)
+	   #'(lambda (value object)
+	       (with-gc-disabled
+		   (let ((gvalue (gvalue-new type-number)))
+		     (funcall
+		      (intern-writer-function (type-from-number type-number)) ; temporary
+		      value gvalue +gvalue-value-offset+)
+		     (%object-set-property object pname gvalue)
+		     (funcall
+		      (intern-destroy-function (type-from-number type-number)) ; temporary
+		      gvalue +gvalue-value-offset+)
+		     (gvalue-free gvalue nil)
+		     value)))
+ 	   #'(lambda (value object)
+ 	       (error "Slot is not writable: ~A" (slot-definition-name slotd))))))
+    
+    (unless (slot-boundp slotd 'boundp-function)
+      (setf 
+       (slot-value slotd 'boundp-function)
        #'(lambda (object)
-	   (with-gc-disabled
-	     (let ((gvalue (gvalue-new type-number)))
-	       (%object-get-property object pname gvalue)
-	       (unwind-protect
-		   (funcall
-		    (intern-reader-function (type-from-number type-number)) gvalue +gvalue-value-offset+) ; temporary workaround for wrong topological sorting of types
-		 (gvalue-free gvalue t)))))
-       #'(lambda (value object)
-	   (with-gc-disabled
-  	     (let ((gvalue (gvalue-new type-number)))
-	       (funcall
-		(intern-writer-function (type-from-number type-number)) ; temporary
-		value gvalue +gvalue-value-offset+)
-	       (%object-set-property object pname gvalue)
-	       (funcall
-		(intern-destroy-function (type-from-number type-number)) ; temporary
-		gvalue +gvalue-value-offset+)
-	       (gvalue-free gvalue nil)
-	       value)))))))
+	   (declare (ignore object))
+	   t))))
+  (call-next-method))
+
 
 (defmethod validate-superclass ((class gobject-class)
 				(super pcl::standard-class))
@@ -208,35 +269,50 @@ (defun default-slot-accessor (class-name slot-name type)
   (intern
    (format
     nil "~A-~A~A" class-name slot-name
-    (if (eq 'boolean type) "-P" ""))))
+    (if (eq type 'boolean) "-P" ""))))
 
 (defun expand-gobject-type (type-number &optional options
 			    (metaclass 'gobject-class))
   (let* ((supers (cons (supertype type-number) (implements type-number)))
 	 (class  (type-from-number type-number))
-	 (override-slots (getf options :slots))
+	 (manual-slots (getf options :slots))
 	 (expanded-slots
 	  (mapcar
 	   #'(lambda (param)
 	       (with-slots (name flags value-type documentation) param
 	         (let* ((slot-name (default-slot-name name))
-			(slot-type value-type) ;(type-from-number value-type t))
+;			(slot-type value-type) ;(type-from-number value-type t))
+			(slot-type (or (type-from-number value-type) value-type))
 			(accessor
-			 (default-slot-accessor class slot-name (type-from-number slot-type)))) ; temporary workaround for wrong topological sorting of types
+			 (default-slot-accessor class slot-name slot-type)));(type-from-number slot-type)))) ; temporary workaround for wrong topological sorting of types
+
 		   `(,slot-name
 		     :allocation :property
 		     :pname ,name
 		     ,@(cond
 			((and
 			  (member :writable flags)
-			  (member :readable flags))
+			  (member :readable flags)
+			  (not (member :construct-only flags)))
 			 (list :accessor accessor))
-			((member :writable flags)
+			((and (member :writable flags)
+			      (not (member :construct-only flags)))
 			 (list :writer `(setf ,accessor)))
 			((member :readable flags)
 			 (list :reader accessor)))
+		     ,@(when (or
+			      (not (member :writable flags))
+			      (member :construct-only flags))
+		         (list :writable nil))
+		     ,@(when (not (member :readable flags))
+		         (list :readable nil))
+		     ,@(when (or 
+			      (member :construct flags)
+			      (member :construct-only flags))
+		         (list :construct t))
 		     ,@(when (or
 			      (member :construct flags)
+			      (member :construct-only flags)
 			      (member :writable flags))
 			 (list :initarg (intern (string slot-name) "KEYWORD")))
 		     :type ,slot-type
@@ -244,7 +320,7 @@ 			 (default-slot-accessor class slot-name (type-from-number slot-type)))) ; tem
 			 (list :documentation documentation))))))
 	   (query-object-class-properties type-number))))
 
-    (dolist (slot-def override-slots)
+    (dolist (slot-def (reverse manual-slots))
       (let ((name (car slot-def))
 	    (pname (getf (cdr slot-def) :pname)))
 	(setq
diff --git a/glib/gparam.lisp b/glib/gparam.lisp
index 9e7b91c..c589a18 100644
--- a/glib/gparam.lisp
+++ b/glib/gparam.lisp
@@ -15,22 +15,29 @@
 ;; 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: gparam.lisp,v 1.6 2002-03-19 17:01:42 espen Exp $
+;; $Id: gparam.lisp,v 1.7 2004-10-27 14:59:00 espen Exp $
 
 (in-package "GLIB")
 
 (deftype gvalue () 'pointer)
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defbinding (size-of-gvalue "size_of_gvalue") () unsigned-int))
+
 (defconstant +gvalue-size+ (+ (size-of 'type-number) (* 2 (size-of 'double-float))))
+(defconstant +gvalue-size+ #.(size-of-gvalue))
+
 (defconstant +gvalue-value-offset+ (size-of 'type-number))
 
 (defbinding (gvalue-init "g_value_init") () nil
+  (value gvalue)
   (type type-number))
 
-(defun gvalue-new (type)
+(defun gvalue-new (type &optional (value nil value-p))
   (let ((gvalue (allocate-memory +gvalue-size+)))
-    (setf (system:sap-ref-32 gvalue 0) type)
-;    (gvalue-init (type-number-of type))
+    (gvalue-init gvalue (find-type-number type))
+    (when value-p
+      (gvalue-set gvalue value))
     gvalue))
 
 (defun gvalue-free (gvalue free-content)
@@ -56,6 +63,11 @@ (defun gvalue-set (gvalue value)
   value)
 
 
+(deftype-method unreference-alien gvalue (type-spec location)
+  `(gvalue-free ,location nil))
+
+
+
 (deftype param-flag-type ()
   '(flags
     (:readable 1)
@@ -65,7 +77,8 @@ (deftype param-flag-type ()
     (:lax-validation 16)
     (:private 32)))
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
+;(eval-when (:compile-toplevel :load-toplevel :execute)
+;; TODO: rename to param-spec
   (defclass param (ginstance)
     ((name
       :allocation :alien
@@ -95,7 +108,7 @@   (defclass param (ginstance)
       :type string))
     (:metaclass ginstance-class)
     (:ref "g_param_spec_ref")
-    (:unref "g_param_spec_unref")))
+    (:unref "g_param_spec_unref"));)
 
 
 (defclass param-char (param)
@@ -303,6 +316,3 @@ (defclass param-value-array (param)
 (defclass param-object (param)
   ()
   (:metaclass ginstance-class))
-
-
-
diff --git a/glib/gtype.lisp b/glib/gtype.lisp
index 2b4a2d0..02f9677 100644
--- a/glib/gtype.lisp
+++ b/glib/gtype.lisp
@@ -15,12 +15,14 @@
 ;; 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.16 2002-03-24 12:56:03 espen Exp $
+;; $Id: gtype.lisp,v 1.17 2004-10-27 14:59:00 espen Exp $
 
 (in-package "GLIB")
 
 (use-prefix "g")
 
+;(load-shared-library "libgobject-2.0" :init "g_type_init")
+
 ;;;; 
 
 (deftype type-number () '(unsigned 32))
@@ -68,9 +70,11 @@ (defun register-type (type id)
   (let ((type-number
 	 (etypecase id
 	   (integer id)
-	   (string (find-type-number id t)))))
+	   (string (find-type-number id t))
+	   (symbol (gethash id *type-to-number-hash*)))))
     (setf (gethash type *type-to-number-hash*) type-number)
-    (setf (gethash type-number *number-to-type-hash*) type)
+    (unless (symbolp id)
+      (setf (gethash type-number *number-to-type-hash*) type))
     type-number))
 
 (defbinding %type-from-name () type-number
@@ -167,21 +171,23 @@ (deftype-method translate-from-alien
 ;;;; Metaclass for subclasses of ginstance
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass ginstance-class (proxy-class)))
+  (defclass ginstance-class (proxy-class)
+    ()))
 
 
 (defmethod shared-initialize ((class ginstance-class) names
 			      &rest initargs &key name alien-name
-			      size ref unref)
+			      ref unref)
   (declare (ignore initargs 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)
-    (let ((size (or size (type-instance-size type-number))))
-      (declare (special size))
-      (call-next-method)))
+    (if (getf initargs :size)
+	(call-next-method)
+      (let ((size (type-instance-size type-number)))
+	(apply #'call-next-method class names :size (list size) initargs))))
 
   (when ref
     (let ((ref (mkbinding (first ref) 'pointer 'pointer)))
@@ -189,7 +195,7 @@ (defmethod shared-initialize ((class ginstance-class) names
        (slot-value class 'copy)
        #'(lambda (type location)
 	   (declare (ignore type))
-	   (funcall ref location)))))     
+	   (funcall ref location)))))
   (when unref
     (let ((unref (mkbinding (first unref) 'nil 'pointer)))
       (setf
diff --git a/glib/pcl.lisp b/glib/pcl.lisp
index 39b973a..cba663d 100644
--- a/glib/pcl.lisp
+++ b/glib/pcl.lisp
@@ -26,111 +26,94 @@
 ;;; Modifications for better AMOP conformance
 ;;; Copyright (C) 2001 Espen S. Johnsen <esj@stud.cs.uit.no>
 
-(in-package "PCL")
-
-;;;; Adding initargs parameter to change-class
 
-(defun change-class-internal (instance new-class initargs)
-  (let* ((old-class (class-of instance))
-	 (copy (allocate-instance new-class))
-	 (new-wrapper (get-wrapper copy))
-	 (old-wrapper (class-wrapper old-class))
-	 (old-layout (wrapper-instance-slots-layout old-wrapper))
-	 (new-layout (wrapper-instance-slots-layout new-wrapper))
-	 (old-slots (get-slots instance))
-	 (new-slots (get-slots copy))
-	 (old-class-slots (wrapper-class-slots old-wrapper)))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setf (ext:package-lock (find-package "PCL")) nil))
 
-    ;;
-    ;; "The values of local slots specified by both the class Cto and
-    ;; Cfrom are retained.  If such a local slot was unbound, it remains
-    ;; unbound."
-    ;;     
-    (iterate ((new-slot (list-elements new-layout))
-	      (new-position (interval :from 0)))
-      (let ((old-position (posq new-slot old-layout)))
-	(when old-position
-	  (setf (instance-ref new-slots new-position)
-		(instance-ref old-slots old-position)))))
+(in-package "PCL")
 
+(defstruct slot-info
+  (name nil :type symbol)
+  ;;
+  ;; Specified slot allocation.or :INSTANCE.
+  (allocation :instance :type symbol)
+  ;;
+  ;; Specified slot type or T.
+  (type t :type (or symbol list number)))
+
+
+(defmethod compute-slots :around ((class standard-class))
+  (loop with slotds = (call-next-method) and location = -1
+	for slot in slotds do
+	  (setf (slot-definition-location slot)
+		(case (slot-definition-allocation slot)
+		  (:instance
+		   (incf location))
+		  (:class
+		   (let* ((name (slot-definition-name slot))
+			  (from-class (slot-definition-allocation-class slot))
+			  (cell (assq name (class-slot-cells from-class))))
+		     (assert (consp cell))
+		     cell))))
+	  (initialize-internal-slot-functions slot)
+	finally
+	  (return slotds)))
+
+
+
+(defun update-slots (class eslotds)
+  (collect ((instance-slots) (class-slots))
+    (dolist (eslotd eslotds)
+      (case (slot-definition-allocation eslotd)
+	(:instance (instance-slots eslotd))
+	(:class (class-slots eslotd))))
     ;;
-    ;; "The values of slots specified as shared in the class Cfrom and
-    ;; as local in the class Cto are retained."
-    ;;
-    (iterate ((slot-and-val (list-elements old-class-slots)))
-      (let ((position (posq (car slot-and-val) new-layout)))
-	(when position
-	  (setf (instance-ref new-slots position) (cdr slot-and-val)))))
-
-    ;; Make the copy point to the old instance's storage, and make the
-    ;; old instance point to the new storage.
-    (swap-wrappers-and-slots instance copy)
-
-    (apply #'update-instance-for-different-class copy instance initargs)
-    instance))
-
-
-(fmakunbound 'change-class)
-(defgeneric change-class (instance new-class &rest initargs))
-
-(defmethod change-class ((instance standard-object)
-			 (new-class standard-class)
-			 &rest initargs)
-  (change-class-internal instance new-class initargs))
-
-(defmethod change-class ((instance funcallable-standard-object)
-			 (new-class funcallable-standard-class)
-			 &rest initargs)
-  (change-class-internal instance new-class initargs))
-
-(defmethod change-class ((instance standard-object)
-			 (new-class funcallable-standard-class)
-			 &rest initargs)
-  (declare (ignore initargs))
-  (error "Can't change the class of ~S to ~S~@
-          because it isn't already an instance with metaclass ~S."
-	 instance new-class 'standard-class))
-
-(defmethod change-class ((instance funcallable-standard-object)
-			 (new-class standard-class)
-			 &rest initargs)
-  (declare (ignore initargs))
-  (error "Can't change the class of ~S to ~S~@
-          because it isn't already an instance with metaclass ~S."
-	 instance new-class 'funcallable-standard-class))
-
-(defmethod change-class ((instance t) (new-class symbol) &rest initargs)
-  (change-class instance (find-class new-class) initargs))
-
-
-;;;; Make the class finalization protocol behave as specified in AMOP
-
-(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
-  (multiple-value-bind (meta initargs)
-      (ensure-class-values class args)
-    (if (eq (class-of class) meta)
-	(apply #'reinitialize-instance class initargs)
-      (apply #'change-class class meta initargs))
-    (setf (find-class name) class)
-    (inform-type-system-about-class class name)
-    class))
-
-(defmethod finalize-inheritance ((class std-class))
-  (dolist (super (class-direct-superclasses class))
-    (unless (class-finalized-p super) (finalize-inheritance super)))
-  (update-cpl class (compute-class-precedence-list class))
-  (update-slots class (compute-slots class))
-  (update-gfs-of-class class)
-  (update-inits class (compute-default-initargs class))
-  (update-make-instance-function-table class))
-
-(defmethod finalize-inheritance ((class forward-referenced-class))
-  (error "~A can't be finalized" class))
-
-(defun update-class (class &optional finalizep)  
-  (declare (ignore finalizep))
-  (unless (class-has-a-forward-referenced-superclass-p class)
-    (finalize-inheritance class)
-    (dolist (sub (class-direct-subclasses class))
-      (update-class sub))))
+    ;; If there is a change in the shape of the instances then the
+    ;; old class is now obsolete.
+    (let* ((nlayout (mapcar #'slot-definition-name
+			    (sort (instance-slots) #'<
+				  :key #'slot-definition-location)))
+	   (nslots (length nlayout))
+	   (nwrapper-class-slots (compute-class-slots (class-slots)))
+	   (owrapper (when (class-finalized-p class)
+		       (class-wrapper class)))
+	   (olayout (when owrapper
+		      (wrapper-instance-slots-layout owrapper)))
+	   (nwrapper
+	    (cond ((null owrapper)
+		   (make-wrapper nslots class))
+		  ;;
+		  ;; We cannot reuse the old wrapper easily when it
+		  ;; has class slot cells, even if these cells are
+		  ;; EQUAL to the ones used in the new wrapper.  The
+		  ;; class slot cells of OWRAPPER may be referenced
+		  ;; from caches, and if we don't change the wrapper,
+		  ;; the caches won't notice that something has
+		  ;; changed.  We could do something here manually,
+		  ;; but I don't think it's worth it.
+		  ((and (equal nlayout olayout)
+			(null (wrapper-class-slots owrapper)))
+		   owrapper)
+		  (t
+		   ;;
+		   ;; This will initialize the new wrapper to have the same
+		   ;; state as the old wrapper.  We will then have to change
+		   ;; that.  This may seem like wasted work (it is), but the
+		   ;; spec requires that we call make-instances-obsolete.
+		   (make-instances-obsolete class)
+		   (class-wrapper class)))))
+
+      (with-slots (wrapper slots finalized-p) class
+	(update-lisp-class-layout class nwrapper)
+	(setf slots eslotds
+	      (wrapper-instance-slots-layout nwrapper) nlayout
+	      (wrapper-class-slots nwrapper) nwrapper-class-slots
+	      (wrapper-no-of-instance-slots nwrapper) nslots
+	      wrapper nwrapper
+	      finalized-p t))
+
+      (unless (eq owrapper nwrapper)
+	(update-inline-access class)
+	(update-pv-table-cache-info class)
+	(maybe-update-standard-class-locations class)))))
 
diff --git a/glib/proxy.lisp b/glib/proxy.lisp
index 7831a76..fa1e518 100644
--- a/glib/proxy.lisp
+++ b/glib/proxy.lisp
@@ -15,97 +15,127 @@
 ;; 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: proxy.lisp,v 1.7 2002-01-20 14:52:04 espen Exp $
+;; $Id: proxy.lisp,v 1.8 2004-10-27 14:59:00 espen Exp $
 
 (in-package "GLIB")
 
+(import 
+'(pcl::initialize-internal-slot-functions
+  pcl::compute-effective-slot-definition-initargs
+  pcl::compute-slot-accessor-info
+  pcl::reader-function pcl::writer-function pcl::boundp-function))
 
 ;;;; Superclass for all metaclasses implementing some sort of virtual slots
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass virtual-slot-class (pcl::standard-class))
+  (defclass virtual-slot-class (standard-class) 
+    ())
 
   (defclass direct-virtual-slot-definition (standard-direct-slot-definition)
     ((setter :reader slot-definition-setter :initarg :setter)
-     (getter :reader slot-definition-getter :initarg :getter)))
+     (getter :reader slot-definition-getter :initarg :getter)
+     (boundp :reader slot-definition-boundp :initarg :boundp)))
   
-  (defclass effective-virtual-slot-definition
-    (standard-effective-slot-definition)))
+  (defclass effective-virtual-slot-definition (standard-effective-slot-definition)
+    ((setter :reader slot-definition-setter :initarg :setter)
+     (getter :reader slot-definition-getter :initarg :getter)
+     (boundp :reader slot-definition-boundp :initarg :boundp)))
+
+  (defun most-specific-slot-value (instances slot &optional default)
+    (let ((object (find-if
+		   #'(lambda (ob)
+		       (and (slot-exists-p ob slot) (slot-boundp ob slot)))
+		   instances)))
+      (if object
+	  (slot-value object slot)
+	  default)))
+)
+
   
 
-(defmethod direct-slot-definition-class ((class virtual-slot-class) initargs)
+(defmethod direct-slot-definition-class ((class virtual-slot-class) &rest initargs)
   (if (eq (getf initargs :allocation) :virtual)
       (find-class 'direct-virtual-slot-definition)
     (call-next-method)))
 
-(defmethod effective-slot-definition-class ((class virtual-slot-class) initargs)
+(defmethod effective-slot-definition-class ((class virtual-slot-class) &rest initargs)
   (if (eq (getf initargs :allocation) :virtual)
       (find-class 'effective-virtual-slot-definition)
     (call-next-method)))
 
-(defun %most-specific-slot-value (slotds slot &optional default)
-  (let ((slotd
-	 (find-if
-	  #'(lambda (slotd)
-	      (and
-	       (slot-exists-p slotd slot)
-	       (slot-boundp slotd slot)))
-	  slotds)))
-    (if slotd
-	(slot-value slotd slot)
-      default)))
- 
-(defgeneric compute-virtual-slot-accessors (class slotd direct-slotds))
-
-(defmethod compute-virtual-slot-accessors
-    ((class virtual-slot-class)
-     (slotd effective-virtual-slot-definition)
-     direct-slotds)
-    (let ((getter (%most-specific-slot-value direct-slotds 'getter))
-	  (setter (%most-specific-slot-value direct-slotds 'setter)))
-      (list getter setter)))
-
-(defmethod compute-effective-slot-definition
-    ((class virtual-slot-class) direct-slotds)
-  (let ((slotd (call-next-method)))
-    (when (typep slotd 'effective-virtual-slot-definition)
-      (setf
-       (slot-value slotd 'pcl::location)
-       (compute-virtual-slot-accessors class slotd direct-slotds)))
-    slotd))
+
+(defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
+  (with-slots (getter setter boundp) slotd
+    (unless (slot-boundp slotd 'reader-function)
+      (setf 
+       (slot-value slotd 'reader-function)
+       (etypecase getter
+	 (function getter)
+	 (null #'(lambda (object)
+		   (declare (ignore object))
+		   (error "Can't read slot: ~A" (slot-definition-name slotd))))
+	 (symbol #'(lambda (object)
+		     (funcall getter object))))))
+
+    (unless (slot-boundp slotd 'writer-function)
+      (setf 
+       (slot-value slotd 'writer-function)
+       (etypecase setter
+	 (function setter)
+	 (null #'(lambda (object)
+		   (declare (ignore object))
+		   (error "Can't set slot: ~A" (slot-definition-name slotd))))
+	 ((or symbol cons) #'(lambda (value object)
+			       (funcall (fdefinition setter) value object))))))
+
+    (unless (slot-boundp slotd 'boundp-function)
+      (setf 
+       (slot-value slotd 'boundp-function)
+       (etypecase boundp
+	 (function boundp)
+	 (null #'(lambda (object)
+		   (declare (ignore object))
+		   t))
+	 (symbol #'(lambda (object)
+		     (funcall boundp object)))))))
+  (initialize-internal-slot-gfs (slot-definition-name slotd)))
+
+
+
+(defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition)
+					    type gf)
+  nil)
+
+(defmethod compute-effective-slot-definition-initargs ((class virtual-slot-class) direct-slotds)
+  (if (eq (most-specific-slot-value direct-slotds 'allocation) :virtual)
+      (nconc 
+       (list :getter (most-specific-slot-value direct-slotds 'getter)
+	     :setter (most-specific-slot-value direct-slotds 'setter)
+	     :boundp (most-specific-slot-value direct-slotds 'boundp))
+       (call-next-method))
+    (call-next-method)))
+
 
 (defmethod slot-value-using-class
     ((class virtual-slot-class) (object standard-object)
      (slotd effective-virtual-slot-definition))
-  (let ((reader (first (slot-definition-location slotd))))
-    (if reader
-	(funcall reader object)
-      (slot-unbound class object (slot-definition-name slotd)))))
+  (if (funcall (slot-value slotd 'boundp-function) object)
+      (funcall (slot-value slotd 'reader-function) object)
+    (slot-unbound class object (slot-definition-name slotd))))
 
 (defmethod slot-boundp-using-class
     ((class virtual-slot-class) (object standard-object)
      (slotd effective-virtual-slot-definition))
-   (and (first (slot-definition-location slotd)) t))
-    
-(defmethod (setf slot-value-using-class)
+  (funcall (slot-value slotd 'boundp-function) object))
+  
+(defmethod (setf slot-value-using-class) 
     (value (class virtual-slot-class) (object standard-object)
      (slotd effective-virtual-slot-definition))
-  (let ((setter (second (slot-definition-location slotd))))
-    (cond
-     ((null setter)
-      (error
-       "Can't set read-only slot ~A in ~A"
-       (slot-definition-name slotd)
-       object))
-     ((or (functionp setter) (symbolp setter))
-      (funcall setter value object)
-      value)
-     (t
-      (funcall (fdefinition setter) value object)
-      value))))
-	
+  (funcall (slot-value slotd 'writer-function) value object))
+
+  
 (defmethod validate-superclass
-    ((class virtual-slot-class) (super pcl::standard-class))
+    ((class virtual-slot-class) (super standard-class))
   t)
 
 
@@ -159,15 +189,14 @@ (defmethod initialize-proxy ((instance proxy)
   (ext:finalize instance (instance-finalizer instance)))
 
 (defmethod instance-finalizer ((instance proxy))
-  (let ((free (proxy-class-free (class-of instance)))
+  (let ((class (class-of instance))
 	(type (type-of instance))
 	(location (proxy-location instance)))
-    (declare
-     (type symbol type)
-     (type system-area-pointer location))
-    #'(lambda ()
-	(funcall free type location)
-	(remove-cached-instance location))))
+    (declare (type symbol type) (type system-area-pointer location))
+    (let ((free (proxy-class-free class)))
+      #'(lambda ()
+	  (funcall free type location)
+	  (remove-cached-instance location)))))
 
 
 (deftype-method translate-type-spec proxy (type-spec)
@@ -188,15 +217,19 @@ (deftype-method translate-to-alien
     proxy (type-spec instance &optional weak-ref)
   (if weak-ref
       `(proxy-location ,instance)
-    `(funcall
-      ',(proxy-class-copy (find-class type-spec))
-      ',type-spec (proxy-location ,instance))))
+      (let ((copy (proxy-class-copy (find-class type-spec)))) 
+	(if (symbolp copy)
+	    `(,copy ',type-spec (proxy-location ,instance))    
+	`(funcall ',copy ',type-spec (proxy-location ,instance))))))
 
 (deftype-method unreference-alien proxy (type-spec location)
-  `(funcall ',(proxy-class-free (find-class type-spec)) ',type-spec ,location))
+  (let ((free (proxy-class-free (find-class type-spec)))) 
+    (if (symbolp free)
+	`(,free ',type-spec ,location)
+    `(funcall ',free ',type-spec ,location))))
 
-(defun proxy-instance-size (proxy)
-  (proxy-class-size (class-of proxy)))
+;; (defun proxy-instance-size (proxy)
+;;   (proxy-class-size (class-of proxy)))
 
 ;;;; Metaclass used for subclasses of proxy
 
@@ -211,119 +244,145 @@   (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
      (offset :reader slot-definition-offset :initarg :offset)))
   
   (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
-    ((offset :reader slot-definition-offset)))
+    ((offset :reader slot-definition-offset :initarg :offset)))
   
-  (defclass effective-virtual-alien-slot-definition
-    (effective-virtual-slot-definition))
+  (defclass effective-virtual-alien-slot-definition (effective-virtual-slot-definition)
+    ())
 
 
   (defmethod most-specific-proxy-superclass ((class proxy-class))
     (find-if
      #'(lambda (class)
 	 (subtypep (class-name class) 'proxy))
-     (cdr (pcl::compute-class-precedence-list class))))
-
+     (cdr (compute-class-precedence-list class))))
+  
   (defmethod direct-proxy-superclass ((class proxy-class))
     (find-if
      #'(lambda (class)
 	 (subtypep (class-name class) 'proxy))
-     (pcl::class-direct-superclasses class)))
-
+     (class-direct-superclasses class)))
+  
   (defmethod shared-initialize ((class proxy-class) names
 				&rest initargs &key size copy free)
     (declare (ignore initargs))
     (call-next-method)
     (cond
-     (size (setf (slot-value class 'size) (first size)))
-     ((slot-boundp class 'size) (slot-makunbound class 'size)))
+      (size (setf (slot-value class 'size) (first size)))
+      ((slot-boundp class 'size) (slot-makunbound class 'size)))
     (cond
-     (copy (setf (slot-value class 'copy) (first copy)))
-     ((slot-boundp class 'copy) (slot-makunbound class 'copy)))
+      (copy (setf (slot-value class 'copy) (first copy)))
+      ((slot-boundp class 'copy) (slot-makunbound class 'copy)))
     (cond
-     (free (setf (slot-value class 'free) (first free)))
-     ((slot-boundp class 'free) (slot-makunbound class 'free))))
-
-  (defmethod finalize-inheritance ((class proxy-class))
-    (call-next-method)
+      (free (setf (slot-value class 'free) (first free)))
+      ((slot-boundp class 'free) (slot-makunbound class 'free))))
+  
+;;   (defmethod finalize-inheritance ((class proxy-class))
+;;     (call-next-method)
+  (defmethod shared-initialize :after ((class proxy-class) names &rest initargs)
     (let ((super (most-specific-proxy-superclass class)))
       (unless (or (not super) (eq super (find-class 'proxy)))
- 	(unless (or (slot-boundp class 'copy) (not (slot-boundp super 'copy)))
- 	  (setf (slot-value class 'copy) (proxy-class-copy super)))
- 	(unless (or (slot-boundp class 'free) (not (slot-boundp super 'free)))
- 	  (setf (slot-value class 'free) (proxy-class-free super))))))
-
-  (defmethod direct-slot-definition-class ((class proxy-class) initargs)
+	(unless (or (slot-boundp class 'copy) (not (slot-boundp super 'copy)))
+	  (setf (slot-value class 'copy) (proxy-class-copy super)))
+	(unless (or (slot-boundp class 'free) (not (slot-boundp super 'free)))
+	  (setf (slot-value class 'free) (proxy-class-free super))))))
+  
+  (defmethod direct-slot-definition-class ((class proxy-class) &rest initargs)
     (case (getf initargs :allocation)
       ((nil :alien) (find-class 'direct-alien-slot-definition))
-;      (:instance (error "Allocation :instance not allowed in class ~A" class))
       (t (call-next-method))))
-
-  (defmethod effective-slot-definition-class ((class proxy-class) initargs)
+  
+  (defmethod effective-slot-definition-class ((class proxy-class) &rest initargs)
     (case (getf initargs :allocation)
       (:alien (find-class 'effective-alien-slot-definition))
       (:virtual (find-class 'effective-virtual-alien-slot-definition))
       (t (call-next-method))))
   
-  (defmethod compute-virtual-slot-accessors
-      ((class proxy-class) (slotd effective-alien-slot-definition)
-       direct-slotds)
-    (with-slots (offset type) slotd
-      (let ((reader (intern-reader-function type))
-	    (writer (intern-writer-function type))
-	    (destroy (intern-destroy-function type)))
-	(setf offset (slot-definition-offset (first direct-slotds)))
-	(list
-	 #'(lambda (object)
-	     (funcall reader (proxy-location object) offset))
-	 #'(lambda (value object)
-	     (let ((location (proxy-location object)))
-	       (funcall destroy location offset)
-	       (funcall writer value location offset)))))))
- 
-  (defmethod compute-virtual-slot-accessors
-      ((class proxy-class)
-       (slotd effective-virtual-alien-slot-definition)
-       direct-slotds)
-    (destructuring-bind (getter setter) (call-next-method)
-      (with-slots (type) slotd
-	(list
-	 (if (stringp getter)
-	     (let ((getter (mkbinding-late getter type 'pointer)))
-	       #'(lambda (object)
-		   (funcall getter (proxy-location object))))
-	   getter)
-	 (if (stringp setter)
-	     (let ((setter (mkbinding-late setter 'nil 'pointer type)))
-	       #'(lambda (value object)
-		   (funcall setter (proxy-location object) value)))
-	   setter)))))
+  
+  (defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds)
+    (if (eq (most-specific-slot-value direct-slotds 'allocation) :alien)
+	(nconc 
+	 (list :offset (most-specific-slot-value direct-slotds 'offset))
+	 (call-next-method))
+      (call-next-method)))
+  
+
+  (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-definition))
+    (with-slots (offset) slotd
+      (let* ((type (slot-definition-type slotd))
+	     (reader (intern-reader-function type))
+	     (writer (intern-writer-function type))
+	     (destroy (intern-destroy-function type)))
+	(unless (slot-boundp slotd 'reader-function)
+	  (setf 
+	   (slot-value slotd 'reader-function)
+	   #'(lambda (object)
+	       (funcall reader (proxy-location object) offset))))
+
+	(unless (slot-boundp slotd 'writer-function)
+	  (setf 
+	   (slot-value slotd 'writer-function)
+	   #'(lambda (value object)
+	       (let ((location (proxy-location object)))
+		 (funcall destroy location offset)
+		 (funcall writer value location offset)))))
+
+	(unless (slot-boundp slotd 'boundp-function)
+	  (setf 
+	   (slot-value slotd 'boundp-function)
+	   #'(lambda (object)
+	       (declare (ignore object))
+	       t)))))
+    (call-next-method))
+  
+
+  (defmethod initialize-internal-slot-functions ((slotd effective-virtual-alien-slot-definition))
+    (with-slots (getter setter type) slotd
+      (when (and (not (slot-boundp slotd 'reader-function)) (stringp getter))
+	(let ((reader (mkbinding-late getter type 'pointer)))
+	  (setf (slot-value slotd 'reader-function)
+		#'(lambda (object)
+		    (funcall reader (proxy-location object))))))
+      
+      (when (and (not (slot-boundp slotd 'writer-function)) (stringp setter))
+	(let ((writer (mkbinding-late setter 'nil 'pointer type)))
+	  (setf (slot-value slotd 'writer-function)
+		#'(lambda (value object)
+		    (funcall writer (proxy-location object) value))))))
+    (call-next-method))
+
+  ;; TODO: call some C code to detect this a compile time
+  (defconstant +struct-alignmen+ 4)
 
   (defmethod compute-slots ((class proxy-class))
-    (with-slots (direct-slots size) class
-      (let ((current-offset
-	     (proxy-class-size (most-specific-proxy-superclass class)))
-	    (max-size 0))
-	(dolist (slotd direct-slots)
-	  (when (eq (slot-definition-allocation slotd) :alien)
-	    (with-slots (offset type) slotd
-	      (unless (slot-boundp slotd 'offset)
-		(setf offset current-offset))
-	      (setq current-offset (+ offset (size-of type)))
-	      (setq max-size (max max-size current-offset)))))
-	(unless (slot-boundp class 'size)
-	  (setf size max-size))))
+    ;; This stuff should really go somewhere else
+    (loop 
+     with offset = (proxy-class-size (most-specific-proxy-superclass class))
+     with size = offset
+     for slotd in (class-direct-slots class)
+     when (eq (slot-definition-allocation slotd) :alien)
+     do (if (not (slot-boundp slotd 'offset))
+	    (setf (slot-value slotd 'offset) offset)
+	  (setq offset (slot-value slotd 'offset)))
+
+        (incf offset (size-of (slot-definition-type slotd)))
+	(incf offset (mod offset +struct-alignmen+))
+	(setq size (max size offset))
+
+     finally (unless (slot-boundp class 'size)
+	       (setf (slot-value class 'size) size)))
     (call-next-method))
-   
-  (defmethod validate-superclass ((class proxy-class)
-				  (super pcl::standard-class))
-    (subtypep (class-name super) 'proxy))
 
+  
+  (defmethod validate-superclass ((class proxy-class) (super standard-class))
+    (subtypep (class-name super) 'proxy))
+  
   (defmethod proxy-class-size (class)
     (declare (ignore class))
     0)
-
-  (defgeneric make-proxy-instance (class location weak-ref
-				   &rest initargs &key)))
+)
+  
+(defgeneric make-proxy-instance (class location weak-ref
+				       &rest initargs &key));)
 
 (defmethod make-proxy-instance ((class symbol) location weak-ref
 				&rest initargs &key)
@@ -353,8 +412,7 @@   (defclass struct (proxy)
     (:copy %copy-struct)
     (:free %free-struct)))
 
-(defmethod initialize-instance ((structure struct)
-				&rest initargs)
+(defmethod initialize-instance ((structure struct) &rest initargs)
   (declare (ignore initargs))
   (setf 
    (slot-value structure 'location)