Merge branch 'bdw-gc-static-alloc'

Conflicts:
	acinclude.m4
	libguile/__scm.h
	libguile/bdw-gc.h
	libguile/eval.c

libguile/__scm.h

@@ -115,6 +115,16 @@
 # define SCM_DEPRECATED  SCM_API
 #endif
 
+/* The SCM_ALIGNED macro, when defined, can be used to instruct the compiler
+ * to honor the given alignment constraint.  */
+#if defined __GNUC__
+# define SCM_ALIGNED(x)  __attribute__ ((aligned (x)))
+#elif defined __INTEL_COMPILER
+# define SCM_ALIGNED(x)  __declspec (align (x))
+#else
+/* Don't know how to align things.  */
+# undef SCM_ALIGNED
+#endif
 
 
 /* {Supported Options}

libguile/_scm.h

@@ -79,6 +79,7 @@
 #include "libguile/variable.h"
 #include "libguile/modules.h"
 #include "libguile/inline.h"
+#include "libguile/strings.h"
 
 #ifndef SCM_SYSCALL
 #ifdef vms

libguile/bdw-gc.h

@@ -46,4 +46,20 @@
 typedef void *GC_PTR;
 #endif
 
+
+/* Return true if PTR points to the heap.  */
+#define SCM_I_IS_POINTER_TO_THE_HEAP(ptr)	\
+  (GC_base (ptr) != NULL)
+
+/* Register a disappearing link for the object pointed to by OBJ such that
+   the pointer pointed to be LINK is cleared when OBJ is reclaimed.  Do so
+   only if OBJ actually points to the heap.  See
+   http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2563
+   for details.  */
+#define SCM_I_REGISTER_DISAPPEARING_LINK(link, obj)		\
+  ((SCM_I_IS_POINTER_TO_THE_HEAP (obj))				\
+   ? GC_GENERAL_REGISTER_DISAPPEARING_LINK ((link), (obj))	\
+   : 0)
+
+
 #endif /* SCM_BDW_GC_H */

libguile/eval.c

@@ -923,7 +923,7 @@ m_expand_body (const SCM forms, const SCM env)
 }
 
 SCM_SYNTAX (s_and, "and", scm_i_makbimacro, scm_m_and);
-SCM_GLOBAL_SYMBOL (scm_sym_and, s_and);
+SCM_GLOBAL_SYMBOL (scm_sym_and, "and");
 
 static SCM
 scm_m_and (SCM expr, SCM env SCM_UNUSED)
@@ -953,7 +953,7 @@ unmemoize_and (const SCM expr, const SCM env)
 
 
 SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
-SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
+SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
 
 static SCM
 scm_m_begin (SCM expr, SCM env SCM_UNUSED)
@@ -976,7 +976,7 @@ unmemoize_begin (const SCM expr, const SCM env)
 
 
 SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case);
-SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);
+SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
 SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
 
 static SCM
@@ -1072,7 +1072,7 @@ unmemoize_case (const SCM expr, const SCM env)
 
 
 SCM_SYNTAX (s_cond, "cond", scm_i_makbimacro, scm_m_cond);
-SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond);
+SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
 SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
 
 static SCM
@@ -1175,7 +1175,7 @@ unmemoize_cond (const SCM expr, const SCM env)
 
 
 SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define);
