From df9ca8d8b2f48e7042298a9a788b749b46fc5efc Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 3 Sep 2009 11:14:24 +0200 Subject: [PATCH] all subrs are gsubrs * libguile/gsubr.c (create_gsubr, create_gsubr_with_generic): Always create gsubrs -- never the specialized tc7 types. Allow gsubrs to have generics, there doesn't seem to be any reason not to. * libguile/macros.c (scm_make_synt): * libguile/values.c (scm_init_values): * libguile/eval.c (scm_init_eval): * libguile/gc.c (scm_init_gc): Use scm_c_define_gsubr instead of scm_c_define_subr. * libguile/goops.c (scm_class_of): Allow gsubrs to be primitive generics. --- libguile/eval.c | 2 +- libguile/gc.c | 3 +- libguile/goops.c | 2 +- libguile/gsubr.c | 97 +++++++++++------------------------------------ libguile/macros.c | 2 +- libguile/values.c | 3 +- 6 files changed, 27 insertions(+), 82 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index d5405950e..8a4700843 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -941,7 +941,7 @@ scm_init_eval () scm_listofnull = scm_list_1 (SCM_EOL); - f_apply = scm_c_define_subr ("apply", scm_tc7_lsubr_2, scm_apply); + f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply); scm_permanent_object (f_apply); primitive_eval = scm_c_make_gsubr ("primitive-eval", 1, 0, 0, diff --git a/libguile/gc.c b/libguile/gc.c index 96e3c306f..a0715f084 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -820,8 +820,7 @@ scm_init_gc () scm_after_gc_hook = scm_permanent_object (scm_make_hook (SCM_INUM0)); scm_c_define ("after-gc-hook", scm_after_gc_hook); - gc_async = scm_c_make_subr ("%gc-thunk", scm_tc7_subr_0, - gc_async_thunk); + gc_async = scm_c_make_gsubr ("%gc-thunk", 0, 0, 0, gc_async_thunk); scm_c_hook_add (&scm_after_gc_c_hook, mark_gc_async, NULL, 0); diff --git a/libguile/goops.c b/libguile/goops.c index dcb1b7d12..dfa7117d0 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -237,11 +237,11 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, case scm_tc7_subr_2o: case scm_tc7_lsubr_2: case scm_tc7_lsubr: + case scm_tc7_gsubr: if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x)) return scm_class_primitive_generic; else return scm_class_procedure; - case scm_tc7_gsubr: case scm_tc7_program: return scm_class_procedure; case scm_tc7_pws: diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 6123a0b1f..06e8830c8 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -51,47 +51,16 @@ create_gsubr (int define, const char *name, SCM (*fcn) ()) { SCM subr; + unsigned type; - switch (SCM_GSUBR_MAKTYPE (req, opt, rst)) - { - case SCM_GSUBR_MAKTYPE(0, 0, 0): - subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn); - break; - case SCM_GSUBR_MAKTYPE(1, 0, 0): - subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn); - break; - case SCM_GSUBR_MAKTYPE(0, 1, 0): - subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn); - break; - case SCM_GSUBR_MAKTYPE(1, 1, 0): - subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn); - break; - case SCM_GSUBR_MAKTYPE(2, 0, 0): - subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn); - break; - case SCM_GSUBR_MAKTYPE(3, 0, 0): - subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn); - break; - case SCM_GSUBR_MAKTYPE(0, 0, 1): - subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn); - break; - case SCM_GSUBR_MAKTYPE(2, 0, 1): - subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn); - break; - default: - { - 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)); - 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 (name, scm_tc7_gsubr | (type << 8U), - fcn); - } - } + subr = scm_c_make_subr (name, scm_tc7_gsubr | (type << 8U), + fcn); if (define) scm_define (SCM_SUBR_NAME (subr), subr); @@ -121,43 +90,21 @@ create_gsubr_with_generic (int define, SCM *gf) { SCM subr; + unsigned type; - switch (SCM_GSUBR_MAKTYPE(req, opt, rst)) - { - case SCM_GSUBR_MAKTYPE(0, 0, 0): - subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_0, fcn, gf); - goto create_subr; - case SCM_GSUBR_MAKTYPE(1, 0, 0): - subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1, fcn, gf); - goto create_subr; - case SCM_GSUBR_MAKTYPE(0, 1, 0): - subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1o, fcn, gf); - goto create_subr; - case SCM_GSUBR_MAKTYPE(1, 1, 0): - subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2o, fcn, gf); - goto create_subr; - case SCM_GSUBR_MAKTYPE(2, 0, 0): - subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2, fcn, gf); - goto create_subr; - case SCM_GSUBR_MAKTYPE(3, 0, 0): - subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_3, fcn, gf); - goto create_subr; - case SCM_GSUBR_MAKTYPE(0, 0, 1): - subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr, fcn, gf); - goto create_subr; - case SCM_GSUBR_MAKTYPE(2, 0, 1): - subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr_2, fcn, gf); - create_subr: - if (define) - scm_define (SCM_SUBR_NAME (subr), subr); - return subr; - default: - ; - } - scm_misc_error ("scm_c_make_gsubr_with_generic", - "can't make primitive-generic with this arity", - SCM_EOL); - return SCM_BOOL_F; /* never reached */ + 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; } SCM diff --git a/libguile/macros.c b/libguile/macros.c index 970a41d54..d7c054e72 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -312,7 +312,7 @@ SCM scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() ) { SCM var = scm_c_define (name, SCM_UNDEFINED); - SCM transformer = scm_c_make_subr (name, scm_tc7_subr_2, fcn); + SCM transformer = scm_c_make_gsubr (name, 2, 0, 0, fcn); SCM_VARIABLE_SET (var, macroizer (transformer)); return SCM_UNSPECIFIED; } diff --git a/libguile/values.c b/libguile/values.c index 71cdbe2af..967fcd6bc 100644 --- a/libguile/values.c +++ b/libguile/values.c @@ -77,8 +77,7 @@ SCM_DEFINE (scm_values, "values", 0, 0, 1, void scm_init_values (void) { - SCM print = scm_c_define_subr ("%print-values", scm_tc7_subr_2, - print_values); + SCM print = scm_c_define_gsubr ("%print-values", 2, 0, 0, print_values); scm_values_vtable = scm_make_vtable (scm_from_locale_string ("pr"), print);