* Fixed some signedness issues.

* Added conservative marking for the contents of free or allocated cells.
* Changed the representation of weak vectors to use double cells.
* Minor stuff.

libguile/ChangeLog

@@ -1,3 +1,66 @@
+2001-06-30  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+
+	* list.c (SCM_I_CONS):  Make sure the cell type is initialized
+	last.
+
+	* gc.c (s_scm_map_free_list, scm_igc, scm_gc_sweep,
+	init_heap_seg):  Fixed signedness.
+
+	(init_heap_seg):  Replaced strange for-loop with a while loop.
+
+	* weaks.h (WEAKSH, SCM_WEAKS_H):  Rename <foo>H to SCM_<foo>_H.
+
+	(SCM_WVECTP):  Prefer !SCM_<pred> over SCM_N<pred>.
+
+	The following patch adds conservative marking for the elements of
+	free or allocated cells.
+
+	* gc.c (allocated_mark, heap_segment):  New static functions.
+
+	(which_seg):  Deleted, since the functionality is now provided by
+	function heap_segment.
+
+	(map_free_list):  Use heap_segment instead of which_seg.
+
+	(MARK):  If cell debugging is disabled, mark free cells
+	conservatively.
+
+	(scm_mark_locations, scm_cellp):  Extracted the search for the
+	heap segment of a SCM value into function heap_segment.
+
+	(scm_init_storage):  Allocated cells must be marked
+	conservatively.
+
+	* gc.[ch] (scm_gc_mark_cell_conservatively):  New function.
+
+	The following patch changes the representation of weak vectors to
+	double cells instead of using an extension of the vector's
+	allocated memory.
+
+	* gc.c (MARK):  Use SCM_SET_WVECT_GC_CHAIN instead of assigning to
+	the result of SCM_WVECT_GC_CHAIN.
+
+	(scm_gc_sweep):  Weak vectors don't have extra fields any more.
+
+	* weaks.c (allocate_weak_vector):  New static function.  It does
+	not patch any previously created vector object during the
+	construction of a weak vector, and thus doesn't need to switch
+	off interrupts during vector creation.
+
+	(scm_make_weak_vector, scm_make_weak_key_hash_table,
+	scm_make_weak_value_hash_table, scm_make_doubly_weak_hash_table):
+	Use allocate_weak_vector to provide the new weak vector object.
+
+	* weaks.h (SCM_WVECT_TYPE, SCM_SET_WVECT_TYPE,
+	SCM_SET_WVECT_GC_CHAIN):  New macros.  The weak vector subtype is
+	now stored in the double cell.
+
+	(SCM_IS_WHVEC, SCM_IS_WHVEC_V, SCM_IS_WHVEC_B, SCM_IS_WHVEC_ANY):
+	Use SCM_WVECT_TYPE.
+
+	(SCM_WVECT_GC_CHAIN):  The weak objects are now chained together
+	using an entry of the double cell.
+
 2001-06-30  Thien-Thi Nguyen  <ttn@revel.glug.org>
 
 	* stamp-h.in: bye bye

libguile/gc.c

@@ -114,6 +114,19 @@ unsigned int scm_debug_cell_accesses_p = 1;
 static unsigned int debug_cells_gc_interval = 0;
 
 