-SCM_GLOBAL_SYMBOL (scm_sym_define, s_define);
+SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
 
 /* Guile provides an extension to R5RS' define syntax to represent function
  * currying in a compact way.  With this extension, it is allowed to write
@@ -1286,7 +1286,7 @@ memoize_as_thunk_prototype (const SCM expr, const SCM env SCM_UNUSED)
 
 
 SCM_SYNTAX (s_delay, "delay", scm_i_makbimacro, scm_m_delay);
-SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
+SCM_GLOBAL_SYMBOL (scm_sym_delay, "delay");
 
 /* Promises are implemented as closures with an empty parameter list.  Thus,
  * (delay <expression>) is transformed into (#@delay '() <expression>), where
@@ -1315,7 +1315,7 @@ unmemoize_delay (const SCM expr, const SCM env)
 
 
 SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do);
-SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
+SCM_GLOBAL_SYMBOL(scm_sym_do, "do");
 
 /* DO gets the most radically altered syntax.  The order of the vars is
  * reversed here.  During the evaluation this allows for simple consing of the
@@ -1431,7 +1431,7 @@ unmemoize_do (const SCM expr, const SCM env)
 
 
 SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if);
-SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
+SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
 
 static SCM
 scm_m_if (SCM expr, SCM env SCM_UNUSED)
@@ -1465,7 +1465,7 @@ unmemoize_if (const SCM expr, const SCM env)
 
 
 SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda);
-SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda);
+SCM_GLOBAL_SYMBOL (scm_sym_lambda, "lambda");
 
 /* A helper function for memoize_lambda to support checking for duplicate
  * formal arguments: Return true if OBJ is `eq?' to one of the elements of
@@ -1613,7 +1613,7 @@ transform_bindings (
 
 
 SCM_SYNTAX(s_let, "let", scm_i_makbimacro, scm_m_let);
-SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);
+SCM_GLOBAL_SYMBOL(scm_sym_let, "let");
 
 /* This function is a helper function for memoize_let.  It transforms
  * (let name ((var init) ...) body ...) into
@@ -1725,7 +1725,7 @@ unmemoize_let (const SCM expr, const SCM env)
 
 
 SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec);
-SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
+SCM_GLOBAL_SYMBOL(scm_sym_letrec, "letrec");
 
 static SCM
 scm_m_letrec (SCM expr, SCM env)
@@ -1774,7 +1774,7 @@ unmemoize_letrec (const SCM expr, const SCM env)
 
 
 SCM_SYNTAX (s_letstar, "let*", scm_i_makbimacro, scm_m_letstar);
-SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
+SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*");
 
 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
  * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body).  */
@@ -1849,7 +1849,7 @@ unmemoize_letstar (const SCM expr, const SCM env)
 
 
 SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or);
-SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
+SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
 
 static SCM
 scm_m_or (SCM expr, SCM env SCM_UNUSED)
@@ -1879,7 +1879,7 @@ unmemoize_or (const SCM expr, const SCM env)
 
 
 SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
-SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);
+SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
 SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
 
@@ -1946,7 +1946,7 @@ scm_m_quasiquote (SCM expr, SCM env)
 
 
 SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
-SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
+SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
 
 static SCM
 scm_m_quote (SCM expr, SCM env SCM_UNUSED)
@@ -1974,8 +1974,7 @@ unmemoize_quote (const SCM expr, const SCM env SCM_UNUSED)
 
 /* Will go into the RnRS module when Guile is factorized.
 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
-static const char s_set_x[] = "set!";
+SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
-SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x);
 
 static SCM
 scm_m_set_x (SCM expr, SCM env SCM_UNUSED)
@@ -2012,7 +2011,7 @@ unmemoize_set_x (const SCM expr, const SCM env)
 
 
 SCM_SYNTAX (s_at, "@", scm_makmmacro, scm_m_at);
-SCM_GLOBAL_SYMBOL (scm_sym_at, s_at);
+SCM_GLOBAL_SYMBOL (scm_sym_at, "@");
 
 static SCM
 scm_m_at (SCM expr, SCM env SCM_UNUSED)
@@ -2033,7 +2032,7 @@ scm_m_at (SCM expr, SCM env SCM_UNUSED)
 }
 
 SCM_SYNTAX (s_atat, "@@", scm_makmmacro, scm_m_atat);
-SCM_GLOBAL_SYMBOL (scm_sym_atat, s_atat);
+SCM_GLOBAL_SYMBOL (scm_sym_atat, "@@");
 
 static SCM
 scm_m_atat (SCM expr, SCM env SCM_UNUSED)
@@ -2054,8 +2053,8 @@ scm_m_atat (SCM expr, SCM env SCM_UNUSED)
 }
 
 SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply);
-SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);
+SCM_GLOBAL_SYMBOL (scm_sym_atapply, "@apply");
-SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
+SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply");
 
 static SCM
 scm_m_apply (SCM expr, SCM env SCM_UNUSED)
@@ -2131,7 +2130,7 @@ scm_m_atbind (SCM expr, SCM env)
 
 
 SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);
-SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);
+SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, "@call-with-current-continuation");
 
 static SCM
 scm_m_cont (SCM expr, SCM env SCM_UNUSED)
@@ -2152,7 +2151,7 @@ unmemoize_atcall_cc (const SCM expr, const SCM env)
 
 
 SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_at_call_with_values);
-SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);
+SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, "@call-with-values");
 
 static SCM
 scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED)
@@ -2173,7 +2172,7 @@ unmemoize_at_call_with_values (const SCM expr, const SCM env)
 }
 
 SCM_SYNTAX (s_eval_when, "eval-when", scm_makmmacro, scm_m_eval_when);
-SCM_GLOBAL_SYMBOL (scm_sym_eval_when, s_eval_when);
+SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
 SCM_SYMBOL (sym_eval, "eval");
 SCM_SYMBOL (sym_load, "load");
 

libguile/guile-snarf.in

@@ -1,7 +1,7 @@
 #!/bin/sh
 # Extract the initialization actions from source files.
 #
-#  Copyright (C) 1996, 97, 98, 99, 2000, 2001, 2002, 2004, 2006, 2008 Free Software Foundation, Inc.
+#  Copyright (C) 1996, 97, 98, 99, 2000, 2001, 2002, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
 #
 # This program is free software; you can redistribute it and/or modify
 # it under the terms of the GNU Lesser General Public License as
@@ -51,7 +51,7 @@ modern_snarf ()                         # writes stdout
     ## empty file.
     echo "/* cpp arguments: $@ */" ;
     ${cpp} -DSCM_MAGIC_SNARF_INITS -DSCM_MAGIC_SNARFER "$@" > ${temp} && cpp_ok_p=true
