#ifndef SCM_SNARF_H
#define SCM_SNARF_H
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2009 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 as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
\f
/* 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 (*)()
-#endif
-#if (defined SCM_ALIGNED) && (SCM_DEBUG_TYPING_STRICTNESS <= 1)
+#ifdef SCM_ALIGNED
/* We support static allocation of some `SCM' objects. */
# define SCM_SUPPORT_STATIC_ALLOCATION
#endif
* 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
#ifdef SCM_SUPPORT_STATIC_ALLOCATION
-/* Regular "subrs", i.e., few arguments. */
-#define SCM_DEFINE_SUBR(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
+/* 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( \
+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_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( \
+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, __subr_meta_info)[0] = scm_i_paste (FNAME, __name); \
+ 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_c_define (scm_i_paste (s_, FNAME), scm_i_paste (FNAME, __subr)); \
+ scm_define (scm_i_paste (FNAME, __name), 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. */
)\
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, \
(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) \
-)
-
-
-#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_SYNTAX(RANAME, STR, TYPE, CFN) \
-SCM_SNARF_HERE(static const char RANAME[]=STR)\
-SCM_SNARF_INIT(scm_make_synt (RANAME, TYPE, CFN))
-
#ifdef SCM_SUPPORT_STATIC_ALLOCATION
# define SCM_SYMBOL(c_name, scheme_name) \
# 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)))
+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)))
+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) \
#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] = \
}; \
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_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_raw_cell), \
+ _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));
+ (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 */