+/* If an allocated cell is detected during garbage collection, this means that
+ * some code has just obtained the object but was preempted before the
+ * initialization of the object was completed.  This meanst that some entries
+ * of the allocated cell may already contain SCM objects.  Therefore,
+ * allocated cells are scanned conservatively.  */
+static SCM
+allocated_mark (SCM allocated)
+{
+  scm_gc_mark_cell_conservatively (allocated);
+  return SCM_BOOL_F;
+}
+
+
 /* Assert that the given object is a valid reference to a valid cell.  This
  * test involves to determine whether the object is a cell pointer, whether
  * this pointer actually points into a heap segment and whether the cell
@@ -517,22 +530,6 @@ clear_mark_space ()
 
 #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
 
-/* Return the number of the heap segment containing CELL.  */
-static long
-which_seg (SCM cell)
-{
-  long i;
-
-  for (i = 0; i < scm_n_heap_segs; i++)
-    if (SCM_PTR_LE (scm_heap_table[i].bounds[0], SCM2PTR (cell))
-	&& SCM_PTR_GT (scm_heap_table[i].bounds[1], SCM2PTR (cell)))
-      return i;
-  fprintf (stderr, "which_seg: can't find segment containing cell %lux\n",
-	   (unsigned long) SCM_UNPACK (cell));
-  abort ();
-}
-
-
 static void
 map_free_list (scm_t_freelist *master, SCM freelist)
 {
@@ -541,9 +538,16 @@ map_free_list (scm_t_freelist *master, SCM freelist)
 
   for (f = freelist; !SCM_NULLP (f); f = SCM_FREE_CELL_CDR (f))
     {
-      long this_seg = which_seg (f);
+      long int this_seg = heap_segment (f);
 
-      if (this_seg != last_seg)
+      if (this_seg == -1)
+	{
+	  fprintf (stderr, 
+		   "map_free_list: can't find segment containing cell %lux\n",
+		   (unsigned long int) SCM_UNPACK (cell));
+	  abort ();
+	}
+      else if (this_seg != last_seg)
 	{
 	  if (last_seg != -1)
 	    fprintf (stderr, "  %5ld %d-cells in segment %ld\n",
@@ -565,12 +569,14 @@ SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0,
 	    "@code{--enable-guile-debug} builds of Guile.")
 #define FUNC_NAME s_scm_map_free_list
 {
-  long i;
+  size_t i;
+
   fprintf (stderr, "%ld segments total (%d:%ld",
 	   (long) scm_n_heap_segs,
 	   scm_heap_table[0].span,
 	   (long) (scm_heap_table[0].bounds[1] - scm_heap_table[0].bounds[0]));
-  for (i = 1; i < scm_n_heap_segs; i++)
+
+  for (i = 1; i != scm_n_heap_segs; i++)
     fprintf (stderr, ", %d:%ld",
 	     scm_heap_table[i].span,
 	     (long) (scm_heap_table[i].bounds[1] - scm_heap_table[i].bounds[0]));
@@ -1120,10 +1126,10 @@ scm_igc (const char *what)
 
   /* mark the registered roots */
   {
-    long i;
+    size_t i;
     for (i = 0; i < SCM_VECTOR_LENGTH (scm_gc_registered_roots); ++i) {
       SCM l = SCM_VELTS (scm_gc_registered_roots)[i];
-      for (; ! SCM_NULLP (l); l = SCM_CDR (l)) {
+      for (; !SCM_NULLP (l); l = SCM_CDR (l)) {
         SCM *p = (SCM *) (scm_num2long (SCM_CAAR (l), 0, NULL));
         scm_gc_mark (*p);
       }
@@ -1366,7 +1372,7 @@ gc_mark_loop_first_time:
       goto_gc_mark_loop;
 
     case scm_tc7_wvect:
-      SCM_WVECT_GC_CHAIN (ptr) = scm_weak_vectors;
+      SCM_SET_WVECT_GC_CHAIN (ptr, scm_weak_vectors);
       scm_weak_vectors = ptr;
       if (SCM_IS_WHVEC_ANY (ptr))
 	{
@@ -1449,7 +1455,27 @@ gc_mark_loop_first_time:
       switch (SCM_TYP16 (ptr))
 	{ /* should be faster than going through scm_smobs */
 	case scm_tc_free_cell:
-	  /* printf("found free_cell %X ", ptr); fflush(stdout); */
+	  /* We have detected a free cell.  This can happen if non-object data
+	   * on the C stack points into guile's heap and is scanned during
+	   * conservative marking.  */
+#if (SCM_DEBUG_CELL_ACCESSES == 0)
+	  /* If cell debugging is disabled, there is a second situation in
+	   * which a free cell can be encountered, namely if with preemptive
+	   * threading one thread has just obtained a fresh cell and was
+	   * preempted before the cell initialization was completed.  In this
+	   * case, some entries of the cell may already contain objects.
+	   * Thus, if cell debugging is disabled, free cells are scanned
+	   * conservatively.  */
+	  scm_gc_mark_cell_conservatively (ptr);
+#else /* SCM_DEBUG_CELL_ACCESSES == 1 */
+	  /* With cell debugging enabled, a freshly obtained but not fully
+	   * initialized cell is guaranteed to be of type scm_tc16_allocated.
+	   * Thus, no conservative scanning for free cells is necessary, but
+	   * instead cells of type scm_tc16_allocated have to be scanned
+	   * conservatively.  This is done in the mark function of the
+	   * scm_tc16_allocated smob type.  */ 
+#endif
+	  break;
 	case scm_tc16_big:
 	case scm_tc16_real:
 	case scm_tc16_complex:
@@ -1493,9 +1519,97 @@ gc_mark_loop_first_time:
 #undef FNAME
 
 
-/* Mark a Region Conservatively
+/* Determine whether the given value does actually represent a cell in some
- */
+ * heap segment.  If this is the case, the number of the heap segment is
+ * returned.  Otherwise, -1 is returned.  Binary search is used in order to
+ * determine the heap segment that contains the cell.*/
+/* FIXME:  To be used within scm_gc_mark_cell_conservatively,
+ * scm_mark_locations and scm_cellp this function should be an inline
+ * function.  */
+static long int
+heap_segment (SCM obj)
+{
+  if (!SCM_CELLP (obj))
+    return -1;
+  else
+    {
+      SCM_CELLPTR ptr = SCM2PTR (obj);
+      unsigned long int i = 0;
+      unsigned long int j = scm_n_heap_segs - 1;
 
+      if (SCM_PTR_LT (ptr, scm_heap_table[i].bounds[0]))
+	return -1;
+      else if (SCM_PTR_LE (scm_heap_table[j].bounds[1], ptr))
+	return -1;
+      else
+	{
+	  while (i < j)
+	    {
+	      if (SCM_PTR_LT (ptr, scm_heap_table[i].bounds[1]))
+		{
+		  break;
+		}
+	      else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr))
+		{
+		  i = j;
+		  break;
+		}
+	      else
+		{
+		  unsigned long int k = (i + j) / 2;
+
+		  if (k == i)
+		    return -1;
+		  else if (SCM_PTR_LT (ptr, scm_heap_table[k].bounds[1]))
+		    {
+		      j = k;
+		      ++i;
+		      if (SCM_PTR_LT (ptr, scm_heap_table[i].bounds[0]))
+			return -1;
+		    }
+		  else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr))
+		    {
+		      i = k;
+		      --j;
+		      if (SCM_PTR_LE (scm_heap_table[j].bounds[1], ptr))
+			return -1;
+		    }
+		}
+	    }
+
+	  if (!DOUBLECELL_ALIGNED_P (obj) && scm_heap_table[i].span == 2)
+	    return -1;
+	  else if (SCM_GC_IN_CARD_HEADERP (ptr))
+	    return -1;
+	  else
+	    return i;
+	}
+    }
+}
+
+
+/* Mark the entries of a cell conservatively.  The given cell is known to be
+ * on the heap.  Still we have to determine its heap segment in order to
+ * figure out whether it is a single or a double cell.  Then, each of the cell
+ * elements itself is checked and potentially marked. */
+void
+scm_gc_mark_cell_conservatively (SCM cell)
+{
+  unsigned long int cell_segment = heap_segment (cell);
+  unsigned int span = scm_heap_table[cell_segment].span;
+  unsigned int i;
+
+  for (i = 1; i != span * 2; ++i)
+    {
+      SCM obj = SCM_CELL_OBJECT (cell, i);
+      long int obj_segment = heap_segment (obj);
+      if (obj_segment >= 0)
+	scm_gc_mark (obj);
+    }
+}
+
+
+/* Mark a region conservatively */
 void
 scm_mark_locations (SCM_STACKITEM x[], unsigned long n)
 {
@@ -1504,98 +1618,21 @@ scm_mark_locations (SCM_STACKITEM x[], unsigned long n)
   for (m = 0; m < n; ++m)
     {
       SCM obj = * (SCM *) &x[m];
-      if (SCM_CELLP (obj))
+      long int segment = heap_segment (obj);
-	{
+      if (segment >= 0)
-	  SCM_CELLPTR ptr = SCM2PTR (obj);
+	scm_gc_mark (obj);
-	  long i = 0;
-	  long j = scm_n_heap_segs - 1;
-	  if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)
-	      && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
-	    {
-	      while (i <= j)
-		{
-		  long seg_id;
-		  seg_id = -1;
-		  if ((i == j)
-		      || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr))
-		    seg_id = i;
-		  else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr))
-		    seg_id = j;
-		  else
-		    {
-		      long k;
-		      k = (i + j) / 2;
-		      if (k == i)
-			break;
-		      if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr))
-			{
-			  j = k;
-			  ++i;
-			  if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr))
-			    continue;
-			  else
-			    break;
-			}
-		      else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr))
-			{
-			  i = k;
-			  --j;
-			  if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
-			    continue;
-			  else
-			    break;
-			}
-		    }
-
-                  if (SCM_GC_IN_CARD_HEADERP (ptr))
-                    break;
-
-		  if (scm_heap_table[seg_id].span == 1
-		      || DOUBLECELL_ALIGNED_P (obj))
-                    scm_gc_mark (obj);
-                  
-		  break;
-		}
-	    }
-	}
     }
 }
 
 
 /* The function scm_cellp determines whether an SCM value can be regarded as a
- * pointer to a cell on the heap.  Binary search is used in order to determine
+ * pointer to a cell on the heap.
- * the heap segment that contains the cell.
  */
 int
 scm_cellp (SCM value)
 {
-  if (SCM_CELLP (value)) {
+  long int segment = heap_segment (value);
-    scm_cell * ptr = SCM2PTR (value);
+  return (segment >= 0);
-    unsigned long i = 0;
-    unsigned long j = scm_n_heap_segs - 1;
-
-    if (SCM_GC_IN_CARD_HEADERP (ptr))
-      return 0;
-
-    while (i < j) {
-      long k = (i + j) / 2;
-      if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr)) {
-	j = k;
-      } else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr)) {
-	i = k + 1;
-      }
-    }
-
-    if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)
-	&& SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr)
-	&& (scm_heap_table[i].span == 1 || DOUBLECELL_ALIGNED_P (value))
-        && !SCM_GC_IN_CARD_HEADERP (ptr)
-        )
-      return 1;
-    else
-      return 0;
-  } else
-    return 0;
 }
 
 
