X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/53befeb700c31dec58cec2c8f6f34535541a2f39..26b263541b56cf79f2c249950c5eadb87ce28b68:/libguile/snarf.h diff --git a/libguile/snarf.h b/libguile/snarf.h index 03a3edd47..1c072babb 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -3,7 +3,8 @@ #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, 2010, 2011 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 @@ -25,17 +26,21 @@ /* Macros for snarfing initialization actions from C source. */ -#if defined(__cplusplus) || defined(GUILE_CPLUSPLUS_SNARF) +/* Casting to a function that can take any number of arguments. */ +#define SCM_FUNC_CAST_ARBITRARY_ARGS scm_t_subr -/* This used to be "SCM (*)(...)" but GCC on RedHat 7.1 doesn't seem - to like it. - */ -#define SCM_FUNC_CAST_ARBITRARY_ARGS SCM (*)() -#else -#define SCM_FUNC_CAST_ARBITRARY_ARGS SCM (*)() +#ifdef SCM_ALIGNED +/* 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 @@ -48,11 +53,17 @@ * The SCM_SNARF_INIT text goes into the corresponding .x file * up through the first occurrence of SCM_SNARF_DOC_START on that * line, if any. + * + * Some debugging options can cause the preprocessor to echo #define + * directives to its output. Keeping the snarfing markers on separate + * lines prevents guile-snarf from inadvertently snarfing the definition + * of SCM_SNARF_INIT if those options are in effect. */ #ifdef SCM_MAGIC_SNARF_INITS # define SCM_SNARF_HERE(X) -# define SCM_SNARF_INIT(X) ^^ X ^:^ +# define SCM_SNARF_INIT_PREFIX ^^ +# define SCM_SNARF_INIT(X) SCM_SNARF_INIT_PREFIX X ^:^ # define SCM_SNARF_DOCS(TYPE, CNAME, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) #else # ifdef SCM_MAGIC_SNARF_DOCS @@ -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,49 @@ 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. */ +/* FIXME: how to verify that req + opt + rest < 11, all are positive, etc? */ +#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_API SCM FNAME ARGLIST; \ + SCM_IMMUTABLE_POINTER (scm_i_paste (FNAME, __subr_foreign), \ + (scm_t_bits) &FNAME); /* the subr */ \ + SCM_STATIC_SUBR_OBJVECT (scm_i_paste (FNAME, __raw_objtable), \ + /* FIXME: directly be the foreign */ \ + SCM_BOOL_F); \ + /* FIXME: be immutable. grr */ \ + SCM_STATIC_PROGRAM (scm_i_paste (FNAME, __subr), \ + SCM_BOOL_F, \ + SCM_PACK (&scm_i_paste (FNAME, __raw_objtable)), \ + SCM_BOOL_F); \ + SCM FNAME ARGLIST \ +) \ +SCM_SNARF_INIT( \ + /* Initialize the foreign. */ \ + scm_i_paste (FNAME, __raw_objtable)[2] = scm_i_paste (FNAME, __subr_foreign); \ + /* Initialize the procedure name (an interned symbol). */ \ + scm_i_paste (FNAME, __raw_objtable)[3] = scm_i_paste (FNAME, __name); \ + /* Initialize the objcode trampoline. */ \ + SCM_SET_CELL_OBJECT (scm_i_paste (FNAME, __subr), 1, \ + scm_subr_objcode_trampoline (REQ, OPT, VAR)); \ + \ + /* Define the subr. */ \ + scm_define (scm_i_paste (FNAME, __name), 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; \ @@ -111,26 +165,6 @@ scm_c_export (s_ ## FNAME, NULL); \ )\ SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) -#define SCM_DEFINE1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \ -SCM_SNARF_HERE(\ -static const char s_ ## FNAME [] = PRIMNAME; \ -SCM FNAME ARGLIST\ -)\ -SCM_SNARF_INIT(scm_c_define_subr (s_ ## FNAME, TYPE, FNAME); ) \ -SCM_SNARF_DOCS(1, FNAME, PRIMNAME, ARGLIST, 2, 0, 0, DOCSTRING) - -#define SCM_PRIMITIVE_GENERIC_1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \ -SCM_SNARF_HERE(\ -static const char s_ ## FNAME [] = PRIMNAME; \ -static SCM g_ ## FNAME; \ -SCM FNAME ARGLIST\ -)\ -SCM_SNARF_INIT(\ -g_ ## FNAME = SCM_PACK (0); \ -scm_c_define_subr_with_generic (s_ ## FNAME, TYPE, FNAME, &g_ ## FNAME); \ -)\ -SCM_SNARF_DOCS(1, FNAME, PRIMNAME, ARGLIST, 2, 0, 0, DOCSTRING) - #define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ SCM_SNARF_HERE(static const char RANAME[]=STR) \ SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \ @@ -153,58 +187,59 @@ scm_c_define_gsubr_with_generic (RANAME, REQ, OPT, VAR, \ (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN, &GF) \ ) -#define SCM_PROC1(RANAME, STR, TYPE, CFN) \ -SCM_SNARF_HERE(static const char RANAME[]=STR) \ -SCM_SNARF_INIT(\ -scm_c_define_subr (RANAME, TYPE, (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN) \ -) +#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_GPROC1(RANAME, STR, TYPE, CFN, GF) \ -SCM_SNARF_HERE(\ -static const char RANAME[]=STR; \ -static SCM GF \ -)SCM_SNARF_INIT(\ -GF = SCM_PACK (0); /* Dirk:FIXME:: Can we safely use #f instead of 0? */ \ -scm_c_define_subr_with_generic (RANAME, TYPE, \ - (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN, &GF) \ +# 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)) \ ) -#define SCM_SYNTAX(RANAME, STR, TYPE, CFN) \ -SCM_SNARF_HERE(static const char RANAME[]=STR)\ -SCM_SNARF_INIT(scm_make_synt (RANAME, TYPE, CFN)) +#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_SYMBOL(c_name, scheme_name) \ +SCM_SNARF_HERE(static SCM c_name) \ +SCM_SNARF_INIT(c_name = scm_from_locale_symbol (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))) +# define SCM_GLOBAL_SYMBOL(c_name, scheme_name) \ +SCM_SNARF_HERE(SCM c_name) \ +SCM_SNARF_INIT(c_name = 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))) +SCM_SNARF_INIT(c_name = scm_from_locale_keyword (scheme_name)) #define SCM_GLOBAL_KEYWORD(c_name, scheme_name) \ SCM_SNARF_HERE(SCM c_name) \ -SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_keyword (scheme_name))) +SCM_SNARF_INIT(c_name = scm_from_locale_keyword (scheme_name)) #define SCM_VARIABLE(c_name, scheme_name) \ SCM_SNARF_HERE(static SCM c_name) \ -SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, SCM_BOOL_F));) +SCM_SNARF_INIT(c_name = scm_c_define (scheme_name, SCM_BOOL_F);) #define SCM_GLOBAL_VARIABLE(c_name, scheme_name) \ SCM_SNARF_HERE(SCM c_name) \ -SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, SCM_BOOL_F));) +SCM_SNARF_INIT(c_name = scm_c_define (scheme_name, SCM_BOOL_F);) #define SCM_VARIABLE_INIT(c_name, scheme_name, init_val) \ SCM_SNARF_HERE(static SCM c_name) \ -SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, init_val));) +SCM_SNARF_INIT(c_name = scm_c_define (scheme_name, init_val);) #define SCM_GLOBAL_VARIABLE_INIT(c_name, scheme_name, init_val) \ SCM_SNARF_HERE(SCM c_name) \ -SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, init_val));) +SCM_SNARF_INIT(c_name = scm_c_define (scheme_name, init_val);) #define SCM_MUTEX(c_name) \ SCM_SNARF_HERE(static scm_t_mutex c_name) \ @@ -270,6 +305,91 @@ 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_CELL(c_name, car, cdr) \ + static SCM_ALIGNED (8) SCM_UNUSED const scm_t_cell \ + c_name ## _raw_scell = \ + { \ + SCM_PACK (car), \ + SCM_PACK (cdr) \ + }; \ + static SCM_UNUSED const SCM c_name = SCM_PACK (& c_name ## _raw_scell) + +#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_STATIC_DOUBLE_CELL(c_name, car, cbr, ccr, cdr) \ + static SCM_ALIGNED (8) SCM_UNUSED scm_t_cell \ + c_name ## _raw_cell [2] = \ + { \ + { SCM_PACK (car), SCM_PACK (cbr) }, \ + { SCM_PACK (ccr), SCM_PACK (cdr) } \ + }; \ + static SCM_UNUSED 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_POINTER(c_name, ptr) \ + SCM_IMMUTABLE_CELL (c_name, scm_tc7_pointer, ptr) + +/* for primitive-generics, add a foreign to the end */ +#define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \ + static SCM_ALIGNED (8) SCM c_name[4] = \ + { \ + SCM_PACK (scm_tc7_vector | (2 << 8)), \ + SCM_PACK (0), \ + foreign, \ + SCM_BOOL_F, /* the name */ \ + } + +#define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars) \ + static SCM_ALIGNED (8) SCM_UNUSED SCM \ + scm_i_paste (c_name, _raw_cell)[] = \ + { \ + SCM_PACK (scm_tc7_program | SCM_F_PROGRAM_IS_PRIMITIVE), \ + objcode, \ + objtable, \ + freevars \ + }; \ + static SCM_UNUSED const SCM c_name = \ + SCM_PACK (& scm_i_paste (c_name, _raw_cell)) + +#endif /* SCM_SUPPORT_STATIC_ALLOCATION */ + + +/* Documentation. */ #ifdef SCM_MAGIC_SNARF_DOCS #undef SCM_ASSERT