[bpt/guile.git] / libguile / snarf.h

/* classes: h_files */

#ifndef SCM_SNARF_H
#define SCM_SNARF_H

/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
 *   2004, 2006, 2009, 2010, 2011, 2014 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 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
 * 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
 */

\f

/* Macros for snarfing initialization actions from C source. */

/* Casting to a function that can take any number of arguments.  */
#define SCM_FUNC_CAST_ARBITRARY_ARGS  scm_t_subr


#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


\f
/* Generic macros to be used in user macro definitions.
 *
 * For example, in order to define a macro which creates ints and
 * initializes them to the result of foo (), do:
 *
 *   #define SCM_FOO(NAME) \
 *     SCM_SNARF_HERE (int NAME) \
 *     SCM_SNARF_INIT (NAME = foo ())
 *
 * 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_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
#  define SCM_SNARF_HERE(X)
#  define SCM_SNARF_INIT(X)
#  define SCM_SNARF_DOCS(TYPE, CNAME, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) \
^^ { \
cname CNAME ^^ \
fname FNAME ^^ \
type TYPE ^^ \
location __FILE__ __LINE__ ^^ \
arglist ARGLIST ^^ \
argsig REQ OPT VAR ^^ \
DOCSTRING ^^ }
# else
#  define SCM_SNARF_HERE(X) X
#  define SCM_SNARF_INIT(X)
#  define SCM_SNARF_DOCS(TYPE, CNAME, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
# endif
#endif

#define SCM_DEFINE_GSUBR(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
SCM_SNARF_HERE(\
SCM_UNUSED static const char s_ ## FNAME [] = PRIMNAME; \
SCM FNAME ARGLIST\
)\
SCM_SNARF_INIT(\
scm_c_define_gsubr (s_ ## FNAME, REQ, OPT, VAR, \
                    (SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME); \
)\
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(							        \
  SCM_UNUSED 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(\
SCM_UNUSED static const char s_ ## FNAME [] = PRIMNAME; \
static SCM g_ ## FNAME; \
SCM FNAME ARGLIST\
)\
SCM_SNARF_INIT(\
g_ ## FNAME = SCM_PACK (0); \
scm_c_define_gsubr_with_generic (s_ ## FNAME, REQ, OPT, VAR, \
                    		 (SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME, \
				 &g_ ## FNAME); \
)\
SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)

#define SCM_DEFINE_PUBLIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
SCM_SNARF_HERE(\
SCM_UNUSED static const char s_ ## FNAME [] = PRIMNAME; \
SCM FNAME ARGLIST\
)\
SCM_SNARF_INIT(\
scm_c_define_gsubr (s_ ## FNAME, REQ, OPT, VAR, \
                    (SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME); \
scm_c_export (s_ ## FNAME, NULL); \
)\
SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)

#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN)  \
SCM_SNARF_HERE(SCM_UNUSED static const char RANAME[]=STR) \
SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \
                                   (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN))

#define SCM_REGISTER_PROC(RANAME, STR, REQ, OPT, VAR, CFN)  \
SCM_SNARF_HERE(SCM_UNUSED static const char RANAME[]=STR) \
SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \
                                   (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN);) \
SCM_SNARF_DOCS(register, CFN, STR, (), REQ, OPT, VAR, \
               "implemented by the C function \"" #CFN "\"")

#define SCM_GPROC(RANAME, STR, REQ, OPT, VAR, CFN, GF)  \
SCM_SNARF_HERE(\
SCM_UNUSED 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_gsubr_with_generic (RANAME, REQ, OPT, VAR, \
                                 (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN, &GF) \
)

#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_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_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_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_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_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_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_c_define (scheme_name, init_val);)

#define SCM_MUTEX(c_name) \
SCM_SNARF_HERE(static scm_t_mutex c_name) \
SCM_SNARF_INIT(scm_i_plugin_mutex_init (&c_name, &scm_i_plugin_mutex))

#define SCM_GLOBAL_MUTEX(c_name) \
SCM_SNARF_HERE(scm_t_mutex c_name) \
SCM_SNARF_INIT(scm_i_plugin_mutex_init (&c_name, &scm_i_plugin_mutex))

#define SCM_REC_MUTEX(c_name) \
SCM_SNARF_HERE(static scm_t_rec_mutex c_name) \
SCM_SNARF_INIT(scm_i_plugin_rec_mutex_init (&c_name, &scm_i_plugin_rec_mutex))

#define SCM_GLOBAL_REC_MUTEX(c_name) \
SCM_SNARF_HERE(scm_t_rec_mutex c_name) \
SCM_SNARF_INIT(scm_i_plugin_rec_mutex_init (&c_name, &scm_i_plugin_rec_mutex))

#define SCM_SMOB(tag, scheme_name, size) \
SCM_SNARF_HERE(static scm_t_bits tag) \
SCM_SNARF_INIT((tag)=scm_make_smob_type((scheme_name), (size));)

#define SCM_GLOBAL_SMOB(tag, scheme_name, size) \
SCM_SNARF_HERE(scm_t_bits tag) \
SCM_SNARF_INIT((tag)=scm_make_smob_type((scheme_name), (size));)

#define SCM_SMOB_MARK(tag, c_name, arg) \
SCM_SNARF_HERE(static SCM c_name(SCM arg)) \
SCM_SNARF_INIT(scm_set_smob_mark((tag), (c_name));)

#define SCM_GLOBAL_SMOB_MARK(tag, c_name, arg) \
SCM_SNARF_HERE(SCM c_name(SCM arg)) \
SCM_SNARF_INIT(scm_set_smob_mark((tag), (c_name));)

#define SCM_SMOB_FREE(tag, c_name, arg) \
SCM_SNARF_HERE(static size_t c_name(SCM arg)) \
SCM_SNARF_INIT(scm_set_smob_free((tag), (c_name));)

#define SCM_GLOBAL_SMOB_FREE(tag, c_name, arg) \
SCM_SNARF_HERE(size_t c_name(SCM arg)) \
SCM_SNARF_INIT(scm_set_smob_free((tag), (c_name));)

#define SCM_SMOB_PRINT(tag, c_name, obj, port, pstate) \
SCM_SNARF_HERE(static int c_name(SCM obj, SCM port, scm_print_state* pstate)) \
SCM_SNARF_INIT(scm_set_smob_print((tag), (c_name));)

#define SCM_GLOBAL_SMOB_PRINT(tag, c_name, obj, port, pstate) \
SCM_SNARF_HERE(int c_name(SCM obj, SCM port, scm_print_state* pstate)) \
SCM_SNARF_INIT(scm_set_smob_print((tag), (c_name));)

#define SCM_SMOB_EQUALP(tag, c_name, obj1, obj2) \
SCM_SNARF_HERE(static SCM c_name(SCM obj1, SCM obj2)) \
SCM_SNARF_INIT(scm_set_smob_equalp((tag), (c_name));)

#define SCM_GLOBAL_SMOB_EQUALP(tag, c_name, obj1, obj2) \
SCM_SNARF_HERE(SCM c_name(SCM obj1, SCM obj2)) \
SCM_SNARF_INIT(scm_set_smob_equalp((tag), (c_name));)

#define SCM_SMOB_APPLY(tag, c_name, req, opt, rest, arglist) \
SCM_SNARF_HERE(static SCM c_name arglist) \
SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)

#define SCM_GLOBAL_SMOB_APPLY(tag, c_name, req, opt, rest, arglist) \
SCM_SNARF_HERE(SCM c_name arglist) \
SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)

\f
/* 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 */

