* goops.scm (compute-getters-n-setters/verify-accessors): Better

check of format of value returned by compute-get-n-set.
(compute-getters-n-setters): Extended format of slot
getters-n-setters to indicate position and size of slot memory
allocated in instances.

* goops.c (scm_sys_prep_layout_x): Instance allocation is now
indicated through extra fields in getters-n-setters.
(scm_add_slot): Adapted to new format of getters_n_setters slot.
(Thanks to Andy Wingo.)

THANKS

@@ -80,4 +80,5 @@ For fixes or providing information which led to a fix:
      Panagiotis Vossos
 	 Thomas Wawrzinek
 	Florian Weimer
+           Andy Wingo
 	  Keith Wright

libguile/ChangeLog

@@ -1,3 +1,10 @@
+2003-04-13  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
+
+	* goops.c (scm_sys_prep_layout_x): Instance allocation is now
+	indicated through extra fields in getters-n-setters.
+	(scm_add_slot): Adapted to new format of getters_n_setters slot.
+	(Thanks to Andy Wingo.)
+
 2003-04-12  Rob Browning  <rlb@defaultvalue.org>
 
 	* backtrace.c (display_backtrace_file): correct a couple of

libguile/goops.c

@@ -471,6 +471,22 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
 }
 #undef FUNC_NAME
 
+/* NOTE: The following macros are interdependent with code
+ *       in goops.scm:compute-getters-n-setters
+ */
+#define SCM_GNS_INSTANCE_ALLOCATED_P(gns)	\
+  (SCM_INUMP (SCM_CDDR (gns))			\
+   || (SCM_CONSP (SCM_CDDR (gns))		\
+       && SCM_CONSP (SCM_CDDDR (gns))		\
+       && SCM_CONSP (SCM_CDDDDR (gns))))
+#define SCM_GNS_INDEX(gns)			\
+  (SCM_INUMP (SCM_CDDR (gns))			\
+   ? SCM_INUM (SCM_CDDR (gns))			\
+   : SCM_INUM (SCM_CAR (SCM_CDDDDR (gns))))
+#define SCM_GNS_SIZE(gns)			\
+  (SCM_INUMP (SCM_CDDR (gns))			\
+   ? 1						\
+   : SCM_INUM (SCM_CADR (SCM_CDDDDR (gns))))
 
 SCM_KEYWORD (k_class, "class");
 SCM_KEYWORD (k_allocation, "allocation");
@@ -481,12 +497,13 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
 	    "")
 #define FUNC_NAME s_scm_sys_prep_layout_x
 {
-  long i, n, len;
+  SCM slots, getters_n_setters, nfields;
-  char *s, p, a;
+  unsigned long int n, i;
-  SCM nfields, slots, type, allocation;
+  char *s;
 
   SCM_VALIDATE_INSTANCE (1, class);
   slots = SCM_SLOT (class, scm_si_slots);
+  getters_n_setters = SCM_SLOT (class, scm_si_getters_n_setters);
   nfields = SCM_SLOT (class, scm_si_nfields);
   if (!SCM_INUMP (nfields) || SCM_INUM (nfields) < 0)
     SCM_MISC_ERROR ("bad value in nfields slot: ~S",
@@ -498,46 +515,79 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
 		    scm_list_1 (nfields));
 
   s  = n > 0 ? scm_must_malloc (n, FUNC_NAME) : 0;
-  for (i = 0; i < n; i += 2)
+  i = 0;
+  while (SCM_CONSP (getters_n_setters))
     {
-      if (!SCM_CONSP (slots))
+      if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters)))
-	SCM_MISC_ERROR ("to few slot definitions", SCM_EOL);
-      len = scm_ilength (SCM_CDAR (slots));
-      allocation = scm_i_get_keyword (k_allocation, SCM_CDAR (slots),
-				      len, k_instance, FUNC_NAME);
-      while (!SCM_EQ_P (allocation, k_instance))
 	{
-	  slots = SCM_CDR (slots);
+	  SCM type;
-	  len = scm_ilength (SCM_CDAR (slots));
+	  int len, index, size;
-	  allocation = scm_i_get_keyword (k_allocation, SCM_CDAR (slots),
+	  char p, a;
-					  len, k_instance, FUNC_NAME);
-	}
-      type = scm_i_get_keyword (k_class, SCM_CDAR (slots),
-				len, SCM_BOOL_F, FUNC_NAME);
-      if (SCM_NIMP (type) && SCM_SUBCLASSP (type, scm_class_foreign_slot))
-	{
-	  if (SCM_SUBCLASSP (type, scm_class_self))
-	    p = 's';
-	  else if (SCM_SUBCLASSP (type, scm_class_protected))
-	    p = 'p';
-	  else
-	    p = 'u';
 
-	  if (SCM_SUBCLASSP (type, scm_class_opaque))
+	  if (i >= n || !SCM_CONSP (slots))
-	    a = 'o';
+	    goto inconsistent;
-	  else if (SCM_SUBCLASSP (type, scm_class_read_only))
+	  
-	    a = 'r';
+	  /* extract slot type */
+	  len = scm_ilength (SCM_CDAR (slots));
+	  type = scm_i_get_keyword (k_class, SCM_CDAR (slots),
+				    len, SCM_BOOL_F, FUNC_NAME);
+	  /* determine slot GC protection and access mode */
+	  if (SCM_FALSEP (type))
+	    {
+	      p = 'p';
+	      a = 'w';
+	    }
 	  else
-	    a = 'w';
+	    {
+	      if (!SCM_CLASSP (type))
+		{
+		  if (s)
+		    free (s);
+		  SCM_MISC_ERROR ("bad slot class", SCM_EOL);
+		}
+	      else if (SCM_SUBCLASSP (type, scm_class_foreign_slot))
+		{
+		  if (SCM_SUBCLASSP (type, scm_class_self))
+		    p = 's';
+		  else if (SCM_SUBCLASSP (type, scm_class_protected))
+		    p = 'p';
+		  else
+		    p = 'u';
+
+		  if (SCM_SUBCLASSP (type, scm_class_opaque))
+		    a = 'o';
+		  else if (SCM_SUBCLASSP (type, scm_class_read_only))
+		    a = 'r';
+		  else
+		    a = 'w';
+		}
+	      else
+		{
+		  p = 'p';
+		  a = 'w';
+		}
+	    }
+      
+	  index = SCM_GNS_INDEX (SCM_CAR (getters_n_setters));
+	  if (index != (i >> 1))
+	    goto inconsistent;
+	  size = SCM_GNS_SIZE (SCM_CAR (getters_n_setters));
+	  while (size)
+	    {
+	      s[i++] = p;
+	      s[i++] = a;
+	      --size;
+	    }
 	}
