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 ) is transformed into (#@delay '() ), 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));