@@ -1654,7 +1691,7 @@ scm_gc_sweep ()
   register scm_t_freelist *freelist;
   register unsigned long m;
   register int span;
-  long i;
+  size_t i;
   size_t seg_size;
 
   m = 0;
@@ -1738,9 +1775,6 @@ scm_gc_sweep ()
 	    case scm_tc7_pws:
 	      break;
 	    case scm_tc7_wvect:
-              m += (2 + SCM_VECTOR_LENGTH (scmptr)) * sizeof (SCM);
-              scm_must_free (SCM_VECTOR_BASE (scmptr) - 2);
-              break;
 	    case scm_tc7_vector:
 	      {
 		unsigned long int length = SCM_VECTOR_LENGTH (scmptr);
@@ -2222,7 +2256,7 @@ init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_t_freelist *freelist)
 {
   register SCM_CELLPTR ptr;
   SCM_CELLPTR seg_end;
-  long new_seg_index;
+  size_t new_seg_index;
   ptrdiff_t n_new_cells;
   int span = freelist->span;
 
@@ -2238,13 +2272,11 @@ init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_t_freelist *freelist)
   seg_end = SCM_GC_CARD_DOWN ((char *)seg_org + size);
 
   /* Find the right place and insert the segment record.
-   *
    */
-  for (new_seg_index = 0;
+  new_seg_index = 0;
-       (   (new_seg_index < scm_n_heap_segs)
+  while (new_seg_index < scm_n_heap_segs 
-	&& SCM_PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org));
+	 && SCM_PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org))
-       new_seg_index++)
+    new_seg_index++;
-    ;
 
   {
     int i;
@@ -2468,7 +2500,7 @@ alloc_some_heap (scm_t_freelist *freelist, policy_on_error error_policy)
  * parameters.  Therefore, you can be sure that the compiler will keep those
  * scheme values alive (on the stack or in a register) up to the point where
  * scm_remember_upto_here* is called.  In other words, place the call to
- * scm_remember_upt_here* _behind_ the last code in your function, that
+ * scm_remember_upto_here* _behind_ the last code in your function, that
  * depends on the scheme object to exist.
  *
  * Example: We want to make sure, that the string object str does not get
@@ -2778,6 +2810,7 @@ scm_init_storage ()
 
 #if (SCM_DEBUG_CELL_ACCESSES == 1)
   scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0);