-    grep "^ *\^ *\^" ${temp} | sed -e "s/^ *\^ *\^//" -e "s/\^\ *:\ *\^.*/;/"
+    grep "^ *\^ *\^" ${temp} | sed -e "s/ *\^ *\^//g" -e "s/\^ *: *\^/;/g"
 }
 
 ## main

libguile/procs.h

@@ -40,6 +40,46 @@
 #define SCM_SET_SUBR_GENERIC(x, g) (*((SCM *) SCM_CELL_WORD_2 (x)) = (g))
 #define SCM_SET_SUBR_GENERIC_LOC(x, g) (SCM_SET_CELL_WORD_2 (x, (scm_t_bits) g))
 
+/* Return the most suitable subr type for a subr with REQ required arguments,
+   OPT optional arguments, and REST (0 or 1) arguments.  This has to be in
+   sync with `create_gsubr ()'.  */
+#define SCM_SUBR_ARITY_TO_TYPE(req, opt, rest)				\
+  ((rest) == 0								\
+   ? ((opt) == 0							\
+      ? ((req) == 0							\
+	 ? scm_tc7_subr_0						\
+	 : ((req) == 1							\
+	    ? scm_tc7_subr_1						\
+	    : ((req) == 2						\
+	       ? scm_tc7_subr_2						\
+	       : ((req) == 3						\
+		  ? scm_tc7_subr_3					\
+		  : scm_tc7_gsubr					\
+		    | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U)))))	\
+      : ((opt) == 1							\
+	 ? ((req) == 0							\
+	    ? scm_tc7_subr_1o						\
+	    : ((req) == 1						\
+	       ? scm_tc7_subr_2o					\
+	       : scm_tc7_gsubr |					\
+	         (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U)))		\
+	 : scm_tc7_gsubr |						\
+	   (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U)))			\
+   : ((rest) == 1							\
+      ? ((opt) == 0							\
+	 ? ((req) == 0							\
+	    ? scm_tc7_lsubr						\
+	    : ((req) == 2						\
+	       ? scm_tc7_lsubr_2					\
+	       : scm_tc7_gsubr						\
+	         | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U)))		\
+	 : scm_tc7_gsubr						\
+	   | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))		\
+      : scm_tc7_gsubr							\
+        | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U)))
+
+
+
 /* Closures
  */
 
@@ -104,6 +144,9 @@
 #define SCM_PROCEDURE(obj) SCM_CELL_OBJECT_1 (obj)
 #define SCM_SETTER(obj) SCM_CELL_OBJECT_2 (obj)
 
+
+
+
 SCM_API SCM scm_c_make_subr (const char *name, long type, SCM (*fcn)());
 SCM_API SCM scm_c_make_subr_with_generic (const char *name, long type,
 					  SCM (*fcn)(), SCM *gf);

libguile/snarf.h

