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

remove asubrs

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2009-12-03 17:05:14 +01:00
parent bf5a05f2a0
commit 31d845b4bc
6 changed files with 16 additions and 228 deletions
Download patch file Download diff file Expand all files Collapse all files

226
libguile/array-map.c
View file

@ -44,39 +44,6 @@
#include "libguile/array-map.h" #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. */ /* The WHAT argument for `scm_gc_malloc ()' et al. */
static const char indices_gc_hint[] = "array-indices"; 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_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);
SCM_SYMBOL (sym_b, "b"); 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_PROC (2, proc);
SCM_VALIDATE_REST_ARGUMENT (lra); SCM_VALIDATE_REST_ARGUMENT (lra);
switch (SCM_TYP7 (proc)) scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
{ return SCM_UNSPECIFIED;
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;
}
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -1111,23 +928,27 @@ scm_raequal (SCM ra0, SCM ra1)
return scm_from_bool(raeql (ra0, SCM_BOOL_T, ra1)); return scm_from_bool(raeql (ra0, SCM_BOOL_T, ra1));
} }
#if 0 SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
/* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */ (SCM ra0, SCM ra1, SCM rest),
SCM_DEFINE1 (scm_array_equal_p, "array-equal?", scm_tc7_rpsubr,
(SCM ra0, SCM ra1),
"Return @code{#t} iff all arguments are arrays with the same\n" "Return @code{#t} iff all arguments are arrays with the same\n"
"shape, the same type, and have corresponding elements which are\n" "shape, the same type, and have corresponding elements which are\n"
"either @code{equal?} or @code{array-equal?}. This function\n" "either @code{equal?} or @code{array-equal?}. This function\n"
"differs from @code{equal?} in that a one dimensional shared\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" "array may be @var{array-equal?} but not @var{equal?} to a\n"
"vector or uniform vector.") "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 #undef FUNC_NAME
#endif
static char s_array_equal_p[] = "array-equal?";
SCM 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 void
scm_init_array_map (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; scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_raequal;
#include "libguile/array-map.x" #include "libguile/array-map.x"
scm_add_feature (s_scm_array_for_each); scm_add_feature (s_scm_array_for_each);

1
libguile/goops.c
View file

@ -225,7 +225,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
case scm_tc16_fraction: case scm_tc16_fraction:
return scm_class_fraction; return scm_class_fraction;
} }
case scm_tc7_asubr:
case scm_tc7_cxr: case scm_tc7_cxr:
case scm_tc7_rpsubr: case scm_tc7_rpsubr:
case scm_tc7_gsubr: case scm_tc7_gsubr:

1
libguile/procprop.c
View file

@ -56,7 +56,6 @@ scm_i_procedure_arity (SCM proc)
case scm_tc7_cxr: case scm_tc7_cxr:
a += 1; a += 1;
break; break;
case scm_tc7_asubr:
case scm_tc7_rpsubr: case scm_tc7_rpsubr:
r = 1; r = 1;
break; break;

1
libguile/procs.c
View file

@ -136,7 +136,6 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
case scm_tcs_closures: case scm_tcs_closures:
return scm_from_bool (SCM_CLOSURE_NUM_REQUIRED_ARGS (obj) == 0); return scm_from_bool (SCM_CLOSURE_NUM_REQUIRED_ARGS (obj) == 0);
case scm_tc7_rpsubr: case scm_tc7_rpsubr:
case scm_tc7_asubr:
return SCM_BOOL_T; return SCM_BOOL_T;
case scm_tc7_gsubr: case scm_tc7_gsubr:
return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0); return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0);

5
libguile/tags.h
View file

@ -434,7 +434,7 @@ typedef scm_t_uintptr scm_t_bits;
#define scm_tc7_cxr 93 #define scm_tc7_cxr 93
#define scm_tc7_unused_11 95 #define scm_tc7_unused_11 95
#define scm_tc7_unused_12 101 #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_13 109
#define scm_tc7_unused_14 111 #define scm_tc7_unused_14 111
#define scm_tc7_unused_15 117 #define scm_tc7_unused_15 117
@ -675,8 +675,7 @@ enum scm_tc8_tags
/* For subrs /* For subrs
*/ */
#define scm_tcs_subrs \ #define scm_tcs_subrs \
scm_tc7_asubr:\ scm_tc7_cxr:\
case scm_tc7_cxr:\
case scm_tc7_rpsubr:\ case scm_tc7_rpsubr:\
case scm_tc7_gsubr case scm_tc7_gsubr

10
libguile/vm.c
View file

@ -280,16 +280,6 @@ apply_foreign (SCM proc, SCM *args, int nargs, int headroom)
case scm_tc7_cxr: case scm_tc7_cxr:
if (nargs != 1) scm_wrong_num_args (proc); if (nargs != 1) scm_wrong_num_args (proc);
return scm_i_chase_pairs (args[0], (scm_t_bits) SCM_SUBRF (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: case scm_tc7_rpsubr:
{ {
int idx = 0; int idx = 0;