mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

all subrs are gsubrs

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2009-09-03 11:14:24 +02:00
parent aa3f69519f
commit df9ca8d8b2
6 changed files with 27 additions and 82 deletions
Download patch file Download diff file Expand all files Collapse all files

97
libguile/gsubr.c
View file

@ -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