@@ -3,7 +3,7 @@
 #ifndef SCM_SNARF_H
 #define SCM_SNARF_H
 
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2009 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -36,6 +36,17 @@
 #define SCM_FUNC_CAST_ARBITRARY_ARGS SCM (*)()
 #endif
 
+#if (defined SCM_ALIGNED) && (SCM_DEBUG_TYPING_STRICTNESS <= 1)
+/* We support static allocation of some `SCM' objects.  */
+# define SCM_SUPPORT_STATIC_ALLOCATION
+#endif
+
+/* C preprocessor token concatenation.  */
+#define scm_i_paste(x, y)      x ## y
+#define scm_i_paste3(a, b, c)  a ## b ## c
+
+
+
 /* Generic macros to be used in user macro definitions.
  *
  * For example, in order to define a macro which creates ints and
@@ -74,7 +85,7 @@ DOCSTRING ^^ }
 # endif
 #endif
 
-#define SCM_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
+#define SCM_DEFINE_GSUBR(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
 SCM_SNARF_HERE(\
 static const char s_ ## FNAME [] = PRIMNAME; \
 SCM FNAME ARGLIST\
@@ -85,6 +96,35 @@ scm_c_define_gsubr (s_ ## FNAME, REQ, OPT, VAR, \
 )\
 SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
 
+#ifdef SCM_SUPPORT_STATIC_ALLOCATION
+
+/* Static subr allocation.  */
+#define SCM_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING)	\
+SCM_SYMBOL (scm_i_paste (FNAME, __name), PRIMNAME);			\
+SCM_SNARF_HERE(								\
+  static const char scm_i_paste (s_, FNAME) [] = PRIMNAME;		\
+  SCM_IMMUTABLE_SUBR (scm_i_paste (FNAME, __subr),			\
+		      scm_i_paste (FNAME, __name),			\
+		      REQ, OPT, VAR, &FNAME);				\
+  SCM FNAME ARGLIST							\
+)									\
+SCM_SNARF_INIT(								\
+  /* Initialize the procedure name (an interned symbol).  */		\
+  scm_i_paste (FNAME, __subr_meta_info)[0] = scm_i_paste (FNAME, __name); \
+									\
+  /* Define the subr.  */						\
+  scm_c_define (scm_i_paste (s_, FNAME), scm_i_paste (FNAME, __subr));	\
+)									\
+SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
+
+#else /* !SCM_SUPPORT_STATIC_ALLOCATION */
+
+/* Always use the generic subr case.  */
+#define SCM_DEFINE SCM_DEFINE_GSUBR
+
+#endif /* !SCM_SUPPORT_STATIC_ALLOCATION */
+
+
 #define SCM_PRIMITIVE_GENERIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
 SCM_SNARF_HERE(\
 static const char s_ ## FNAME [] = PRIMNAME; \
@@ -174,14 +214,36 @@ scm_c_define_subr_with_generic (RANAME, TYPE, \
 SCM_SNARF_HERE(static const char RANAME[]=STR)\
 SCM_SNARF_INIT(scm_make_synt (RANAME, TYPE, CFN))
 
-#define SCM_SYMBOL(c_name, scheme_name) \
+#ifdef SCM_SUPPORT_STATIC_ALLOCATION
+
+# define SCM_SYMBOL(c_name, scheme_name)				\
+SCM_SNARF_HERE(								\
+  SCM_IMMUTABLE_STRING (scm_i_paste (c_name, _string), scheme_name);	\
+  static SCM c_name)							\
+SCM_SNARF_INIT(								\
+  c_name = scm_string_to_symbol (scm_i_paste (c_name, _string))		\
+)
+
+# define SCM_GLOBAL_SYMBOL(c_name, scheme_name)				\
+SCM_SNARF_HERE(								\
+  SCM_IMMUTABLE_STRING (scm_i_paste (c_name, _string), scheme_name);	\
+  SCM c_name)								\
+SCM_SNARF_INIT(								\
+  c_name = scm_string_to_symbol (scm_i_paste (c_name, _string))		\
+)
+
+#else /* !SCM_SUPPORT_STATIC_ALLOCATION */
+
+# define SCM_SYMBOL(c_name, scheme_name)				\
 SCM_SNARF_HERE(static SCM c_name)					\
 SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_symbol (scheme_name)))
 
-#define SCM_GLOBAL_SYMBOL(c_name, scheme_name) \
+# define SCM_GLOBAL_SYMBOL(c_name, scheme_name)				\
 SCM_SNARF_HERE(SCM c_name)						\
 SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_symbol (scheme_name)))
 