\f
/* Documentation.  */

#ifdef SCM_MAGIC_SNARF_DOCS
#undef SCM_ASSERT
#define SCM_ASSERT(_cond, _arg, _pos, _subr) ^^ argpos _arg _pos __LINE__ ^^
#endif /* SCM_MAGIC_SNARF_DOCS */

#endif  /* SCM_SNARF_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/
Commit	Line	Data
5b4215a8 JB	1	/* classes: h_files */
5b4215a8 JB	2
b29058ff DH	3	#ifndef SCM_SNARF_H
b29058ff DH	4	#define SCM_SNARF_H
5b4215a8	5
be90d0b6	6	/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
b8d7aacd	7	* 2004, 2006, 2009, 2010, 2011, 2014 Free Software Foundation, Inc.
b29058ff	8	*
73be1d9e	9	* This library is free software; you can redistribute it and/or
53befeb7 NJ	10	* modify it under the terms of the GNU Lesser General Public License
	11	* as published by the Free Software Foundation; either version 3 of
	12	* the License, or (at your option) any later version.
b29058ff	13	*
53befeb7 NJ	14	* This library is distributed in the hope that it will be useful, but
53befeb7 NJ	15	* WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e MV	16	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
73be1d9e MV	17	* Lesser General Public License for more details.
b29058ff	18	*
73be1d9e MV	19	* You should have received a copy of the GNU Lesser General Public
73be1d9e MV	20	* License along with this library; if not, write to the Free Software
53befeb7 NJ	21	* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
53befeb7 NJ	22	* 02110-1301 USA
73be1d9e	23	*/
1bbd0b84	24
5b4215a8 JB	25	\f
5b4215a8 JB	26
b29058ff DH	27	/* Macros for snarfing initialization actions from C source. */
b29058ff DH	28
be90d0b6 LC	29	/* Casting to a function that can take any number of arguments. */
be90d0b6 LC	30	#define SCM_FUNC_CAST_ARBITRARY_ARGS scm_t_subr
e1fbffa9	31
bfe19b46	32
544a29de	33	#ifdef SCM_ALIGNED
c6054fea LC	34	/* We support static allocation of some `SCM' objects. */
	35	# define SCM_SUPPORT_STATIC_ALLOCATION
	36	#endif
	37
