summaryrefslogtreecommitdiff
path: root/libguile/array-map.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-12-03 17:05:14 +0100
committerAndy Wingo <wingo@pobox.com>2009-12-03 17:05:14 +0100
commit31d845b4bc4bf50f32492c17dc43c9ccea779acb (patch)
tree1c7ce1e4bba02e5dfb1934313eb36fbd8c422ca6 /libguile/array-map.c
parentbf5a05f2a01fee23f5622d1429dc32f4850f98b5 (diff)
downloadguile-31d845b4bc4bf50f32492c17dc43c9ccea779acb.tar.gz
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.
Diffstat (limited to 'libguile/array-map.c')
-rw-r--r--libguile/array-map.c228
1 files changed, 15 insertions, 213 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);