summaryrefslogtreecommitdiff
path: root/libguile/gsubr.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/gsubr.c')
-rw-r--r--libguile/gsubr.c52
1 files changed, 17 insertions, 35 deletions
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