-      else
-	{
-	  p = 'p';
-	  a = 'w';
-	}
-      s[i] = p;
-      s[i + 1] = a;
       slots = SCM_CDR (slots);
+      getters_n_setters = SCM_CDR (getters_n_setters);
+    }
+  if (!SCM_NULLP (slots))
+    {
+    inconsistent:
+      if (s)
+	free (s);
+      SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL);
     }
   SCM_SET_SLOT (class, scm_si_layout, scm_mem2symbol (s, n));
   if (s)
@@ -2541,8 +2591,6 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class,
 			     slot_class,
 			     setter ? k_accessor : k_getter,
 			     gf);
-      SCM gns = scm_list_4 (name, SCM_BOOL_F, get, set);
-
       scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor,
 						k_specializers,
 						scm_list_1 (class),
@@ -2559,16 +2607,16 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class,
       SCM_SET_SLOT (class, scm_si_slots,
 		    scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),
 					      scm_list_1 (slot))));
-      SCM_SET_SLOT (class, scm_si_getters_n_setters,
+      {
-		    scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters),
+	SCM n = SCM_SLOT (class, scm_si_nfields);
-					      scm_list_1 (gns))));
+	SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, SCM_MAKINUM (1));
+	SCM_SET_SLOT (class, scm_si_getters_n_setters,
+		      scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters),
+						scm_list_1 (gns))));
+	SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (SCM_INUM (n) + 1));
+      }
     }
   }
-  {
-    long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields));
-
-    SCM_SET_SLOT (class, scm_si_nfields, SCM_MAKINUM (n + 1));
-  }
 }
 
 SCM

oop/ChangeLog

@@ -1,3 +1,11 @@
+2003-04-13  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
+
+	* goops.scm (compute-getters-n-setters/verify-accessors): Better
+	check of format of value returned by compute-get-n-set.
+	(compute-getters-n-setters): Extended format of slot
+	getters-n-setters to indicate position and size of slot memory
+	allocated in instances.
+
 2002-12-08  Rob Browning  <rlb@defaultvalue.org>
 
 	* Makefile.am (subpkgdatadir): VERSION -> GUILE_EFFECTIVE_VERSION.

oop/goops.scm

@@ -1043,27 +1043,45 @@
 	       (lambda () init)))))
 
   (define (verify-accessors slot l)
-    (if (pair? l)
+    (cond ((integer? l))
-	(let ((get (car l)) 
+	  ((not (and (list? l) (= (length l) 2)))
-	      (set (cadr l)))
+	   (goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
-	  (if (not (and (closure? get)
+			slot class l))
-			(= (car (procedure-property get 'arity)) 1)))
+	  (else
-	      (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
+	   (let ((get (car l)) 
-			   slot class get))
+		 (set (cadr l)))
-	  (if (not (and (closure? set)
+	     (if (not (and (closure? get)
-			(= (car (procedure-property set 'arity)) 2)))
+			   (= (car (procedure-property get 'arity)) 1)))
-	    (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
+		 (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
-			 slot class set)))))
+			      slot class get))
+	     (if (not (and (closure? set)
+			   (= (car (procedure-property set 'arity)) 2)))
+		 (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
+			      slot class set))))))
 
   (map (lambda (s)
-	 (let* ((g-n-s (compute-get-n-set class s))
+	 ;; The strange treatment of nfields is due to backward compatibility.
+	 (let* ((index (slot-ref class 'nfields))
+		(g-n-s (compute-get-n-set class s))
+		(size (- (slot-ref class 'nfields) index))
 		(name  (slot-definition-name s)))
-	   ; For each slot we have '(name init-function getter setter)
+	   ;; NOTE: The following is interdependent with C macros
-	   ; If slot, we have the simplest form '(name init-function . index)
+	   ;; defined above goops.c:scm_sys_prep_layout_x.
+	   ;;
+	   ;; For simple instance slots, we have the simplest form
+	   ;; '(name init-function . index)
+	   ;; For other slots we have
+	   ;; '(name init-function getter setter . alloc)
+	   ;; where alloc is:
+	   ;;   '(index size) for instance allocated slots
+	   ;;   '() for other slots
 	   (verify-accessors name g-n-s)
 	   (cons name
 		 (cons (compute-slot-init-function s)
-		       g-n-s))))
+		       (if (or (integer? g-n-s)
+			       (zero? size))
+			   g-n-s
+			   (append g-n-s index size))))))
        slots))
 
 ;;; compute-cpl