+  scm_set_smob_mark (scm_tc16_allocated, allocated_mark);
 #endif  /* SCM_DEBUG_CELL_ACCESSES == 1 */
 
   j = SCM_NUM_PROTECTS;

libguile/gc.h

@@ -363,6 +363,7 @@ extern void scm_alloc_cluster (struct scm_t_freelist *master);
 extern void scm_igc (const char *what);
 extern void scm_gc_mark (SCM p);
 extern void scm_gc_mark_dependencies (SCM p);
+extern void scm_gc_mark_cell_conservatively (SCM cell);
 extern void scm_mark_locations (SCM_STACKITEM x[], unsigned long n);
 extern int scm_cellp (SCM value);
 extern void scm_gc_sweep (void);

libguile/list.c

@@ -1,4 +1,4 @@
-/*	Copyright (C) 1995,1996,1997, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,2000,2001 Free Software Foundation, Inc.
  * 
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -63,8 +63,8 @@
 #define SCM_I_CONS(cell,x,y)			\
 do {						\
   SCM_NEWCELL (cell);				\
-  SCM_SET_CELL_OBJECT_0 (cell, x);		\
   SCM_SET_CELL_OBJECT_1 (cell, y);		\
+  SCM_SET_CELL_OBJECT_0 (cell, x);		\
 } while (0)
 
 SCM

libguile/weaks.c

@@ -43,18 +43,72 @@
    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
 
 
+
 #include "libguile/_scm.h"
 #include "libguile/vectors.h"
 
 #include "libguile/validate.h"
 #include "libguile/weaks.h"
-
 
+
 
 /* {Weak Vectors}
  */
 
 
