summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore1
-rw-r--r--acinclude.m419
-rw-r--r--configure.in6
-rw-r--r--libguile/Makefile.am26
-rw-r--r--libguile/__scm.h12
-rw-r--r--libguile/_scm.h3
-rw-r--r--libguile/boehm-gc.h18
-rw-r--r--libguile/guile-snarf.in4
-rw-r--r--libguile/procs.h37
-rw-r--r--libguile/snarf.h148
-rw-r--r--libguile/strings.c17
-rw-r--r--libguile/strings.h13
-rw-r--r--libguile/tags.h4
-rw-r--r--libguile/vectors.c6
-rw-r--r--libguile/weaks.c18
15 files changed, 295 insertions, 37 deletions
diff --git a/.gitignore b/.gitignore
index 7644deacd..43545aedb 100644
--- a/.gitignore
+++ b/.gitignore
@@ -74,4 +74,5 @@ libguile/stack-limit-calibration.scm
cscope.out
cscope.files
*.log
+/libguile/snarf-gsubr.h
INSTALL
diff --git a/acinclude.m4 b/acinclude.m4
index 345e323b3..3e1dbeb2a 100644
--- a/acinclude.m4
+++ b/acinclude.m4
@@ -1,3 +1,5 @@
+dnl -*- Autoconf -*-
+
dnl On the NeXT, #including <utime.h> doesn't give you a definition for
dnl struct utime, unless you #define _POSIX_SOURCE.
@@ -308,3 +310,20 @@ else
fi
AC_LANG_RESTORE
])dnl ACX_PTHREAD
+
+
+dnl Check whether GNU ld's read-only relocations (the `PT_GNU_RELRO'
+dnl ELF segment header) are supported. This allows things like
+dnl statically allocated cells (1) to eventually be remapped read-only
+dnl by the loader, and (2) to be identified as pointerless by the
+dnl garbage collector.
+AC_DEFUN([GUILE_GNU_LD_RELRO], [
+ AC_MSG_CHECKING([whether the linker understands `-z relro'])
+
+ save_LDFLAGS="$LDFLAGS"
+ LDFLAGS="$LDFLAGS -Wl,-z -Wl,relro"
+ AC_LINK_IFELSE([AC_LANG_PROGRAM([], [])],
+ [AC_MSG_RESULT([yes])],
+ [AC_MSG_RESULT([no])
+ LDFLAGS="$save_LDFLAGS"])
+])
diff --git a/configure.in b/configure.in
index 3c54bbdcd..c278361b6 100644
--- a/configure.in
+++ b/configure.in
@@ -4,7 +4,7 @@ dnl
define(GUILE_CONFIGURE_COPYRIGHT,[[
-Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
This file is part of GUILE
@@ -1448,6 +1448,10 @@ esac
AC_SUBST(GCC_CFLAGS)
+# Check for GNU ld's "-z relro".
+GUILE_GNU_LD_RELRO
+
+
## If we're creating a shared library (using libtool!), then we'll
## need to generate a list of .lo files corresponding to the .o files
## given in LIBOBJS. We'll call it LIBLOBJS.
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index fe06c01c6..885de72c4 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
+## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -77,6 +77,21 @@ scmconfig.h: ${top_builddir}/config.h gen-scmconfig$(EXEEXT)
rm -f scmconfig.h
mv scmconfig.h.tmp scmconfig.h
+# Generate aliases for `SCM_DEFINE_GSUBR'. Since there's a lot of
+# them, it's an efficient compression method.
+snarf-gsubr.h:
+ ( echo "/* Automatically generated, do not edit. */" ; \
+ for req in `seq 0 16`; do \
+ for opt in `seq 0 16`; do \
+ for rst in 0 1; do \
+ echo "#ifndef SCM_DEFINE_SUBR_req$${req}_opt$${opt}_rst$${rst}" ; \
+ echo "# define SCM_DEFINE_SUBR_req$${req}_opt$${opt}_rst$${rst} SCM_DEFINE_GSUBR" ; \
+ echo "#endif" ; \
+ done ; \
+ done ; \
+ done ) > "$@.tmp"
+ mv "$@.tmp" "$@"
+
guile_filter_doc_snarfage_SOURCES = c-tokenize.c
## Override default rule; this should be compiled for BUILD host.
@@ -166,8 +181,8 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
-BUILT_SOURCES = cpp_err_symbols.c cpp_sig_symbols.c libpath.h \
- version.h scmconfig.h \
+BUILT_SOURCES = cpp_err_symbols.c cpp_sig_symbols.c libpath.h \
+ version.h scmconfig.h snarf-gsubr.h \
$(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
EXTRA_libguile_la_SOURCES = _scm.h \
@@ -224,7 +239,7 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \
pthread-threads.h null-threads.h throw.h unif.h values.h \
variable.h vectors.h vports.h weaks.h
-nodist_modinclude_HEADERS = version.h scmconfig.h
+nodist_modinclude_HEADERS = version.h scmconfig.h snarf-gsubr.h
bin_SCRIPTS = guile-snarf
@@ -409,7 +424,8 @@ MOSTLYCLEANFILES = \
cpp_err_symbols_here cpp_err_symbols_diff cpp_err_symbols_new \
cpp_sig_symbols_here cpp_sig_symbols_diff cpp_sig_symbols_new \
version.h version.h.tmp \
- scmconfig.h scmconfig.h.tmp stack-limit-calibration.scm
+ scmconfig.h scmconfig.h.tmp snarf-gsubr.h snarf-gsubr.h.tmp \
+ stack-limit-calibration.scm
CLEANFILES = libpath.h *.x *.doc guile-procedures.txt guile-procedures.texi guile.texi
diff --git a/libguile/__scm.h b/libguile/__scm.h
index d486b69bf..b84cbb98b 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -3,7 +3,7 @@
#ifndef SCM___SCM_H
#define SCM___SCM_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003, 2006, 2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003, 2006, 2007, 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
@@ -106,6 +106,16 @@
# define SCM_INTERNAL extern
#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 e40f29bb0..ff033ded0 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -3,7 +3,7 @@
#ifndef SCM__SCM_H
#define SCM__SCM_H
-/* Copyright (C) 1995,1996,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2002, 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
@@ -77,6 +77,7 @@
#include "libguile/variable.h"
#include "libguile/modules.h"
#include "libguile/inline.h"
+#include "libguile/strings.h"
/* SCM_SYSCALL retries system calls that have been interrupted (EINTR).
However this can be avoided if the operating system can restart
diff --git a/libguile/boehm-gc.h b/libguile/boehm-gc.h
index 708f17b35..ab842bc1b 100644
--- a/libguile/boehm-gc.h
+++ b/libguile/boehm-gc.h
@@ -1,7 +1,7 @@
#ifndef SCM_BOEHM_GC_H
#define SCM_BOEHM_GC_H
-/* Copyright (C) 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 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
@@ -45,4 +45,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_BOEHM_GC_H */
diff --git a/libguile/guile-snarf.in b/libguile/guile-snarf.in
index 617bad822..4d79f43bf 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 General Public License as published by
@@ -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 354d27179..1e273512a 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -51,6 +51,40 @@
#define SCM_CCLO_SUBR(x) (SCM_CCLO_REF ((x), 0))
#define SCM_SET_CCLO_SUBR(x, v) (SCM_CCLO_SET ((x), 0, (v)))
+/* Return the subr type corresponding to the given arity. If the arity
+ doesn't match that of a subr (e.g., too many arguments), then -1 is
+ returned. 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 \
+ : -1)))) \
+ : ((opt) == 1 \
+ ? ((req) == 0 \
+ ? scm_tc7_subr_1o \
+ : ((req) == 1 \
+ ? scm_tc7_subr_2o \
+ : -1)) \
+ : -1)) \
+ : ((rest) == 1 \
+ ? ((opt) == 0 \
+ ? ((req) == 0 \
+ ? scm_tc7_lsubr \
+ : ((req) == 2 \
+ ? scm_tc7_lsubr_2 \
+ : -1)) \
+ : -1) \
+ : -1))
+
+
+
/* Closures
*/
@@ -115,6 +149,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 5c2f18774..451323c1b 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
@@ -35,6 +35,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
@@ -73,7 +84,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\
@@ -84,6 +95,63 @@ 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
+
+/* Regular "subrs", i.e., few arguments. */
+#define SCM_DEFINE_SUBR(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)
+
+/* XXX: Eventually, we could statically allocate gsubrs as well. */
+
+/* These are the subrs whose arity makes it possible to define them as "raw
+ subrs" (as opposed to "gsubrs"). This has to be consistent with
+ `SCM_SUBR_ARITY_TO_TYPE ()' and `create_gsubr ()'. */
+#define SCM_DEFINE_SUBR_req0_opt0_rst0 SCM_DEFINE_SUBR
+#define SCM_DEFINE_SUBR_req1_opt0_rst0 SCM_DEFINE_SUBR
+#define SCM_DEFINE_SUBR_req0_opt1_rst0 SCM_DEFINE_SUBR
+#define SCM_DEFINE_SUBR_req1_opt1_rst0 SCM_DEFINE_SUBR
+#define SCM_DEFINE_SUBR_req2_opt0_rst0 SCM_DEFINE_SUBR
+#define SCM_DEFINE_SUBR_req3_opt0_rst0 SCM_DEFINE_SUBR
+#define SCM_DEFINE_SUBR_req0_opt0_rst1 SCM_DEFINE_SUBR
+#define SCM_DEFINE_SUBR_req2_opt0_rst1 SCM_DEFINE_SUBR
+
+/* For any other combination of required/optional/rest arguments, use
+ `SCM_DEFINE_GSUBR (). */
+#include "libguile/snarf-gsubr.h"
+
+/* The generic subr definition macro. This macro dispatches to either
+ `SCM_DEFINE_SUBR ()' or `SCM_DEFINE_GSUBR ()' depending on the arity of
+ the subr being defined. */
+#define SCM_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
+ SCM_DEFINE_SUBR_req ## REQ ## _opt ## OPT ## _rst ## VAR \
+ (FNAME, PRIMNAME, \
+ REQ, OPT, VAR, \
+ ARGLIST, 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; \
@@ -173,14 +241,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)))
@@ -269,6 +359,52 @@ 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) \
+ SCM_IMMUTABLE_DOUBLE_CELL (c_name, \
+ scm_tc7_stringbuf | SCM_I_STRINGBUF_F_SHARED, \
+ (scm_t_bits) (contents), \
+ (scm_t_bits) sizeof (contents) - 1, \
+ (scm_t_bits) 0)
+
+#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_raw_cell), \
+ (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 6e3b0a347..1839c6ac0 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -65,8 +65,8 @@
* stringbuf. So we have fixstrings and bigstrings...
*/
-#define STRINGBUF_F_SHARED 0x100
-#define STRINGBUF_F_INLINE 0x200
+#define STRINGBUF_F_SHARED SCM_I_STRINGBUF_F_SHARED
+#define STRINGBUF_F_INLINE SCM_I_STRINGBUF_F_INLINE
#define STRINGBUF_TAG scm_tc7_stringbuf
#define STRINGBUF_SHARED(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED)
@@ -86,8 +86,15 @@
#define STRINGBUF_MAX_INLINE_LEN (3*sizeof(scm_t_bits))
-#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_DEBUG
static size_t lenhist[1001];
@@ -155,7 +162,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 e7053257f..2dabde1d6 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -3,7 +3,7 @@
#ifndef SCM_STRINGS_H
#define SCM_STRINGS_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 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
@@ -109,6 +109,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 inline strings. */
+#define SCM_I_STRINGBUF_F_SHARED 0x100
+#define SCM_I_STRINGBUF_F_INLINE 0x200
+
+
/* 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 4e0700b52..249e1d5ba 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -3,7 +3,7 @@
#ifndef SCM_TAGS_H
#define SCM_TAGS_H
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -106,7 +106,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 c01b3e3b6..cc4c04f7b 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 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
@@ -279,7 +279,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)
@@ -297,7 +297,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 7558e78a6..6af4d6722 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
@@ -64,8 +64,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));
@@ -85,8 +85,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));
@@ -104,13 +104,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));