+#endif /* !SCM_SUPPORT_STATIC_ALLOCATION */
+
 #define SCM_KEYWORD(c_name, scheme_name) \
 SCM_SNARF_HERE(static SCM c_name) \
 SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_keyword (scheme_name)))
@@ -270,6 +332,60 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
 SCM_SNARF_HERE(SCM c_name arglist) \
 SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
 
+
+/* Low-level snarfing for static memory allocation.  */
+
+#ifdef SCM_SUPPORT_STATIC_ALLOCATION
+
+#define SCM_IMMUTABLE_DOUBLE_CELL(c_name, car, cbr, ccr, cdr)		\
+  static SCM_ALIGNED (8) SCM_UNUSED const scm_t_cell			\
+  c_name ## _raw_cell [2] =						\
+    {									\
+      { SCM_PACK (car), SCM_PACK (cbr) },				\
+      { SCM_PACK (ccr), SCM_PACK (cdr) }				\
+    };									\
+  static SCM_UNUSED const SCM c_name = SCM_PACK (& c_name ## _raw_cell)
+
+#define SCM_IMMUTABLE_STRINGBUF(c_name, contents)	\
+  static SCM_UNUSED const				\
+  struct						\
+  {							\
+    scm_t_bits word_0;					\
+    scm_t_bits word_1;					\
+    const char buffer[sizeof (contents)];		\
+  }							\
+  c_name =						\
+    {							\
+      scm_tc7_stringbuf | SCM_I_STRINGBUF_F_SHARED,	\
+      sizeof (contents) - 1,				\
+      contents						\
+    }
+
+#define SCM_IMMUTABLE_STRING(c_name, contents)				\
+  SCM_IMMUTABLE_STRINGBUF (scm_i_paste (c_name, _stringbuf), contents);	\
+  SCM_IMMUTABLE_DOUBLE_CELL (c_name,					\
+			     scm_tc7_ro_string,				\
+			     (scm_t_bits) &scm_i_paste (c_name,		\
+							_stringbuf),	\
+			     (scm_t_bits) 0,				\
+			     (scm_t_bits) sizeof (contents) - 1)
+
+#define SCM_IMMUTABLE_SUBR(c_name, name, req, opt, rest, fcn)		\
+  static SCM_UNUSED SCM scm_i_paste (c_name, _meta_info)[2] =		\
+    {									\
+      SCM_BOOL_F,  /* The name, initialized at run-time.  */		\
+      SCM_EOL      /* The procedure properties.  */			\
+    };									\
+  SCM_IMMUTABLE_DOUBLE_CELL (c_name,					\
+			     SCM_SUBR_ARITY_TO_TYPE (req, opt, rest),	\
+			     (scm_t_bits) fcn,				\
+			     (scm_t_bits) 0 /* no generic */,		\
+			     (scm_t_bits) & scm_i_paste (c_name, _meta_info));
+
+#endif /* SCM_SUPPORT_STATIC_ALLOCATION */
+
+
+/* Documentation.  */
 
 #ifdef SCM_MAGIC_SNARF_DOCS
 #undef SCM_ASSERT

libguile/strings.c

@@ -72,10 +72,8 @@
 
 #define STRINGBUF_HEADER_BYTES  (STRINGBUF_HEADER_SIZE * sizeof (SCM))
 
-#define STRINGBUF_F_SHARED      0x100
+#define STRINGBUF_F_SHARED      SCM_I_STRINGBUF_F_SHARED
-#define STRINGBUF_F_WIDE        0x400 /* If true, strings have UCS-4
+#define STRINGBUF_F_WIDE        SCM_I_STRINGBUF_F_WIDE
-                                         encoding.  Otherwise, strings
-                                         are Latin-1.  */
 
 #define STRINGBUF_TAG           scm_tc7_stringbuf
 #define STRINGBUF_SHARED(buf)   (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED)
@@ -89,7 +87,14 @@
 #define STRINGBUF_WIDE_CHARS(buf) ((scm_t_wchar *) STRINGBUF_CHARS (buf))
 
 #define SET_STRINGBUF_SHARED(buf)					\
-  (SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED))
+  do									\
+    {									\
+      /* Don't modify BUF if it's already marked as shared since it might be \
+	 a read-only, statically allocated stringbuf.  */		\
+      if (SCM_LIKELY (!STRINGBUF_SHARED (buf)))				\
+	SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED); \
+    }									\
+  while (0)
 
 #if SCM_STRING_LENGTH_HISTOGRAM
 static size_t lenhist[1001];