b68095f0 LC	38	/* C preprocessor token concatenation. */
	39	#define scm_i_paste(x, y) x ## y
	40	#define scm_i_paste3(a, b, c) a ## b ## c
	41
c6054fea LC	42
c6054fea LC	43	\f
73d8385e MD	44	/* Generic macros to be used in user macro definitions.
	45	*
	46	* For example, in order to define a macro which creates ints and
	47	* initializes them to the result of foo (), do:
	48	*
	49	* #define SCM_FOO(NAME) \
94a70859 MD	50	* SCM_SNARF_HERE (int NAME) \
94a70859 MD	51	* SCM_SNARF_INIT (NAME = foo ())
1e76143f	52	*
94a70859	53	* The SCM_SNARF_INIT text goes into the corresponding .x file
3c6d9d71 DH	54	* up through the first occurrence of SCM_SNARF_DOC_START on that
3c6d9d71 DH	55	* line, if any.
95c1cfb5 BT	56	*
	57	* Some debugging options can cause the preprocessor to echo #define
	58	* directives to its output. Keeping the snarfing markers on separate
	59	* lines prevents guile-snarf from inadvertently snarfing the definition
	60	* of SCM_SNARF_INIT if those options are in effect.
73d8385e MD	61	*/
73d8385e MD	62
c99f9605 ML	63	#ifdef SCM_MAGIC_SNARF_INITS
c99f9605 ML	64	# define SCM_SNARF_HERE(X)
95c1cfb5 BT	65	# define SCM_SNARF_INIT_PREFIX ^^
95c1cfb5 BT	66	# define SCM_SNARF_INIT(X) SCM_SNARF_INIT_PREFIX X ^:^
cecb4a5e	67	# define SCM_SNARF_DOCS(TYPE, CNAME, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
1e76143f	68	#else
c99f9605	69	# ifdef SCM_MAGIC_SNARF_DOCS
94a70859	70	# define SCM_SNARF_HERE(X)
c99f9605	71	# define SCM_SNARF_INIT(X)
cecb4a5e	72	# define SCM_SNARF_DOCS(TYPE, CNAME, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) \
ac13d9d2	73	^^ { \
cecb4a5e	74	cname CNAME ^^ \
ac13d9d2 ML	75	fname FNAME ^^ \
	76	type TYPE ^^ \
	77	location __FILE__ __LINE__ ^^ \
	78	arglist ARGLIST ^^ \
	79	argsig REQ OPT VAR ^^ \
	80	DOCSTRING ^^ }