+/* Allocate memory for a weak vector on behalf of the caller.  The allocated
+ * vector will be of the given weak vector subtype.  It will contain size
+ * elements which are initialized with the 'fill' object, or, if 'fill' is
+ * undefined, with an unspecified object.
+ */
+static SCM
+allocate_weak_vector (scm_t_bits type, SCM size, SCM fill, const char* caller)
+#define FUNC_NAME caller
+{
+  if (SCM_INUMP (size))
+    {
+      size_t c_size;
+      SCM v;
+
+      SCM_ASSERT_RANGE (1, size, SCM_INUM (size) >= 0);
+      c_size = SCM_INUM (size);
+
+      SCM_NEWCELL2 (v);
+      SCM_SET_WVECT_GC_CHAIN (v, SCM_EOL);
+      SCM_SET_WVECT_TYPE (v, type);
+
+      if (c_size > 0)
+	{
+	  scm_t_bits *base;
+	  size_t j;
+
+	  if (SCM_UNBNDP (fill))
+	    fill = SCM_UNSPECIFIED;
+
+	  SCM_ASSERT_RANGE (1, size, c_size <= SCM_VECTOR_MAX_LENGTH);
+	  base = scm_must_malloc (c_size * sizeof (scm_t_bits), FUNC_NAME);
+	  for (j = 0; j != c_size; ++j)
+	    base[j] = SCM_UNPACK (fill);
+	  SCM_SET_VECTOR_BASE (v, base);
+	  SCM_SET_VECTOR_LENGTH (v, c_size, scm_tc7_wvect);
+	  scm_remember_upto_here_1 (fill);
+	}
+      else
+	{
+	  SCM_SET_VECTOR_BASE (v, NULL);
+	  SCM_SET_VECTOR_LENGTH (v, 0, scm_tc7_wvect);
+	}
+
+      return v;
+    }
+  else if (SCM_BIGP (size))
+    SCM_OUT_OF_RANGE (1, size);
+  else
+    SCM_WRONG_TYPE_ARG (1, size);
+}
+#undef FUNC_NAME
+
+
 SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
 	    (SCM size, SCM fill),
 	    "Return a weak vector with @var{size} elements. If the optional\n"
