X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/e42573315bd70d514b92458a7644057cd3ac5757..26b263541b56cf79f2c249950c5eadb87ce28b68:/libguile/snarf.h?ds=sidebyside diff --git a/libguile/snarf.h b/libguile/snarf.h index ef1fcd01d..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, 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 @@ -25,18 +26,11 @@ /* 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 @@ -59,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 @@ -99,22 +99,35 @@ 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_SNARF_HERE( \ static const char scm_i_paste (s_, FNAME) [] = PRIMNAME; \ SCM_API SCM FNAME ARGLIST; \ - SCM_IMMUTABLE_SUBR (scm_i_paste (FNAME, __subr), \ - scm_i_paste (FNAME, __name), \ - REQ, OPT, VAR, &FNAME); \ + 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, __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) @@ -152,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, \ @@ -194,27 +187,6 @@ 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) \ -) - - -#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) \ @@ -338,6 +310,15 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));) #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] = \ @@ -347,6 +328,15 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));) }; \ 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 \ @@ -369,19 +359,32 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));) (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)); + (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 */