From 31d845b4bc4bf50f32492c17dc43c9ccea779acb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 3 Dec 2009 17:05:14 +0100 Subject: [PATCH] remove asubrs * libguile/tags.h (scm_tcs_subrs, scm_tc7_asubr): Remove definitions. * libguile/goops.c (scm_class_of) * libguile/procprop.c (scm_i_procedure_arity) * libguile/procs.c (scm_thunk_p) * libguile/vm.c (apply_foreign): Remove cases for asubrs. * libguile/array-map.c: Gut all of the optimizations, because there are no more asubrs, soon won't be rpsubrs, and all of this should happen on the Scheme level, ideally. --- libguile/array-map.c | 226 +++---------------------------------------- libguile/goops.c | 1 - libguile/procprop.c | 1 - libguile/procs.c | 1 - libguile/tags.h | 5 +- libguile/vm.c | 10 -- 6 files changed, 16 insertions(+), 228 deletions(-) diff --git a/libguile/array-map.c b/libguile/array-map.c index 72009985c..75bc490d5 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -44,39 +44,6 @@ #include "libguile/array-map.h" -typedef struct -{ - char *name; - SCM sproc; - int (*vproc) (); -} ra_iproc; - - -/* These tables are a kluge that will not scale well when more - * vectorized subrs are added. It is tempting to steal some bits from - * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an - * offset into a table of vectorized subrs. - */ - -static ra_iproc ra_rpsubrs[] = -{ - {"=", SCM_UNDEFINED, scm_ra_eqp}, - {"<", SCM_UNDEFINED, scm_ra_lessp}, - {"<=", SCM_UNDEFINED, scm_ra_leqp}, - {">", SCM_UNDEFINED, scm_ra_grp}, - {">=", SCM_UNDEFINED, scm_ra_greqp}, - {0, 0, 0} -}; - -static ra_iproc ra_asubrs[] = -{ - {"+", SCM_UNDEFINED, scm_ra_sum}, - {"-", SCM_UNDEFINED, scm_ra_difference}, - {"*", SCM_UNDEFINED, scm_ra_product}, - {"/", SCM_UNDEFINED, scm_ra_divide}, - {0, 0, 0} -}; - /* The WHAT argument for `scm_gc_malloc ()' et al. */ static const char indices_gc_hint[] = "array-indices"; @@ -697,81 +664,6 @@ ramap (SCM ra0, SCM proc, SCM ras) } -static int -ramap_rp (SCM ra0, SCM proc, SCM ras) -{ - SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras)); - long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; - unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2); - long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; - long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; - long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc; - ra0 = SCM_I_ARRAY_V (ra0); - ra1 = SCM_I_ARRAY_V (ra1); - ra2 = SCM_I_ARRAY_V (ra2); - - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (scm_is_true (scm_c_bitvector_ref (ra0, i0))) - if (scm_is_false (SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2)))) - scm_c_bitvector_set_x (ra0, i0, SCM_BOOL_F); - - return 1; -} - - - -static int -ramap_2o (SCM ra0, SCM proc, SCM ras) -{ - SCM ra1 = SCM_CAR (ras); - long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; - unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1); - long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; - ra0 = SCM_I_ARRAY_V (ra0); - ra1 = SCM_I_ARRAY_V (ra1); - ras = SCM_CDR (ras); - if (scm_is_null (ras)) - { - for (; n-- > 0; i0 += inc0, i1 += inc1) - GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), SCM_UNDEFINED)); - } - else - { - SCM ra2 = SCM_CAR (ras); - unsigned long i2 = SCM_I_ARRAY_BASE (ra2); - long inc2 = SCM_I_ARRAY_DIMS (ra2)->inc; - ra2 = SCM_I_ARRAY_V (ra2); - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2))); - } - return 1; -} - - - -static int -ramap_a (SCM ra0, SCM proc, SCM ras) -{ - long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; - unsigned long i0 = SCM_I_ARRAY_BASE (ra0); - long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_I_ARRAY_V (ra0); - if (scm_is_null (ras)) - for (; n-- > 0; i0 += inc0) - GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), SCM_UNDEFINED)); - else - { - SCM ra1 = SCM_CAR (ras); - unsigned long i1 = SCM_I_ARRAY_BASE (ra1); - long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_I_ARRAY_V (ra1); - for (; n-- > 0; i0 += inc0, i1 += inc1) - GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), GVREF (ra1, i1))); - } - return 1; -} - - SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x); SCM_SYMBOL (sym_b, "b"); @@ -790,83 +682,8 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, SCM_VALIDATE_PROC (2, proc); SCM_VALIDATE_REST_ARGUMENT (lra); - switch (SCM_TYP7 (proc)) - { - default: - gencase: - scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME); - return SCM_UNSPECIFIED; - case scm_tc7_rpsubr: - { - ra_iproc *p; - if (!scm_is_typed_array (ra0, sym_b)) - goto gencase; - scm_array_fill_x (ra0, SCM_BOOL_T); - for (p = ra_rpsubrs; p->name; p++) - if (scm_is_eq (proc, p->sproc)) - { - while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra))) - { - scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME); - lra = SCM_CDR (lra); - } - return SCM_UNSPECIFIED; - } - while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra))) - { - scm_ramapc (ramap_rp, proc, ra0, lra, FUNC_NAME); - lra = SCM_CDR (lra); - } - return SCM_UNSPECIFIED; - } - case scm_tc7_asubr: - if (scm_is_null (lra)) - { - SCM fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED); - scm_array_fill_x (ra0, fill); - } - else - { - SCM tail, ra1 = SCM_CAR (lra); - SCM v0 = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_V (ra0) : ra0); - ra_iproc *p; - /* Check to see if order might matter. - This might be an argument for a separate - SERIAL-ARRAY-MAP! */ - if (scm_is_eq (v0, ra1) - || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V (ra1)))) - if (!scm_is_eq (ra0, ra1) - || (SCM_I_ARRAYP(ra0) && !SCM_I_ARRAY_CONTP(ra0))) - goto gencase; - for (tail = SCM_CDR (lra); !scm_is_null (tail); tail = SCM_CDR (tail)) - { - ra1 = SCM_CAR (tail); - if (scm_is_eq (v0, ra1) - || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V (ra1)))) - goto gencase; - } - for (p = ra_asubrs; p->name; p++) - if (scm_is_eq (proc, p->sproc)) - { - if (!scm_is_eq (ra0, SCM_CAR (lra))) - scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), FUNC_NAME); - lra = SCM_CDR (lra); - while (1) - { - scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME); - if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra))) - return SCM_UNSPECIFIED; - lra = SCM_CDR (lra); - } - } - scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME); - lra = SCM_CDR (lra); - if (SCM_NIMP (lra)) - for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra)) - scm_ramapc (ramap_a, proc, ra0, lra, FUNC_NAME); - } - return SCM_UNSPECIFIED; - } + scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME); + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1111,23 +928,27 @@ scm_raequal (SCM ra0, SCM ra1) return scm_from_bool(raeql (ra0, SCM_BOOL_T, ra1)); } -#if 0 -/* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */ -SCM_DEFINE1 (scm_array_equal_p, "array-equal?", scm_tc7_rpsubr, - (SCM ra0, SCM ra1), +SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1, + (SCM ra0, SCM ra1, SCM rest), "Return @code{#t} iff all arguments are arrays with the same\n" "shape, the same type, and have corresponding elements which are\n" "either @code{equal?} or @code{array-equal?}. This function\n" "differs from @code{equal?} in that a one dimensional shared\n" "array may be @var{array-equal?} but not @var{equal?} to a\n" "vector or uniform vector.") -#define FUNC_NAME s_scm_array_equal_p +#define FUNC_NAME s_scm_i_array_equal_p { + if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1)) + return SCM_BOOL_T; + + while (!scm_is_null (rest)) + { if (scm_is_false (scm_array_equal_p (ra0, scm_car (rest)))) + return SCM_BOOL_F; + rest = scm_cdr (rest); + } + return scm_array_equal_p (ra0, ra1); } #undef FUNC_NAME -#endif - -static char s_array_equal_p[] = "array-equal?"; SCM @@ -1139,28 +960,9 @@ scm_array_equal_p (SCM ra0, SCM ra1) } -static void -init_raprocs (ra_iproc *subra) -{ - for (; subra->name; subra++) - { - SCM sym = scm_from_locale_symbol (subra->name); - SCM var = - scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F); - if (var != SCM_BOOL_F) - subra->sproc = SCM_VARIABLE_REF (var); - else - subra->sproc = SCM_BOOL_F; - } -} - - void scm_init_array_map (void) { - init_raprocs (ra_rpsubrs); - init_raprocs (ra_asubrs); - scm_c_define_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p); scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_raequal; #include "libguile/array-map.x" scm_add_feature (s_scm_array_for_each); diff --git a/libguile/goops.c b/libguile/goops.c index 7ce5b3173..5c12f51a4 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -225,7 +225,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, case scm_tc16_fraction: return scm_class_fraction; } - case scm_tc7_asubr: case scm_tc7_cxr: case scm_tc7_rpsubr: case scm_tc7_gsubr: diff --git a/libguile/procprop.c b/libguile/procprop.c index a92d31c22..b74c6775d 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -56,7 +56,6 @@ scm_i_procedure_arity (SCM proc) case scm_tc7_cxr: a += 1; break; - case scm_tc7_asubr: case scm_tc7_rpsubr: r = 1; break; diff --git a/libguile/procs.c b/libguile/procs.c index 6fda200d0..36ee34d48 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -136,7 +136,6 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0, case scm_tcs_closures: return scm_from_bool (SCM_CLOSURE_NUM_REQUIRED_ARGS (obj) == 0); case scm_tc7_rpsubr: - case scm_tc7_asubr: return SCM_BOOL_T; case scm_tc7_gsubr: return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0); diff --git a/libguile/tags.h b/libguile/tags.h index 2a9fc4b2f..a64156d64 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -434,7 +434,7 @@ typedef scm_t_uintptr scm_t_bits; #define scm_tc7_cxr 93 #define scm_tc7_unused_11 95 #define scm_tc7_unused_12 101 -#define scm_tc7_asubr 103 +#define scm_tc7_unused_18 103 #define scm_tc7_unused_13 109 #define scm_tc7_unused_14 111 #define scm_tc7_unused_15 117 @@ -675,8 +675,7 @@ enum scm_tc8_tags /* For subrs */ #define scm_tcs_subrs \ - scm_tc7_asubr:\ - case scm_tc7_cxr:\ + scm_tc7_cxr:\ case scm_tc7_rpsubr:\ case scm_tc7_gsubr diff --git a/libguile/vm.c b/libguile/vm.c index fdfae0082..689359e18 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -280,16 +280,6 @@ apply_foreign (SCM proc, SCM *args, int nargs, int headroom) case scm_tc7_cxr: if (nargs != 1) scm_wrong_num_args (proc); return scm_i_chase_pairs (args[0], (scm_t_bits) SCM_SUBRF (proc)); - case scm_tc7_asubr: - if (nargs < 2) - return SCM_SUBRF (proc) (args[0], SCM_UNDEFINED); - { - SCM x = args[0]; - int idx = 1; - while (nargs-- > 1) - x = SCM_SUBRF (proc) (x, args[idx++]); - return x; - } case scm_tc7_rpsubr: { int idx = 0;