@@ -63,16 +117,7 @@ SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
 	    "empty list.")
 #define FUNC_NAME s_scm_make_weak_vector
 {
-  /* Dirk:FIXME:: We should probably rather use a double cell for weak vectors. */
+  return allocate_weak_vector (0, size, fill, FUNC_NAME);
-  SCM v;
-  v = scm_make_vector (scm_sum (size, SCM_MAKINUM (2)), fill);
-  SCM_DEFER_INTS;
-  SCM_SET_VECTOR_LENGTH (v, SCM_INUM (size), scm_tc7_wvect);
-  SCM_SETVELTS(v, SCM_VELTS(v) + 2);
-  SCM_VELTS(v)[-2] = SCM_EOL;
-  SCM_VECTOR_BASE (v) [-1] = 0;
-  SCM_ALLOW_INTS;
-  return v;
 }
 #undef FUNC_NAME
 
@@ -116,16 +161,12 @@ SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
 	    "weak hashes are also weak vectors.")
 #define FUNC_NAME s_scm_weak_vector_p
 {
-  return SCM_BOOL(SCM_WVECTP (obj) && !SCM_IS_WHVEC (obj));
+  return SCM_BOOL (SCM_WVECTP (obj) && !SCM_IS_WHVEC (obj));
 }
 #undef FUNC_NAME
 
-
-
 
 
-
-
 SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0, 
 	    (SCM size),
 	    "@deffnx primitive make-weak-value-hash-table size\n"
@@ -138,13 +179,7 @@ SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0,
 	    "would modify regular hash tables. (@pxref{Hash Tables})")
 #define FUNC_NAME s_scm_make_weak_key_hash_table
 {
-  SCM v;
+  return allocate_weak_vector (1, size, SCM_EOL, FUNC_NAME);
-  SCM_VALIDATE_INUM (1, size);
-  v = scm_make_weak_vector (size, SCM_EOL);
-  SCM_DEFER_INTS;
-  SCM_VECTOR_BASE (v) [-1] = 1;
-  SCM_ALLOW_INTS;
-  return v;
 }
 #undef FUNC_NAME
 
@@ -155,34 +190,22 @@ SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0,
 	    "(@pxref{Hash Tables})")
 #define FUNC_NAME s_scm_make_weak_value_hash_table
 {
-  SCM v;
+  return allocate_weak_vector (2, size, SCM_EOL, FUNC_NAME);
-  SCM_VALIDATE_INUM (1, size);
-  v = scm_make_weak_vector (size, SCM_EOL);
-  SCM_DEFER_INTS;
-  SCM_VECTOR_BASE (v) [-1] = 2;
-  SCM_ALLOW_INTS;
-  return v;
 }
 #undef FUNC_NAME
 
 
-
 SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0, 
             (SCM size),
 	    "Return a hash table with weak keys and values with @var{size}\n"
 	    "buckets.  (@pxref{Hash Tables})")
 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
 {
-  SCM v;
+  return allocate_weak_vector (3, size, SCM_EOL, FUNC_NAME);
-  SCM_VALIDATE_INUM (1, size);
-  v = scm_make_weak_vector (size, SCM_EOL);
-  SCM_DEFER_INTS;
-  SCM_VECTOR_BASE (v) [-1] = 3;
-  SCM_ALLOW_INTS;
-  return v;
 }
 #undef FUNC_NAME
 
+
 SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, 
            (SCM obj),
 	    "@deffnx primitive weak-value-hash-table? obj\n"
@@ -192,7 +215,7 @@ SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0,
 	    "nor a weak value hash table.")
 #define FUNC_NAME s_scm_weak_key_hash_table_p
 {
-  return SCM_BOOL(SCM_WVECTP (obj) && SCM_IS_WHVEC(obj));
+  return SCM_BOOL (SCM_WVECTP (obj) && SCM_IS_WHVEC (obj));
 }
 #undef FUNC_NAME
 
@@ -202,7 +225,7 @@ SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0,
 	    "Return @code{#t} if @var{obj} is a weak value hash table.")
 #define FUNC_NAME s_scm_weak_value_hash_table_p
 {
-  return SCM_BOOL(SCM_WVECTP (obj) && SCM_IS_WHVEC_V(obj));
+  return SCM_BOOL (SCM_WVECTP (obj) && SCM_IS_WHVEC_V (obj));
 }
 #undef FUNC_NAME
 
