+#ifdef GUILE_NEW_GC_SCHEME
+static int last_cluster;
+static int last_size;
+
+static int
+free_list_length (char *title, int i, SCM freelist)
+{
+ SCM ls;
+ int n = 0;
+ for (ls = freelist; SCM_NNULLP (ls); ls = SCM_CDR (ls))
+ if (SCM_UNPACK_CAR (ls) == scm_tc_free_cell)
+ ++n;
+ else
+ {
+ fprintf (stderr, "bad cell in %s at position %d\n", title, n);
+ abort ();
+ }
+ if (n != last_size)
+ {
+ if (i > 0)
+ {
+ if (last_cluster == i - 1)
+ fprintf (stderr, "\t%d\n", last_size);
+ else
+ fprintf (stderr, "-%d\t%d\n", i - 1, last_size);
+ }
+ if (i >= 0)
+ fprintf (stderr, "%s %d", title, i);
+ else
+ fprintf (stderr, "%s\t%d\n", title, n);
+ last_cluster = i;
+ last_size = n;
+ }
+ return n;
+}
+
+static void
+free_list_lengths (char *title, scm_freelist_t *master, SCM freelist)
+{
+ SCM clusters;
+ int i = 0, len, n = 0;
+ fprintf (stderr, "%s\n\n", title);
+ n += free_list_length ("free list", -1, freelist);
+ for (clusters = master->clusters;
+ SCM_NNULLP (clusters);
+ clusters = SCM_CDR (clusters))
+ {
+ len = free_list_length ("cluster", i++, SCM_CAR (clusters));
+ n += len;
+ }
+ if (last_cluster == i - 1)
+ fprintf (stderr, "\t%d\n", last_size);
+ else
+ fprintf (stderr, "-%d\t%d\n", i - 1, last_size);
+ fprintf (stderr, "\ntotal %d objects\n\n", n);
+}
+
+SCM_DEFINE (scm_free_list_length, "free-list-length", 0, 0, 0,
+ (),
+ "Print debugging information about the free-list.\n"
+ "`free-list-length' is only included in --enable-guile-debug builds of Guile.")
+#define FUNC_NAME s_scm_free_list_length
+{
+ free_list_lengths ("1-cells", &scm_master_freelist, scm_freelist);
+ free_list_lengths ("2-cells", &scm_master_freelist2, scm_freelist2);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
+#endif
+
+#ifdef GUILE_DEBUG_FREELIST