c99f9605 ML	81	# else
	82	# define SCM_SNARF_HERE(X) X
	83	# define SCM_SNARF_INIT(X)
cecb4a5e	84	# define SCM_SNARF_DOCS(TYPE, CNAME, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
c99f9605	85	# endif
1e76143f	86	#endif
73d8385e	87
46f9baf4	88	#define SCM_DEFINE_GSUBR(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
94a70859	89	SCM_SNARF_HERE(\
b8d7aacd	90	SCM_UNUSED static const char s_ ## FNAME [] = PRIMNAME; \
4b4d0898 GB	91	SCM FNAME ARGLIST\
4b4d0898 GB	92	)\
94a70859	93	SCM_SNARF_INIT(\
9a441ddb MV	94	scm_c_define_gsubr (s_ ## FNAME, REQ, OPT, VAR, \
9a441ddb MV	95	(SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME); \
2fdcf8bd	96	)\
cecb4a5e	97	SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
1bbd0b84	98
46f9baf4 LC	99	#ifdef SCM_SUPPORT_STATIC_ALLOCATION
46f9baf4 LC	100
f0eb5ae6	101	/* Static subr allocation. */
fd12a19a	102	/* FIXME: how to verify that req + opt + rest < 11, all are positive, etc? */
f0eb5ae6	103	#define SCM_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
46f9baf4	104	SCM_SYMBOL (scm_i_paste (FNAME, __name), PRIMNAME); \
fd12a19a	105	SCM_SNARF_HERE( \
b8d7aacd	106	SCM_UNUSED static const char scm_i_paste (s_, FNAME) [] = PRIMNAME; \
f4767979	107	SCM_API SCM FNAME ARGLIST; \
5b46a8c2	108	SCM_IMMUTABLE_POINTER (scm_i_paste (FNAME, __subr_foreign), \
52fd9639	109	(scm_t_bits) &FNAME); /* the subr */ \
fd12a19a AW	110	SCM_STATIC_SUBR_OBJVECT (scm_i_paste (FNAME, __raw_objtable), \
	111	/* FIXME: directly be the foreign */ \
	112	SCM_BOOL_F); \
	113	/* FIXME: be immutable. grr */ \
	114	SCM_STATIC_PROGRAM (scm_i_paste (FNAME, __subr), \
	115	SCM_BOOL_F, \
	116	SCM_PACK (&scm_i_paste (FNAME, __raw_objtable)), \
	117	SCM_BOOL_F); \
46f9baf4 LC	118	SCM FNAME ARGLIST \
46f9baf4 LC	119	) \
f4767979	120	SCM_SNARF_INIT( \
fd12a19a AW	121	/* Initialize the foreign. */ \
fd12a19a AW	122	scm_i_paste (FNAME, __raw_objtable)[2] = scm_i_paste (FNAME, __subr_foreign); \
46f9baf4	123	/* Initialize the procedure name (an interned symbol). */ \
fd12a19a AW	124	scm_i_paste (FNAME, __raw_objtable)[3] = scm_i_paste (FNAME, __name); \
	125	/* Initialize the objcode trampoline. */ \
	126	SCM_SET_CELL_OBJECT (scm_i_paste (FNAME, __subr), 1, \
	127	scm_subr_objcode_trampoline (REQ, OPT, VAR)); \
46f9baf4 LC	128	\
46f9baf4 LC	129	/* Define the subr. */ \
fd12a19a	130	scm_define (scm_i_paste (FNAME, __name), scm_i_paste (FNAME, __subr)); \
46f9baf4 LC	131	) \
	132	SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
	133
46f9baf4 LC	134	#else /* !SCM_SUPPORT_STATIC_ALLOCATION */
	135
	136	/* Always use the generic subr case. */
	137	#define SCM_DEFINE SCM_DEFINE_GSUBR
	138
	139	#endif /* !SCM_SUPPORT_STATIC_ALLOCATION */
	140
	141
a48d60b1 MD	142	#define SCM_PRIMITIVE_GENERIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
a48d60b1 MD	143	SCM_SNARF_HERE(\
b8d7aacd	144	SCM_UNUSED static const char s_ ## FNAME [] = PRIMNAME; \
a48d60b1 MD	145	static SCM g_ ## FNAME; \
	146	SCM FNAME ARGLIST\
	147	)\
	148	SCM_SNARF_INIT(\
	149	g_ ## FNAME = SCM_PACK (0); \
	150	scm_c_define_gsubr_with_generic (s_ ## FNAME, REQ, OPT, VAR, \
	151	(SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME, \
	152	&g_ ## FNAME); \
	153	)\
	154	SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
	155
5527702a MV	156	#define SCM_DEFINE_PUBLIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
5527702a MV	157	SCM_SNARF_HERE(\
b8d7aacd	158	SCM_UNUSED static const char s_ ## FNAME [] = PRIMNAME; \
5527702a MV	159	SCM FNAME ARGLIST\
	160	)\
	161	SCM_SNARF_INIT(\
	162	scm_c_define_gsubr (s_ ## FNAME, REQ, OPT, VAR, \
	163	(SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME); \
	164	scm_c_export (s_ ## FNAME, NULL); \
	165	)\
	166	SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
	167
9b1594fd	168	#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
b8d7aacd	169	SCM_SNARF_HERE(SCM_UNUSED static const char RANAME[]=STR) \
9a441ddb MV	170	SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \
9a441ddb MV	171	(SCM_FUNC_CAST_ARBITRARY_ARGS) CFN))
9b1594fd	172
1bbd0b84	173	#define SCM_REGISTER_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
b8d7aacd	174	SCM_SNARF_HERE(SCM_UNUSED static const char RANAME[]=STR) \
9a441ddb MV	175	SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \
9a441ddb MV	176	(SCM_FUNC_CAST_ARBITRARY_ARGS) CFN);) \
cecb4a5e	177	SCM_SNARF_DOCS(register, CFN, STR, (), REQ, OPT, VAR, \
c99f9605	178	"implemented by the C function \"" #CFN "\"")
3dc81fba	179
9de33deb	180	#define SCM_GPROC(RANAME, STR, REQ, OPT, VAR, CFN, GF) \
94a70859	181	SCM_SNARF_HERE(\
b8d7aacd	182	SCM_UNUSED static const char RANAME[]=STR;\
54778cd3	183	static SCM GF \
94a70859	184	)SCM_SNARF_INIT(\
54778cd3	185	GF = SCM_PACK (0); /* Dirk:FIXME:: Can we safely use #f instead of 0? */ \
9a441ddb MV	186	scm_c_define_gsubr_with_generic (RANAME, REQ, OPT, VAR, \
9a441ddb MV	187	(SCM_FUNC_CAST_ARBITRARY_ARGS) CFN, &GF) \
4b4d0898	188	)
3dc81fba	189
c6054fea LC	190	#ifdef SCM_SUPPORT_STATIC_ALLOCATION
	191
	192	# define SCM_SYMBOL(c_name, scheme_name) \
	193	SCM_SNARF_HERE( \
b68095f0	194	SCM_IMMUTABLE_STRING (scm_i_paste (c_name, _string), scheme_name); \
c6054fea	195	static SCM c_name) \
b68095f0 LC	196	SCM_SNARF_INIT( \
	197	c_name = scm_string_to_symbol (scm_i_paste (c_name, _string)) \
	198	)
c6054fea LC	199
	200	# define SCM_GLOBAL_SYMBOL(c_name, scheme_name) \
	201	SCM_SNARF_HERE( \
b68095f0	202	SCM_IMMUTABLE_STRING (scm_i_paste (c_name, _string), scheme_name); \
c6054fea	203	SCM c_name) \
b68095f0 LC	204	SCM_SNARF_INIT( \
	205	c_name = scm_string_to_symbol (scm_i_paste (c_name, _string)) \
	206	)
c6054fea LC	207
	208	#else /* !SCM_SUPPORT_STATIC_ALLOCATION */
	209
	210	# define SCM_SYMBOL(c_name, scheme_name) \
	211	SCM_SNARF_HERE(static SCM c_name) \
e7efe8e7	212	SCM_SNARF_INIT(c_name = scm_from_locale_symbol (scheme_name))
5b4215a8	213
c6054fea LC	214	# define SCM_GLOBAL_SYMBOL(c_name, scheme_name) \
c6054fea LC	215	SCM_SNARF_HERE(SCM c_name) \
e7efe8e7	216	SCM_SNARF_INIT(c_name = scm_from_locale_symbol (scheme_name))
78f9f47b	217
c6054fea LC	218	#endif /* !SCM_SUPPORT_STATIC_ALLOCATION */
c6054fea LC	219
37b83f68	220	#define SCM_KEYWORD(c_name, scheme_name) \
94a70859	221	SCM_SNARF_HERE(static SCM c_name) \
e7efe8e7	222	SCM_SNARF_INIT(c_name = scm_from_locale_keyword (scheme_name))
37b83f68	223
37b83f68	224	#define SCM_GLOBAL_KEYWORD(c_name, scheme_name) \
94a70859	225	SCM_SNARF_HERE(SCM c_name) \
e7efe8e7	226	SCM_SNARF_INIT(c_name = scm_from_locale_keyword (scheme_name))
5b4215a8	227
86d31dfe MV	228	#define SCM_VARIABLE(c_name, scheme_name) \
86d31dfe MV	229	SCM_SNARF_HERE(static SCM c_name) \
e7efe8e7	230	SCM_SNARF_INIT(c_name = scm_c_define (scheme_name, SCM_BOOL_F);)
86d31dfe MV	231
	232	#define SCM_GLOBAL_VARIABLE(c_name, scheme_name) \
	233	SCM_SNARF_HERE(SCM c_name) \
e7efe8e7	234	SCM_SNARF_INIT(c_name = scm_c_define (scheme_name, SCM_BOOL_F);)
86d31dfe MV	235
	236	#define SCM_VARIABLE_INIT(c_name, scheme_name, init_val) \
	237	SCM_SNARF_HERE(static SCM c_name) \
e7efe8e7	238	SCM_SNARF_INIT(c_name = scm_c_define (scheme_name, init_val);)
86d31dfe MV	239
	240	#define SCM_GLOBAL_VARIABLE_INIT(c_name, scheme_name, init_val) \
	241	SCM_SNARF_HERE(SCM c_name) \
e7efe8e7	242	SCM_SNARF_INIT(c_name = scm_c_define (scheme_name, init_val);)
86d31dfe	243
28d52ebb MD	244	#define SCM_MUTEX(c_name) \
	245	SCM_SNARF_HERE(static scm_t_mutex c_name) \
	246	SCM_SNARF_INIT(scm_i_plugin_mutex_init (&c_name, &scm_i_plugin_mutex))
9bc4701c	247
28d52ebb MD	248	#define SCM_GLOBAL_MUTEX(c_name) \
	249	SCM_SNARF_HERE(scm_t_mutex c_name) \
	250	SCM_SNARF_INIT(scm_i_plugin_mutex_init (&c_name, &scm_i_plugin_mutex))
9bc4701c	251
28d52ebb MD	252	#define SCM_REC_MUTEX(c_name) \
	253	SCM_SNARF_HERE(static scm_t_rec_mutex c_name) \
	254	SCM_SNARF_INIT(scm_i_plugin_rec_mutex_init (&c_name, &scm_i_plugin_rec_mutex))
9bc4701c	255
28d52ebb MD	256	#define SCM_GLOBAL_REC_MUTEX(c_name) \
28d52ebb MD	257	SCM_SNARF_HERE(scm_t_rec_mutex c_name) \
0b6843b1	258	SCM_SNARF_INIT(scm_i_plugin_rec_mutex_init (&c_name, &scm_i_plugin_rec_mutex))
9bc4701c	259
94e38a65 MV	260	#define SCM_SMOB(tag, scheme_name, size) \
	261	SCM_SNARF_HERE(static scm_t_bits tag) \
	262	SCM_SNARF_INIT((tag)=scm_make_smob_type((scheme_name), (size));)
	263
	264	#define SCM_GLOBAL_SMOB(tag, scheme_name, size) \
	265	SCM_SNARF_HERE(scm_t_bits tag) \
	266	SCM_SNARF_INIT((tag)=scm_make_smob_type((scheme_name), (size));)
	267
	268	#define SCM_SMOB_MARK(tag, c_name, arg) \
	269	SCM_SNARF_HERE(static SCM c_name(SCM arg)) \
	270	SCM_SNARF_INIT(scm_set_smob_mark((tag), (c_name));)
	271
	272	#define SCM_GLOBAL_SMOB_MARK(tag, c_name, arg) \
	273	SCM_SNARF_HERE(SCM c_name(SCM arg)) \
	274	SCM_SNARF_INIT(scm_set_smob_mark((tag), (c_name));)
	275
	276	#define SCM_SMOB_FREE(tag, c_name, arg) \
	277	SCM_SNARF_HERE(static size_t c_name(SCM arg)) \
	278	SCM_SNARF_INIT(scm_set_smob_free((tag), (c_name));)
	279
	280	#define SCM_GLOBAL_SMOB_FREE(tag, c_name, arg) \
	281	SCM_SNARF_HERE(size_t c_name(SCM arg)) \
	282	SCM_SNARF_INIT(scm_set_smob_free((tag), (c_name));)
	283
	284	#define SCM_SMOB_PRINT(tag, c_name, obj, port, pstate) \
	285	SCM_SNARF_HERE(static int c_name(SCM obj, SCM port, scm_print_state* pstate)) \
	286	SCM_SNARF_INIT(scm_set_smob_print((tag), (c_name));)
	287
	288	#define SCM_GLOBAL_SMOB_PRINT(tag, c_name, obj, port, pstate) \
	289	SCM_SNARF_HERE(int c_name(SCM obj, SCM port, scm_print_state* pstate)) \
	290	SCM_SNARF_INIT(scm_set_smob_print((tag), (c_name));)
	291
	292	#define SCM_SMOB_EQUALP(tag, c_name, obj1, obj2) \
	293	SCM_SNARF_HERE(static SCM c_name(SCM obj1, SCM obj2)) \
	294	SCM_SNARF_INIT(scm_set_smob_equalp((tag), (c_name));)
	295
	296	#define SCM_GLOBAL_SMOB_EQUALP(tag, c_name, obj1, obj2) \
	297	SCM_SNARF_HERE(SCM c_name(SCM obj1, SCM obj2)) \
	298	SCM_SNARF_INIT(scm_set_smob_equalp((tag), (c_name));)
	299
	300	#define SCM_SMOB_APPLY(tag, c_name, req, opt, rest, arglist) \
	301	SCM_SNARF_HERE(static SCM c_name arglist) \
	302	SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
	303
	304	#define SCM_GLOBAL_SMOB_APPLY(tag, c_name, req, opt, rest, arglist) \
	305	SCM_SNARF_HERE(SCM c_name arglist) \
	306	SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
	307
c6054fea LC	308	\f
	309	/* Low-level snarfing for static memory allocation. */
	310
	311	#ifdef SCM_SUPPORT_STATIC_ALLOCATION
	312
fd12a19a AW	313	#define SCM_IMMUTABLE_CELL(c_name, car, cdr) \
	314	static SCM_ALIGNED (8) SCM_UNUSED const scm_t_cell \
	315	c_name ## _raw_scell = \
	316	{ \
	317	SCM_PACK (car), \
	318	SCM_PACK (cdr) \
	319	}; \
	320	static SCM_UNUSED const SCM c_name = SCM_PACK (& c_name ## _raw_scell)
	321
c6054fea LC	322	#define SCM_IMMUTABLE_DOUBLE_CELL(c_name, car, cbr, ccr, cdr) \
	323	static SCM_ALIGNED (8) SCM_UNUSED const scm_t_cell \
	324	c_name ## _raw_cell [2] = \
	325	{ \
	326	{ SCM_PACK (car), SCM_PACK (cbr) }, \
	327	{ SCM_PACK (ccr), SCM_PACK (cdr) } \
	328	}; \
	329	static SCM_UNUSED const SCM c_name = SCM_PACK (& c_name ## _raw_cell)
	330
fd12a19a AW	331	#define SCM_STATIC_DOUBLE_CELL(c_name, car, cbr, ccr, cdr) \
	332	static SCM_ALIGNED (8) SCM_UNUSED scm_t_cell \
	333	c_name ## _raw_cell [2] = \
	334	{ \
	335	{ SCM_PACK (car), SCM_PACK (cbr) }, \
	336	{ SCM_PACK (ccr), SCM_PACK (cdr) } \
	337	}; \
	338	static SCM_UNUSED SCM c_name = SCM_PACK (& c_name ## _raw_cell)
	339
5f236208 LC	340	#define SCM_IMMUTABLE_STRINGBUF(c_name, contents) \
	341	static SCM_UNUSED const \
	342	struct \
	343	{ \
	344	scm_t_bits word_0; \
	345	scm_t_bits word_1; \
	346	const char buffer[sizeof (contents)]; \
	347	} \
	348	c_name = \
	349	{ \
	350	scm_tc7_stringbuf \| SCM_I_STRINGBUF_F_SHARED, \
	351	sizeof (contents) - 1, \
	352	contents \
	353	}
c6054fea LC	354
c6054fea LC	355	#define SCM_IMMUTABLE_STRING(c_name, contents) \
b68095f0	356	SCM_IMMUTABLE_STRINGBUF (scm_i_paste (c_name, _stringbuf), contents); \
c6054fea LC	357	SCM_IMMUTABLE_DOUBLE_CELL (c_name, \
c6054fea LC	358	scm_tc7_ro_string, \
b68095f0	359	(scm_t_bits) &scm_i_paste (c_name, \
5f236208	360	_stringbuf), \
c6054fea	361	(scm_t_bits) 0, \
544a29de	362	(scm_t_bits) (sizeof (contents) - 1))
c6054fea	363
5b46a8c2 LC	364	#define SCM_IMMUTABLE_POINTER(c_name, ptr) \
5b46a8c2 LC	365	SCM_IMMUTABLE_CELL (c_name, scm_tc7_pointer, ptr)
fd12a19a AW	366
	367	/* for primitive-generics, add a foreign to the end */
	368	#define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \
	369	static SCM_ALIGNED (8) SCM c_name[4] = \
	370	{ \
	371	SCM_PACK (scm_tc7_vector \| (2 << 8)), \
	372	SCM_PACK (0), \
	373	foreign, \
	374	SCM_BOOL_F, /* the name */ \
ccb77157	375	}
fd12a19a AW	376
fd12a19a AW	377	#define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars) \
544a29de AW	378	static SCM_ALIGNED (8) SCM_UNUSED SCM \
	379	scm_i_paste (c_name, _raw_cell)[] = \
	380	{ \
	381	SCM_PACK (scm_tc7_program \| SCM_F_PROGRAM_IS_PRIMITIVE), \
	382	objcode, \
	383	objtable, \
	384	freevars \
	385	}; \
	386	static SCM_UNUSED const SCM c_name = \
	387	SCM_PACK (& scm_i_paste (c_name, _raw_cell))
46f9baf4	388
c6054fea LC	389	#endif /* SCM_SUPPORT_STATIC_ALLOCATION */
	390
	391	\f
	392	/* Documentation. */
94e38a65	393
c99f9605	394	#ifdef SCM_MAGIC_SNARF_DOCS
4b4d0898	395	#undef SCM_ASSERT
ac13d9d2	396	#define SCM_ASSERT(_cond, _arg, _pos, _subr) ^^ argpos _arg _pos __LINE__ ^^
c99f9605	397	#endif /* SCM_MAGIC_SNARF_DOCS */
2e07d033	398
b29058ff	399	#endif /* SCM_SNARF_H */
89e00824 ML	400
	401	/*
	402	Local Variables:
	403	c-file-style: "gnu"
	404	End:
	405	*/