summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2009-11-01 18:17:31 +0100
committerLudovic Courtès <ludo@gnu.org>2009-11-01 18:17:31 +0100
commit731dd0ce191bf4f3ba8fedfe0e08c0e67a966ce4 (patch)
treedd1ad47fdceebb013c42dc9b87c03c2fa5d79c0a
parentb4246e5b2235bd01a24a5069ed683fc3c0f6f18c (diff)
parent5f236208d0d864546e59afa0f5a11c9b3ba14b10 (diff)
downloadguile-731dd0ce191bf4f3ba8fedfe0e08c0e67a966ce4.tar.gz
Merge branch 'bdw-gc-static-alloc'
Conflicts: acinclude.m4 libguile/__scm.h libguile/bdw-gc.h libguile/eval.c
-rw-r--r--libguile/__scm.h10
-rw-r--r--libguile/_scm.h1
-rw-r--r--libguile/bdw-gc.h16
-rw-r--r--libguile/eval.c47
-rw-r--r--libguile/guile-snarf.in4
-rw-r--r--libguile/procs.h43
-rw-r--r--libguile/snarf.h128
-rw-r--r--libguile/strings.c19
-rw-r--r--libguile/strings.h11
-rw-r--r--libguile/tags.h2
-rw-r--r--libguile/vectors.c4
-rw-r--r--libguile/weaks.c18
12 files changed, 252 insertions, 51 deletions
diff --git a/libguile/__scm.h b/libguile/__scm.h
index 55f9f49e2..8bb1b1a0e 100644
--- a/libguile/__scm.h
+++ b/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}
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 33cb375d1..6cb7ce8a4 100644
--- a/libguile/_scm.h
+++ b/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
diff --git a/libguile/bdw-gc.h b/libguile/bdw-gc.h
index a54785e92..3adf99e66 100644
--- a/libguile/bdw-gc.h
+++ b/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 */
diff --git a/libguile/eval.c b/libguile/eval.c
index 3c9625117..cdb90423a 100644
--- a/libguile/eval.c
+++ b/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, s_set_x);
+SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
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_apply, s_atapply + 1);
+SCM_GLOBAL_SYMBOL (scm_sym_atapply, "@apply");
+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");
diff --git a/libguile/guile-snarf.in b/libguile/guile-snarf.in
index 6a72dd5d5..043b3ed0d 100644
--- a/libguile/guile-snarf.in
+++ b/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
diff --git a/libguile/procs.h b/libguile/procs.h
index 469b735d9..7e445ad11 100644
--- a/libguile/procs.h
+++ b/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);
diff --git a/libguile/snarf.h b/libguile/snarf.h
index 03a3edd47..9eaccf60c 100644
--- a/libguile/snarf.h
+++ b/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) \
-SCM_SNARF_HERE(static SCM c_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) \
-SCM_SNARF_HERE(SCM c_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
diff --git a/libguile/strings.c b/libguile/strings.c
index c7f09db21..21295addf 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -72,10 +72,8 @@
#define STRINGBUF_HEADER_BYTES (STRINGBUF_HEADER_SIZE * sizeof (SCM))
-#define STRINGBUF_F_SHARED 0x100
-#define STRINGBUF_F_WIDE 0x400 /* If true, strings have UCS-4
- encoding. Otherwise, strings
- are Latin-1. */
+#define STRINGBUF_F_SHARED SCM_I_STRINGBUF_F_SHARED
+#define STRINGBUF_F_WIDE SCM_I_STRINGBUF_F_WIDE
#define STRINGBUF_TAG scm_tc7_stringbuf
#define STRINGBUF_SHARED(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED)
@@ -88,8 +86,15 @@
#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))
+#define SET_STRINGBUF_SHARED(buf) \
+ 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
diff --git a/libguile/strings.h b/libguile/strings.h
index e68bbe9ab..4e5f70098 100644
--- a/libguile/strings.h
+++ b/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);
diff --git a/libguile/tags.h b/libguile/tags.h
index f74573244..4a68f9c78 100644
--- a/libguile/tags.h
+++ b/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,
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 4198c5462..b1b5890f4 100644
--- a/libguile/vectors.c
+++ b/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
diff --git a/libguile/weaks.c b/libguile/weaks.c
index abe929254..913166ffd 100644
--- a/libguile/weaks.c
+++ b/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,
- (GC_PTR)SCM_UNPACK (car));
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
+ (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,
- (GC_PTR)SCM_UNPACK (cdr));
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
+ (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,
- (GC_PTR)SCM_UNPACK (car));
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
+ (GC_PTR) SCM_UNPACK (car));
}
if (SCM_NIMP (cdr))
{
- GC_GENERAL_REGISTER_DISAPPEARING_LINK ((GC_PTR)&cell->word_1,
- (GC_PTR)SCM_UNPACK (cdr));
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
+ (GC_PTR) SCM_UNPACK (cdr));
}
return (SCM_PACK (cell));