diff options
author | Andy Wingo <wingo@pobox.com> | 2010-01-05 16:15:14 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-01-05 16:15:14 +0100 |
commit | 9fdf9fd3ea7130fd85eaf0a333a965ac4d2b07c3 (patch) | |
tree | 31ac376b1ce4cfb2757e222d39794577378f8c2f /libguile | |
parent | e809758a7e0f3f63162a0a9064b95bd1c1d10628 (diff) | |
download | guile-9fdf9fd3ea7130fd85eaf0a333a965ac4d2b07c3.tar.gz |
move subr implementation details to gsubr.[ch]
* libguile/procs.h: Move subr macros to gsubr.h.
* libguile/procs.c (scm_c_make_subr, scm_c_make_subr_with_generic)
(scm_c_define_subr, scm_c_define_subr_with_generic): Remove these,
because they deal in subr types, and now there is only one subr type.
The body of this code is now in gsubr.c.
* libguile/deprecated.h (scm_subr_p): Remove from procs.[ch] and define
as a deprecated macro. Only used internally, but who knows who's out
there.
* libguile/goops.c (scm_generic_capability_p)
(scm_enable_primitive_generic_x, scm_set_primitive_generic_x)
(scm_primitive_generic_generic): Use the new SCM_PRIMITIVE_GENERIC_P
macro instead of calling scm_subr_p.
* libguile/gsubr.h (SCM_PRIMITIVE_P, SCM_PRIMITIVE_GENERIC_P): New
macros, to replace scm_subr_p and hacky checking for generic
capability.
(SCM_SUBR_META_INFO, SCM_SUBR_NAME, SCM_SUBRF, SCM_SUBR_PROPS)
(SCM_SUBR_GENERIC, SCM_SET_SUBR_GENERIC, SCM_SET_SUBR_GENERIC_LOC)
(SCM_SUBR_ARITY_TO_TYPE): Moved here from procs.h.
* libguile/gsubr.c (create_gsubr): Inline the
scm_c_make_subr definition here, and work for generics too. Removed a
scm_remember_upto_here_1 that was added earlier in the year when
meta_info was not being traced by the GC. Adapt callers.
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/deprecated.h | 5 | ||||
-rw-r--r-- | libguile/goops.c | 13 | ||||
-rw-r--r-- | libguile/gsubr.c | 52 | ||||
-rw-r--r-- | libguile/gsubr.h | 26 | ||||
-rw-r--r-- | libguile/procs.c | 62 | ||||
-rw-r--r-- | libguile/procs.h | 28 |
6 files changed, 53 insertions, 133 deletions
diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 671f40f83..5b7c9a2ac 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -598,6 +598,11 @@ SCM_DEPRECATED scm_t_trampoline_2 scm_trampoline_2 (SCM proc); +/* Deprecated 2010-01-05, use SCM_PRIMITIVE_P instead */ +#define scm_subr_p(x) (SCM_PRIMITIVE_P (x)) + + + void scm_i_init_deprecated (void); #endif diff --git a/libguile/goops.c b/libguile/goops.c index 983fa5924..a703e7a7e 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -39,6 +39,7 @@ #include "libguile/dynl.h" #include "libguile/dynwind.h" #include "libguile/eval.h" +#include "libguile/gsubr.h" #include "libguile/hashtab.h" #include "libguile/keywords.h" #include "libguile/macros.h" @@ -1693,9 +1694,7 @@ SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0, { SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, SCM_ARG1, FUNC_NAME); - return (scm_subr_p (proc) && SCM_SUBR_GENERIC (proc) - ? SCM_BOOL_T - : SCM_BOOL_F); + return (SCM_PRIMITIVE_GENERIC_P (proc) ? SCM_BOOL_T : SCM_BOOL_F); } #undef FUNC_NAME @@ -1708,8 +1707,7 @@ SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1 while (!scm_is_null (subrs)) { SCM subr = SCM_CAR (subrs); - SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr), - subr, SCM_ARGn, FUNC_NAME); + SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARGn, FUNC_NAME); *SCM_SUBR_GENERIC (subr) = scm_make (scm_list_3 (scm_class_generic, k_name, @@ -1725,8 +1723,7 @@ SCM_DEFINE (scm_set_primitive_generic_x, "set-primitive-generic!", 2, 0, 0, "") #define FUNC_NAME s_scm_set_primitive_generic_x { - SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr), - subr, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARG1, FUNC_NAME); SCM_ASSERT (SCM_PUREGENERICP (generic), generic, SCM_ARG2, FUNC_NAME); *SCM_SUBR_GENERIC (subr) = generic; return SCM_UNSPECIFIED; @@ -1738,7 +1735,7 @@ SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0, "") #define FUNC_NAME s_scm_primitive_generic_generic { - if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr)) + if (SCM_PRIMITIVE_GENERIC_P (subr)) { if (!*SCM_SUBR_GENERIC (subr)) scm_enable_primitive_generic_x (scm_list_1 (subr)); diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 24ba6700c..70be51b91 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -48,9 +48,11 @@ SCM_GLOBAL_SYMBOL (scm_sym_name, "name"); static SCM create_gsubr (int define, const char *name, unsigned int req, unsigned int opt, unsigned int rst, - SCM (*fcn) ()) + SCM (*fcn) (), SCM *generic_loc) { SCM subr; + SCM sname; + SCM *meta_info; unsigned type; type = SCM_GSUBR_MAKTYPE (req, opt, rst); @@ -59,11 +61,18 @@ create_gsubr (int define, const char *name, || SCM_GSUBR_REST (type) != rst) scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst)); - subr = scm_c_make_subr (name, scm_tc7_gsubr | (type << 8U), - fcn); + meta_info = scm_gc_malloc (2 * sizeof (*meta_info), "subr meta-info"); + sname = scm_from_locale_symbol (name); + meta_info[0] = sname; + meta_info[1] = SCM_EOL; /* properties */ + + subr = scm_double_cell ((scm_t_bits) scm_tc7_gsubr | (type << 8U), + (scm_t_bits) fcn, + (scm_t_bits) generic_loc, + (scm_t_bits) meta_info); if (define) - scm_define (SCM_SUBR_NAME (subr), subr); + scm_define (sname, subr); return subr; } @@ -71,40 +80,13 @@ create_gsubr (int define, const char *name, SCM scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)()) { - return create_gsubr (0, name, req, opt, rst, fcn); + return create_gsubr (0, name, req, opt, rst, fcn, NULL); } SCM scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)()) { - return create_gsubr (1, name, req, opt, rst, fcn); -} - -static SCM -create_gsubr_with_generic (int define, - const char *name, - int req, - int opt, - int rst, - SCM (*fcn)(), - SCM *gf) -{ - SCM subr; - unsigned type; - - type = SCM_GSUBR_MAKTYPE (req, opt, rst); - if (SCM_GSUBR_REQ (type) != req - || SCM_GSUBR_OPT (type) != opt - || SCM_GSUBR_REST (type) != rst) - scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst)); - - subr = scm_c_make_subr_with_generic (name, scm_tc7_gsubr | (type << 8U), - fcn, gf); - - if (define) - scm_define (SCM_SUBR_NAME (subr), subr); - - return subr; + return create_gsubr (1, name, req, opt, rst, fcn, NULL); } SCM @@ -115,7 +97,7 @@ scm_c_make_gsubr_with_generic (const char *name, SCM (*fcn)(), SCM *gf) { - return create_gsubr_with_generic (0, name, req, opt, rst, fcn, gf); + return create_gsubr (0, name, req, opt, rst, fcn, gf); } SCM @@ -126,7 +108,7 @@ scm_c_define_gsubr_with_generic (const char *name, SCM (*fcn)(), SCM *gf) { - return create_gsubr_with_generic (1, name, req, opt, rst, fcn, gf); + return create_gsubr (1, name, req, opt, rst, fcn, gf); } /* Apply PROC, a gsubr, to the ARGC arguments in ARGV. ARGC is expected to diff --git a/libguile/gsubr.h b/libguile/gsubr.h index e75658d1c..74a08a242 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -25,6 +25,32 @@ #include "libguile/__scm.h" + + + +/* Subrs + */ + +#define SCM_PRIMITIVE_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_gsubr) +#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PRIMITIVE_P (x) && SCM_SUBR_GENERIC (x)) + +#define SCM_SUBR_META_INFO(x) ((SCM *) SCM_CELL_WORD_3 (x)) +#define SCM_SUBR_NAME(x) (SCM_SUBR_META_INFO (x) [0]) +#define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x)) +#define SCM_SUBR_PROPS(x) (SCM_SUBR_META_INFO (x) [1]) +#define SCM_SUBR_GENERIC(x) ((SCM *) SCM_CELL_WORD_2 (x)) +#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) \ + (scm_tc7_gsubr | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U)) + + + + /* Return an integer describing the arity of GSUBR, a subr of type diff --git a/libguile/procs.c b/libguile/procs.c index 6c0391123..e94037828 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -41,53 +41,6 @@ */ -SCM -scm_c_make_subr (const char *name, long type, SCM (*fcn) ()) -{ - register SCM z; - SCM sname; - SCM *meta_info; - - meta_info = scm_gc_malloc (2 * sizeof (*meta_info), "subr meta-info"); - sname = scm_from_locale_symbol (name); - meta_info[0] = sname; - meta_info[1] = SCM_EOL; /* properties */ - - z = scm_double_cell ((scm_t_bits) type, (scm_t_bits) fcn, - 0 /* generic */, (scm_t_bits) meta_info); - - scm_remember_upto_here_1 (sname); - - return z; -} - -SCM -scm_c_define_subr (const char *name, long type, SCM (*fcn) ()) -{ - SCM subr = scm_c_make_subr (name, type, fcn); - scm_define (SCM_SUBR_NAME (subr), subr); - return subr; -} - -SCM -scm_c_make_subr_with_generic (const char *name, - long type, SCM (*fcn) (), SCM *gf) -{ - SCM subr = scm_c_make_subr (name, type, fcn); - SCM_SET_SUBR_GENERIC_LOC (subr, gf); - return subr; -} - -SCM -scm_c_define_subr_with_generic (const char *name, - long type, SCM (*fcn) (), SCM *gf) -{ - SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf); - scm_define (SCM_SUBR_NAME (subr), subr); - return subr; -} - - SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, (SCM obj), "Return @code{#t} if @var{obj} is a procedure.") @@ -123,21 +76,6 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0, } #undef FUNC_NAME -/* Only used internally. */ -int -scm_subr_p (SCM obj) -{ - if (SCM_NIMP (obj)) - switch (SCM_TYP7 (obj)) - { - case scm_tc7_gsubr: - return 1; - default: - ; - } - return 0; -} - SCM_SYMBOL (sym_documentation, "documentation"); SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, diff --git a/libguile/procs.h b/libguile/procs.h index a832cd06f..a4dfaff3c 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -27,36 +27,8 @@ - -/* Subrs - */ - -#define SCM_SUBR_META_INFO(x) ((SCM *) SCM_CELL_WORD_3 (x)) -#define SCM_SUBR_NAME(x) (SCM_SUBR_META_INFO (x) [0]) -#define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x)) -#define SCM_SUBR_PROPS(x) (SCM_SUBR_META_INFO (x) [1]) -#define SCM_SUBR_GENERIC(x) ((SCM *) SCM_CELL_WORD_2 (x)) -#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) \ - (scm_tc7_gsubr | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U)) - - - - -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); -SCM_API SCM scm_c_define_subr (const char *name, long type, SCM (*fcn)()); -SCM_API SCM scm_c_define_subr_with_generic (const char *name, long type, - SCM (*fcn)(), SCM *gf); SCM_API SCM scm_procedure_p (SCM obj); SCM_API SCM scm_thunk_p (SCM obj); -SCM_API int scm_subr_p (SCM obj); SCM_API SCM scm_procedure_documentation (SCM proc); SCM_API SCM scm_procedure_with_setter_p (SCM obj); SCM_API SCM scm_make_procedure_with_setter (SCM procedure, SCM setter); |