@@ -212,10 +235,11 @@ SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0,
 	    "Return @code{#t} if @var{obj} is a doubly weak hash table.")
 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
 {
-  return SCM_BOOL(SCM_WVECTP (obj) && SCM_IS_WHVEC_B (obj));
+  return SCM_BOOL (SCM_WVECTP (obj) && SCM_IS_WHVEC_B (obj));
 }
 #undef FUNC_NAME
 
+
 static void *
 scm_weak_vector_gc_init (void *dummy1 SCM_UNUSED,
 			 void *dummy2 SCM_UNUSED,
@@ -226,6 +250,7 @@ scm_weak_vector_gc_init (void *dummy1 SCM_UNUSED,
   return 0;
 }
 
+
 static void *
 scm_mark_weak_vector_spines (void *dummy1 SCM_UNUSED,
 			     void *dummy2 SCM_UNUSED,
@@ -265,6 +290,7 @@ scm_mark_weak_vector_spines (void *dummy1 SCM_UNUSED,
   return 0;
 }
 
+
 static void *
 scm_scan_weak_vectors (void *dummy1 SCM_UNUSED,
 		       void *dummy2 SCM_UNUSED,
@@ -325,10 +351,8 @@ scm_scan_weak_vectors (void *dummy1 SCM_UNUSED,
   return 0;
 }
 
-
 
 
-
 void
 scm_weaks_prehistory ()
 {
@@ -337,6 +361,7 @@ scm_weaks_prehistory ()
   scm_c_hook_add (&scm_after_sweep_c_hook, scm_scan_weak_vectors, 0, 0);
 }
 
+
 void
 scm_init_weaks ()
 {

libguile/weaks.h

@@ -1,8 +1,8 @@
 /* classes: h_files */
 
-#ifndef WEAKSH
+#ifndef SCM_WEAKS_H
-#define WEAKSH
+#define SCM_WEAKS_H
-/*	Copyright (C) 1995,1996, 2000 Free Software Foundation, Inc.   
+/* Copyright (C) 1995,1996,2000,2001 Free Software Foundation, Inc.   
  * 
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -51,13 +51,15 @@
 
 
 
-
+#define SCM_WVECTP(x) (!SCM_IMP (x) && SCM_TYP7 (x) == scm_tc7_wvect)
-#define SCM_WVECTP(x) (SCM_NIMP(x) && (SCM_TYP7(x)==scm_tc7_wvect))
+#define SCM_WVECT_TYPE(x) (SCM_CELL_WORD_2 (x))
-#define SCM_IS_WHVEC(X) (SCM_UNPACK (SCM_VELTS(X)[-1]) == 1)
+#define SCM_SET_WVECT_TYPE(x, t) (SCM_SET_CELL_WORD_2 ((x), (t)))
-#define SCM_IS_WHVEC_V(X) (SCM_UNPACK (SCM_VELTS(X)[-1]) == 2)
+#define SCM_IS_WHVEC(X) (SCM_WVECT_TYPE (X) == 1)
-#define SCM_IS_WHVEC_B(X) (SCM_UNPACK (SCM_VELTS(X)[-1]) == 3)
+#define SCM_IS_WHVEC_V(X) (SCM_WVECT_TYPE (X) == 2)
-#define SCM_IS_WHVEC_ANY(X) (SCM_UNPACK (SCM_VELTS(X)[-1]) != 0)
+#define SCM_IS_WHVEC_B(X) (SCM_WVECT_TYPE (X) == 3)
-#define SCM_WVECT_GC_CHAIN(X) (SCM_VELTS(X)[-2])
+#define SCM_IS_WHVEC_ANY(X) (SCM_WVECT_TYPE (X) != 0)
+#define SCM_WVECT_GC_CHAIN(X) (SCM_CELL_OBJECT_3 (X))
+#define SCM_SET_WVECT_GC_CHAIN(X, o) (SCM_SET_CELL_OBJECT_3 ((X), (o)))
 
 extern SCM scm_weak_vectors;
 
@@ -75,7 +77,7 @@ extern SCM scm_doubly_weak_hash_table_p (SCM x);
 extern void scm_weaks_prehistory (void);
 extern void scm_init_weaks (void);
 
-#endif  /* WEAKSH */
+#endif  /* SCM_WEAKS_H */
 
 /*
   Local Variables: