* struct.c, struct.h:

(scm_struct_i_free): New hidden struct slot.  Holds destructor for
instances to this vtable.
(scm_struct_free_0): New destructor: Doesn't deallocate data.
(scm_struct_free_light): New destructor: Deallocates a light
struct (i.e. a struct without hidden slots).
(scm_struct_free_standard): New destructor: Deallocates standard
structs.
(scm_struct_free_entity): New destructor: Deallocates entity
structs.
(SCM_SET_VTABLE_DESTRUCTOR): New macro.
Changes to hidden slots:
(scm_struct_i_size): scm_struct_i_flags now shares space with
scm_struct_i_size which holds the size of light structs.
(scm_struct_i_n_words): This slot has changed meaning.  Previously
it included hidden slots.  Now it indicates visible slots.
(scm_alloc_struct): Clear flags.
(SCM_STRUCTF_MASK): 4 new flag positions added => 12 bits.
(struct_num, scm_struct_i_tag): Removed.
(scm_struct_vtable_tag): Base tag on the pointer to mallocated
memory.
(scm_struct_ihashq): Base hash value on pointer to struct handle.

libguile/struct.c

@@ -58,7 +58,6 @@
 
 
 static SCM required_vtable_fields = SCM_BOOL_F;
-static int struct_num = 0;
 SCM scm_struct_table;
 
 
@@ -299,7 +298,7 @@ scm_struct_vtable_p (x)
 
    This function initializes the following fields of the struct:
 
-     scm_struct_i_ptr --- the actual stort of the block of memory; the
+     scm_struct_i_ptr --- the actual start of the block of memory; the
 	 address you should pass to 'free' to dispose of the block.
 	 This field allows us to both guarantee that the returned
 	 address is divisible by eight, and allow the GC to free the
@@ -308,9 +307,6 @@ scm_struct_vtable_p (x)
      scm_struct_i_n_words --- the number of words allocated to the
          block, including the extra fields.  This is used by the GC.
 
-     scm_struct_i_tag --- a unique tag assigned to this struct,
-         allocated according to struct_num.
-
      Ugh.  */
 
 
@@ -326,13 +322,45 @@ scm_alloc_struct (int n_words, int n_extra, char *who)
   /* Adjust it even further so it's aligned on an eight-byte boundary.  */
   p = (SCM *) (((SCM) p + 7) & ~7);
 
-  /* Initialize a few fields as described above, except for the tag.  */
+  /* Initialize a few fields as described above.  */
+  p[scm_struct_i_free] = (SCM) scm_struct_free_standard;
   p[scm_struct_i_ptr] = (SCM) block;
-  p[scm_struct_i_n_words] = (SCM) (n_words + n_extra);
+  p[scm_struct_i_n_words] = (SCM) n_words;
+  p[scm_struct_i_flags] = 0;
 
   return p;
 }
 
+size_t
+scm_struct_free_0 (SCM *vtable, SCM *data)
+{
+  return 0;
+}
+
+size_t
+scm_struct_free_light (SCM *vtable, SCM *data)
+{
+  free (data);
+  return vtable[scm_struct_i_size] & ~SCM_STRUCTF_MASK;
+}
+
+size_t
+scm_struct_free_standard (SCM *vtable, SCM *data)
+{
+  size_t n = ((data[scm_struct_i_n_words] + scm_struct_n_extra_words)
+	      * sizeof (SCM) + 7);
+  free ((void *) data[scm_struct_i_ptr]);
+  return n;
+}
+
+size_t
+scm_struct_free_entity (SCM *vtable, SCM *data)
+{
+  size_t n = ((data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words)
+	      * sizeof (SCM) + 7);
+  free ((void *) data[scm_struct_i_ptr]);
+  return n;
+}
 
 SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct);
 
@@ -373,7 +401,6 @@ scm_make_struct (vtable, tail_array_size, init)
     data = scm_alloc_struct (basic_size + tail_elts,
 			     scm_struct_n_extra_words,
 			     "make-struct");
-  data[scm_struct_i_tag] = struct_num++;
   SCM_SETCDR (handle, data);
   SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + scm_tc3_cons_gloc);
   scm_struct_init (handle, tail_elts, init);
@@ -414,7 +441,6 @@ scm_make_vtable_vtable (extra_fields, tail_array_size, init)
   data = scm_alloc_struct (basic_size + tail_elts,
 			   scm_struct_n_extra_words,
 			   "make-vtable-vtable");
-  data[scm_struct_i_tag] = struct_num++;
   SCM_SETCDR (handle, data);
   SCM_SETCAR (handle, ((SCM)data) + scm_tc3_cons_gloc);
   SCM_STRUCT_LAYOUT (handle) = layout;
@@ -450,8 +476,8 @@ scm_struct_ref (handle, pos)
   data = SCM_STRUCT_DATA (handle);
   p = SCM_INUM (pos);
 
-  fields_desc = (unsigned char *)SCM_CHARS (layout);
+  fields_desc = (unsigned char *) SCM_CHARS (layout);
-  n_fields = data[scm_struct_i_n_words] - scm_struct_n_extra_words;
+  n_fields = data[scm_struct_i_n_words];
   
   SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);
 
@@ -533,7 +559,7 @@ scm_struct_set_x (handle, pos, val)
   p = SCM_INUM (pos);
 
   fields_desc = (unsigned char *)SCM_CHARS (layout);
-  n_fields = data[scm_struct_i_n_words] - scm_struct_n_extra_words;
+  n_fields = data[scm_struct_i_n_words];
 
   SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x);
 
@@ -606,7 +632,7 @@ scm_struct_vtable_tag (handle)
 {
   SCM_ASSERT (SCM_NFALSEP (scm_struct_vtable_p (handle)),
 	      handle, SCM_ARG1, s_struct_vtable_tag);
-  return scm_long2num (SCM_STRUCT_DATA (handle)[scm_struct_i_tag]);
+  return scm_long2num ((long) SCM_STRUCT_DATA (handle) >> 3);
 }
 
 /* {Associating names and classes with vtables}
@@ -619,7 +645,9 @@ scm_struct_vtable_tag (handle)
 unsigned int
 scm_struct_ihashq (SCM obj, unsigned int n)
 {
-  return (SCM_STRUCT_DATA (obj)[scm_struct_i_tag] & ~SCM_STRUCTF_MASK) % n;
+  /* The length of the hash table should be a relative prime it's not
+     necessary to shift down the address.  */
+  return obj % n;
 }
 
 SCM

libguile/struct.h

@@ -50,23 +50,26 @@
 
 
 /* Number of words with negative index */
-#define scm_struct_n_extra_words 3
+#define scm_struct_n_extra_words 4
-#define scm_struct_entity_n_extra_words 8
+#define scm_struct_entity_n_extra_words 9
 
 /* These are how the initial words of a vtable are allocated. */
-#define scm_struct_i_setter	-8 /* Setter */
+#define scm_struct_i_setter	-9 /* Setter */
-#define scm_struct_i_proc	-7 /* Optional procedure slots */
+#define scm_struct_i_proc	-8 /* Optional procedure slots */
-#define scm_struct_i_ptr	-3 /* start of block (see alloc_struct) */
+#define scm_struct_i_free	-4 /* Destructor */
+#define scm_struct_i_ptr	-3 /* Start of block (see alloc_struct) */
 #define scm_struct_i_n_words	-2 /* How many words allocated to this struct? */
-#define scm_struct_i_tag	-1 /* A unique tag for this type.. */
+#define scm_struct_i_size	-1 /* Instance size */
-#define scm_struct_i_flags	-1 /* Upper 8 bits used as flags */
+#define scm_struct_i_flags	-1 /* Upper 12 bits used as flags */
 #define scm_vtable_index_layout  0 /* A symbol describing the physical arrangement of this type. */
 #define scm_vtable_index_vcell   1 /* An opaque word, managed by the garbage collector.  */
 #define scm_vtable_index_vtable  2 /* A pointer to the handle for this vtable. */
 #define scm_vtable_index_printer 3 /* A printer for this struct type. */
 #define scm_vtable_offset_user   4 /* Where do user fields start? */
 
-#define SCM_STRUCTF_MASK   (0xFF << 24)
+typedef size_t (*scm_struct_free_t) (SCM *vtable, SCM *data);
+
+#define SCM_STRUCTF_MASK   (0xFFF << 20)
 #define SCM_STRUCTF_ENTITY (1L << 30) /* Indicates presence of proc slots */
 #define SCM_STRUCTF_LIGHT  (1L << 31) /* Light representation
 					 (no hidden words) */
@@ -77,6 +80,7 @@
 #define SCM_STRUCT_LAYOUT(X) 		(SCM_STRUCT_VTABLE_DATA(X)[scm_vtable_index_layout])
 #define SCM_STRUCT_VTABLE(X) 		(SCM_STRUCT_VTABLE_DATA(X)[scm_vtable_index_vtable])
 #define SCM_STRUCT_PRINTER(X) 		(SCM_STRUCT_VTABLE_DATA(X)[scm_vtable_index_printer])
+#define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA(X)[scm_struct_i_free] = (SCM) D)
 /* Efficiency is important in the following macro, since it's used in GC */
 #define SCM_LAYOUT_TAILP(X)		(((X) & 32) == 0) /* R, W or O */
 
@@ -88,7 +92,13 @@ extern SCM scm_struct_table;
 
 
 
-extern SCM *scm_alloc_struct SCM_P ((int n_words, int n_extra, char *who));
+extern SCM *scm_alloc_struct (int n_words,
+			      int n_extra,
+			      char *who);
+extern size_t scm_struct_free_0 (SCM *vtable, SCM *data);
+extern size_t scm_struct_free_light (SCM *vtable, SCM *data);
+extern size_t scm_struct_free_standard (SCM *vtable, SCM *data);
+extern size_t scm_struct_free_entity (SCM *vtable, SCM *data);
 extern void scm_struct_init SCM_P ((SCM handle, int tail_elts, SCM inits));
 extern SCM scm_make_struct_layout SCM_P ((SCM fields));
 extern SCM scm_struct_p SCM_P ((SCM x));