diff options
author | Ludovic Courtès <ludo@gnu.org> | 2009-02-16 00:24:00 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2009-03-02 00:20:43 +0100 |
commit | e20d7001c3f7150400169fecb0bf0eefdf122fe2 (patch) | |
tree | c87cda61cb2fd5574aa8aceccd199d48736437c0 /libguile/gsubr.c | |
parent | b786a5bbf825f61e04ccd9a54f93cb1e40ac67d9 (diff) | |
download | guile-e20d7001c3f7150400169fecb0bf0eefdf122fe2.tar.gz |
Remove "compiled closures" ("cclos") in favor of a simpler mechanism.
The idea is to introduce `gsubrs' whose arity is encoded in their type
(more precisely in the sizeof (void *) - 8 MSBs). This removes the
indirection introduced by cclos and simplifies the code.
* libguile/__scm.h (CCLO): Remove.
* libguile/debug.c (scm_procedure_source, scm_procedure_environment):
Remove references to `scm_tc7_cclo'.
* libguile/eval.c (scm_trampoline_0, scm_trampoline_1,
scm_trampoline_2): Replace `scm_tc7_cclo' with `scm_tc7_gsubr'.
* libguile/eval.i.c (CEVAL): Likewise. No longer make PROC the first
argument. Directly invoke `scm_gsubr_apply ()' instead of jump to the
`evap(N+1)' label or call to `SCM_APPLY ()'.
* libguile/evalext.c (scm_self_evaluating_p): Remove reference to
`scm_tc7_cclo'.
* libguile/gc-card.c (scm_i_sweep_card, scm_i_tag_name): Likewise.
* libguile/gc-mark.c (scm_gc_mark_dependencies): Likewise.
* libguile/goops.c (scm_class_of): Likewise.
* libguile/print.c (iprin1): Likewise.
* libguile/gsubr.c (create_gsubr): Use `unsigned int's for REQ, OPT and
RST. Use `scm_tc7_gsubr' instead of `scm_makcclo ()' in the default
case.
(scm_gsubr_apply): Remove calls to `SCM_GSUBR_PROC ()'.
(scm_f_gsubr_apply): Remove.
* libguile/gsubr.h (SCM_GSUBR_TYPE): New definition.
(SCM_GSUBR_MAX): Changed to 33.
(SCM_SET_GSUBR_TYPE, SCM_GSUBR_PROC, SCM_SET_GSUBR_PROC,
scm_f_gsubr_apply): Remove.
* libguile/procprop.c (scm_i_procedure_arity): Remove reference to
`scm_tc7_cclo'; add proper handling of `scm_tc7_gsubr'.
* libguile/procs.c (scm_makcclo, scm_make_cclo): Remove.
(scm_procedure_p): Remove reference to `scm_tc7_cclo'.
(scm_thunk_p): Likewise, plus add proper `scm_tc7_gsubr' handling.
* libguile/procs.h (SCM_CCLO_LENGTH, SCM_MAKE_CCLO_TAG,
SCM_SET_CCLO_LENGTH, SCM_CCLO_BASE, SCM_SET_CCLO_BASE, SCM_CCLO_REF,
SCM_CCLO_SET, SCM_CCLO_SUBR, SCM_SET_CCLO_SUBR, scm_makcclo,
scm_make_cclo): Remove.
* libguile/stacks.c (read_frames): Remove reference to `scm_f_gsubr_apply'.
* libguile/tags.h (scm_tc7_cclo): Remove.
(scm_tc7_gsubr): New.
(scm_tcs_subrs): Add `scm_tc7_gsubr'.
Diffstat (limited to 'libguile/gsubr.c')
-rw-r--r-- | libguile/gsubr.c | 78 |
1 files changed, 34 insertions, 44 deletions
diff --git a/libguile/gsubr.c b/libguile/gsubr.c index fdb70ed92..91852d5b8 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -40,11 +40,10 @@ SCM_GLOBAL_SYMBOL (scm_sym_name, "name"); -SCM scm_f_gsubr_apply; - static SCM create_gsubr (int define, const char *name, - int req, int opt, int rst, SCM (*fcn)()) + unsigned int req, unsigned int opt, unsigned int rst, + SCM (*fcn) ()) { SCM subr; @@ -52,53 +51,47 @@ create_gsubr (int define, const char *name, { case SCM_GSUBR_MAKTYPE(0, 0, 0): subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn); - goto create_subr; + break; case SCM_GSUBR_MAKTYPE(1, 0, 0): subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn); - goto create_subr; + break; case SCM_GSUBR_MAKTYPE(0, 1, 0): subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn); - goto create_subr; + break; case SCM_GSUBR_MAKTYPE(1, 1, 0): subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn); - goto create_subr; + break; case SCM_GSUBR_MAKTYPE(2, 0, 0): subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn); - goto create_subr; + break; case SCM_GSUBR_MAKTYPE(3, 0, 0): subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn); - goto create_subr; + break; case SCM_GSUBR_MAKTYPE(0, 0, 1): subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn); - goto create_subr; + break; case SCM_GSUBR_MAKTYPE(2, 0, 1): subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn); - create_subr: - if (define) - scm_define (SCM_SNAME (subr), subr); - return subr; + break; default: { - SCM cclo = scm_makcclo (scm_f_gsubr_apply, 3L); - SCM subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn); - SCM sym = SCM_SNAME (subr); - if (SCM_GSUBR_MAX < req + opt + rst) - { - fprintf (stderr, - "ERROR in scm_c_make_gsubr: too many args (%d) to %s\n", - req + opt + rst, name); - exit (1); - } - SCM_SET_GSUBR_PROC (cclo, subr); - SCM_SET_GSUBR_TYPE (cclo, - scm_from_int (SCM_GSUBR_MAKTYPE (req, opt, rst))); - if (SCM_REC_PROCNAMES_P) - scm_set_procedure_property_x (cclo, scm_sym_name, sym); - if (define) - scm_define (sym, cclo); - return cclo; + 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 (name, scm_tc7_gsubr | (type << 8U), + fcn); } } + + if (define) + scm_define (SCM_SNAME (subr), subr); + + return subr; } SCM @@ -190,20 +183,15 @@ scm_gsubr_apply (SCM args) #define FUNC_NAME "scm_gsubr_apply" { SCM self = SCM_CAR (args); - SCM (*fcn)() = SCM_SUBRF (SCM_GSUBR_PROC (self)); + SCM (*fcn)() = SCM_SUBRF (self); SCM v[SCM_GSUBR_MAX]; - int typ = scm_to_int (SCM_GSUBR_TYPE (self)); + unsigned int typ = SCM_GSUBR_TYPE (self); long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ); -#if 0 - if (n > SCM_GSUBR_MAX) - scm_misc_error (FUNC_NAME, - "Function ~S has illegal arity ~S.", - scm_list_2 (self, scm_from_int (n))); -#endif + args = SCM_CDR (args); for (i = 0; i < SCM_GSUBR_REQ (typ); i++) { if (scm_is_null (args)) - scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self))); + scm_wrong_num_args (SCM_SNAME (self)); v[i] = SCM_CAR(args); args = SCM_CDR(args); } @@ -218,7 +206,7 @@ scm_gsubr_apply (SCM args) if (SCM_GSUBR_REST(typ)) v[i] = args; else if (!scm_is_null (args)) - scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self))); + scm_wrong_num_args (SCM_SNAME (self)); switch (n) { case 2: return (*fcn)(v[0], v[1]); case 3: return (*fcn)(v[0], v[1], v[2]); @@ -229,6 +217,10 @@ scm_gsubr_apply (SCM args) case 8: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7]); case 9: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8]); case 10: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8], v[9]); + default: + scm_misc_error ((char *) SCM_SNAME (self), + "gsubr invocation with more than 10 arguments not implemented", + SCM_EOL); } return SCM_BOOL_F; /* Never reached. */ } @@ -259,8 +251,6 @@ gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst) void scm_init_gsubr() { - scm_f_gsubr_apply = scm_c_make_subr ("gsubr-apply", scm_tc7_lsubr, - scm_gsubr_apply); #ifdef GSUBR_TEST scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */ #endif |