@@ -235,7 +240,7 @@ scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 /* Read-only strings.
  */
 
-#define RO_STRING_TAG         (scm_tc7_string + 0x200)
+#define RO_STRING_TAG         scm_tc7_ro_string
 #define IS_RO_STRING(str)     (SCM_CELL_TYPE(str)==RO_STRING_TAG)
 
 /* Mutation-sharing substrings

libguile/strings.h

@@ -142,6 +142,17 @@ SCM_API size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len);
 
 SCM_API SCM scm_makfromstrs (int argc, char **argv);
 
+
+/* internal constants */
+
+/* Type tag for read-only strings.  */
+#define scm_tc7_ro_string             (scm_tc7_string + 0x200)
+
+/* Flags for shared and wide strings.  */
+#define SCM_I_STRINGBUF_F_SHARED      0x100
+#define SCM_I_STRINGBUF_F_WIDE        0x400
+
+
 /* internal accessor functions.  Arguments must be valid. */
 
 SCM_INTERNAL SCM scm_i_make_string (size_t len, char **datap);

libguile/tags.h

@@ -107,7 +107,7 @@ typedef unsigned long scm_t_bits;
 /* This is the default, which provides an intermediate level of compile time
  * type checking while still resulting in very efficient code.
  */
-    typedef struct scm_unused_struct * SCM;
+    typedef struct { char scm_unused_field; } * SCM;
 
 /*
   The 0?: constructions makes sure that the code is never executed,

libguile/vectors.c

@@ -283,7 +283,7 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj)
 	{
 	  /* Make it a weak pointer.  */
 	  GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (v))[k]);
-	  GC_GENERAL_REGISTER_DISAPPEARING_LINK (link, obj);
+	  SCM_I_REGISTER_DISAPPEARING_LINK (link, obj);
 	}
     }
   else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
@@ -301,7 +301,7 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj)
 	    {
 	      /* Make it a weak pointer.  */
 	      GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (vv))[k]);
-	      GC_GENERAL_REGISTER_DISAPPEARING_LINK (link, obj);
+	      SCM_I_REGISTER_DISAPPEARING_LINK (link, obj);
 	    }
 	}
       else

libguile/weaks.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -65,8 +65,8 @@ scm_weak_car_pair (SCM car, SCM cdr)
   if (SCM_NIMP (car))
     {
       /* Weak car cells make sense iff the car is non-immediate.  */
-      GC_GENERAL_REGISTER_DISAPPEARING_LINK ((GC_PTR)&cell->word_0,
+      SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
-					     (GC_PTR)SCM_UNPACK (car));
+					(GC_PTR) SCM_UNPACK (car));
     }
 
   return (SCM_PACK (cell));
@@ -86,8 +86,8 @@ scm_weak_cdr_pair (SCM car, SCM cdr)
   if (SCM_NIMP (cdr))
     {
       /* Weak cdr cells make sense iff the cdr is non-immediate.  */
-      GC_GENERAL_REGISTER_DISAPPEARING_LINK ((GC_PTR)&cell->word_1,
+      SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
-					     (GC_PTR)SCM_UNPACK (cdr));
+					(GC_PTR) SCM_UNPACK (cdr));
     }
 
   return (SCM_PACK (cell));
@@ -105,13 +105,13 @@ scm_doubly_weak_pair (SCM car, SCM cdr)
 
   if (SCM_NIMP (car))
     {
-      GC_GENERAL_REGISTER_DISAPPEARING_LINK ((GC_PTR)&cell->word_0,
+      SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
-					     (GC_PTR)SCM_UNPACK (car));
+					(GC_PTR) SCM_UNPACK (car));
     }
   if (SCM_NIMP (cdr))
     {
-      GC_GENERAL_REGISTER_DISAPPEARING_LINK ((GC_PTR)&cell->word_1,
+      SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
-					     (GC_PTR)SCM_UNPACK (cdr));
+					(GC_PTR) SCM_UNPACK (cdr));
     }
 
   return (SCM_PACK (cell));