diff --git a/libguile/ramap.c b/libguile/ramap.c index 8f24cb48f..2040f25de 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -170,76 +170,55 @@ scm_ra_matchp (SCM ra0, SCM ras) scm_t_array_dim *s1; unsigned long bas0 = 0; int i, ndim = 1; - int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */ - if (SCM_IMP (ra0)) return 0; - if (scm_is_uniform_vector (ra0)) - goto uniform_vector_0; - switch (SCM_TYP7 (ra0)) + int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */ + + if (scm_is_generalized_vector (ra0)) { - default: - return 0; - case scm_tc7_vector: - case scm_tc7_wvect: - case scm_tc7_string: - case scm_tc7_bvect: - uniform_vector_0: s0->lbnd = 0; s0->inc = 1; - s0->ubnd = scm_to_long (scm_uniform_vector_length (ra0)) - 1; - break; - case scm_tc7_smob: - if (!SCM_ARRAYP (ra0)) - return 0; + s0->ubnd = scm_c_generalized_vector_length (ra0) - 1; + } + else if (SCM_ARRAYP (ra0)) + { ndim = SCM_ARRAY_NDIM (ra0); s0 = SCM_ARRAY_DIMS (ra0); bas0 = SCM_ARRAY_BASE (ra0); - break; } + else + return 0; + while (SCM_NIMP (ras)) { ra1 = SCM_CAR (ras); - if (SCM_IMP (ra1)) - return 0; - if (scm_is_uniform_vector (ra1)) - goto uniform_vector_1; - switch (SCM_TYP7 (ra1)) + + if (scm_is_generalized_vector (ra1)) { - default: - return 0; - case scm_tc7_vector: - case scm_tc7_wvect: - case scm_tc7_string: - case scm_tc7_bvect: - uniform_vector_1: - { - unsigned long int length; - - if (1 != ndim) - return 0; - - length = scm_to_ulong (scm_uniform_vector_length (ra1)); - - switch (exact) - { - case 4: - if (0 != bas0) - exact = 3; - case 3: - if (1 != s0->inc) - exact = 2; - case 2: - if ((0 == s0->lbnd) && (s0->ubnd == length - 1)) - break; - exact = 1; - case 1: - if (s0->lbnd < 0 || s0->ubnd >= length) - return 0; - } - break; - } - case scm_tc7_smob: - if (!SCM_ARRAYP (ra1) || ndim != SCM_ARRAY_NDIM (ra1)) + size_t length; + + if (1 != ndim) return 0; + + length = scm_c_generalized_vector_length (ra1); + + switch (exact) + { + case 4: + if (0 != bas0) + exact = 3; + case 3: + if (1 != s0->inc) + exact = 2; + case 2: + if ((0 == s0->lbnd) && (s0->ubnd == length - 1)) + break; + exact = 1; + case 1: + if (s0->lbnd < 0 || s0->ubnd >= length) + return 0; + } + } + else if (SCM_ARRAYP (ra1) && ndim == SCM_ARRAY_NDIM (ra1)) + { s1 = SCM_ARRAY_DIMS (ra1); if (bas0 != SCM_ARRAY_BASE (ra1)) exact = 3; @@ -258,10 +237,13 @@ scm_ra_matchp (SCM ra0, SCM ras) if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd) return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1); } - break; } + else + return 0; + ras = SCM_CDR (ras); } + return exact; } @@ -296,7 +278,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) if (SCM_IMP (vra0)) goto gencase; if (!SCM_ARRAYP (vra0)) { - unsigned long int length = scm_to_ulong (scm_uniform_vector_length (vra0)); + size_t length = scm_c_generalized_vector_length (vra0); vra1 = scm_make_ra (1); SCM_ARRAY_BASE (vra1) = 0; SCM_ARRAY_DIMS (vra1)->lbnd = 0; @@ -442,73 +424,15 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED) ra = SCM_ARRAY_V (ra); - if (scm_is_uniform_vector (ra)) + if (scm_is_generalized_vector (ra)) { for (i = base; n--; i += inc) - scm_uniform_vector_set_x (ra, scm_from_ulong (i), fill); - return 1; + scm_c_generalized_vector_set_x (ra, i, fill); } - - switch SCM_TYP7 (ra) + else { - default: for (i = base; n--; i += inc) scm_array_set_x (ra, fill, scm_from_ulong (i)); - break; - case scm_tc7_vector: - case scm_tc7_wvect: - for (i = base; n--; i += inc) - SCM_VECTOR_SET (ra, i, fill); - break; - case scm_tc7_string: - SCM_ASRTGO (SCM_CHARP (fill), badarg2); - { - char *data = scm_i_string_writable_chars (ra); - for (i = base; n--; i += inc) - data[i] = SCM_CHAR (fill); - scm_i_string_stop_writing (); - } - break; - case scm_tc7_bvect: - { /* scope */ - long *ve = (long *) SCM_VELTS (ra); - if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_BITVECTOR_LENGTH (ra))) - { - i = base / SCM_LONG_BIT; - if (scm_is_false (fill)) - { - if (base % SCM_LONG_BIT) /* leading partial word */ - ve[i++] &= ~(~0L << (base % SCM_LONG_BIT)); - for (; i < (base + n) / SCM_LONG_BIT; i++) - ve[i] = 0L; - if ((base + n) % SCM_LONG_BIT) /* trailing partial word */ - ve[i] &= (~0L << ((base + n) % SCM_LONG_BIT)); - } - else if (scm_is_eq (fill, SCM_BOOL_T)) - { - if (base % SCM_LONG_BIT) - ve[i++] |= ~0L << (base % SCM_LONG_BIT); - for (; i < (base + n) / SCM_LONG_BIT; i++) - ve[i] = ~0L; - if ((base + n) % SCM_LONG_BIT) - ve[i] |= ~(~0L << ((base + n) % SCM_LONG_BIT)); - } - else - badarg2:SCM_WRONG_TYPE_ARG (2, fill); - } - else - { - if (scm_is_false (fill)) - for (i = base; n--; i += inc) - ve[i / SCM_LONG_BIT] &= ~(1L << (i % SCM_LONG_BIT)); - else if (scm_is_eq (fill, SCM_BOOL_T)) - for (i = base; n--; i += inc) - ve[i / SCM_LONG_BIT] |= (1L << (i % SCM_LONG_BIT)); - else - goto badarg2; - } - break; - } } return 1; } @@ -528,68 +452,12 @@ racp (SCM src, SCM dst) src = SCM_ARRAY_V (src); dst = SCM_ARRAY_V (dst); - if (scm_is_uniform_vector (src) || scm_is_uniform_vector (dst)) - goto gencase; - - switch SCM_TYP7 (dst) - { - default: - gencase: - case scm_tc7_vector: - case scm_tc7_wvect: - - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - scm_array_set_x (dst, - scm_cvref (src, i_s, SCM_UNDEFINED), - scm_from_ulong (i_d)); - break; - case scm_tc7_string: - if (SCM_TYP7 (src) != scm_tc7_string) - goto gencase; - { - char *dst_data = scm_i_string_writable_chars (dst); - const char *src_data = scm_i_string_chars (src); - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - dst_data[i_d] = src_data[i_s]; - scm_i_string_stop_writing (); - } - break; - case scm_tc7_bvect: - if (SCM_TYP7 (src) != scm_tc7_bvect) - goto gencase; - if (1 == inc_d && 1 == inc_s && i_s % SCM_LONG_BIT == i_d % SCM_LONG_BIT && n >= SCM_LONG_BIT) - { - long *sv = (long *) SCM_VELTS (src); - long *dv = (long *) SCM_VELTS (dst); - sv += i_s / SCM_LONG_BIT; - dv += i_d / SCM_LONG_BIT; - if (i_s % SCM_LONG_BIT) - { /* leading partial word */ - *dv = (*dv & ~(~0L << (i_s % SCM_LONG_BIT))) | (*sv & (~0L << (i_s % SCM_LONG_BIT))); - dv++; - sv++; - n -= SCM_LONG_BIT - (i_s % SCM_LONG_BIT); - } - IVDEP (src != dst, - for (; n >= SCM_LONG_BIT; n -= SCM_LONG_BIT, sv++, dv++) - *dv = *sv;) - if (n) /* trailing partial word */ - *dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n)); - } - else - { - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - if (SCM_BITVEC_REF(src, i_s)) - SCM_BITVEC_SET(dst, i_d); - else - SCM_BITVEC_CLR(dst, i_d); - } - break; - } + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + scm_array_set_x (dst, scm_cvref (src, i_s, SCM_UNDEFINED), + scm_from_ulong (i_d)); return 1; } - SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x); @@ -622,18 +490,15 @@ scm_ra_eqp (SCM ra0, SCM ras) ra0 = SCM_ARRAY_V (ra0); ra1 = SCM_ARRAY_V (ra1); ra2 = SCM_ARRAY_V (ra2); - switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0) - { - default: - { - SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (SCM_BITVEC_REF (ra0, i0)) - if (scm_is_false(scm_eq_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))) - SCM_BITVEC_CLR (ra0, i0); - break; - } - } + + { + SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED; + for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) + if (scm_is_true (scm_c_bitvector_ref (ra0, i0))) + if (!scm_is_eq (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) + scm_c_bitvector_set_x (ra0, i0, SCM_BOOL_F); + } + return 1; } @@ -650,20 +515,17 @@ ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt) ra0 = SCM_ARRAY_V (ra0); ra1 = SCM_ARRAY_V (ra1); ra2 = SCM_ARRAY_V (ra2); - switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0) - { - default: - { - SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (SCM_BITVEC_REF (ra0, i0)) - if (opt ? - scm_is_true (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) : - scm_is_false (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))) - SCM_BITVEC_CLR (ra0, i0); - break; - } - } + + { + SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED; + for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) + if (scm_is_true (scm_c_bitvector_ref (ra0, i0))) + if (opt ? + scm_is_true (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) : + scm_is_false (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))) + scm_c_bitvector_set_x (ra0, i0, SCM_BOOL_F); + } + return 1; } @@ -925,15 +787,12 @@ ramap_rp (SCM ra0, SCM proc, SCM ras) ra0 = SCM_ARRAY_V (ra0); ra1 = SCM_ARRAY_V (ra1); ra2 = SCM_ARRAY_V (ra2); - switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0) - { - default: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (SCM_BITVEC_REF (ra0, i0)) - if (scm_is_false (SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))) - SCM_BITVEC_CLR (ra0, i0); - break; - } + + 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) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))) + scm_c_bitvector_set_x (ra0, i0, SCM_BOOL_F); + return 1; } @@ -1221,74 +1080,59 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, #define FUNC_NAME s_scm_array_index_map_x { unsigned long i; - SCM_VALIDATE_NIM (1, ra); SCM_VALIDATE_PROC (2, proc); - if (scm_is_uniform_vector (ra)) - goto uniform_vector; - switch (SCM_TYP7(ra)) + + if (scm_is_generalized_vector (ra)) { - default: - badarg:SCM_WRONG_TYPE_ARG (1, ra); - case scm_tc7_vector: - case scm_tc7_wvect: - { - for (i = 0; i < SCM_VECTOR_LENGTH (ra); i++) - SCM_VECTOR_SET(ra, i, scm_call_1 (proc, scm_from_long (i))); - return SCM_UNSPECIFIED; - } - case scm_tc7_string: - case scm_tc7_bvect: - uniform_vector: - { - unsigned long int length = scm_to_ulong (scm_uniform_vector_length (ra)); - for (i = 0; i < length; i++) - scm_array_set_x (ra, scm_call_1 (proc, scm_from_ulong (i)), - scm_from_ulong (i)); - return SCM_UNSPECIFIED; - } - case scm_tc7_smob: - SCM_ASRTGO (SCM_ARRAYP (ra), badarg); - { - SCM args = SCM_EOL; - SCM inds = scm_make_uve (SCM_ARRAY_NDIM (ra), scm_from_int (-1)); - long *vinds = (long *) SCM_VELTS (inds); - int j, k, kmax = SCM_ARRAY_NDIM (ra) - 1; - if (kmax < 0) - return scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL); - for (k = 0; k <= kmax; k++) - vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd; - k = kmax; - do - { - if (k == kmax) - { - vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd; - i = cind (ra, inds); - for (; vinds[k] <= SCM_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++) - { - for (j = kmax + 1, args = SCM_EOL; j--;) - args = scm_cons (scm_from_long (vinds[j]), args); - scm_array_set_x (SCM_ARRAY_V (ra), - scm_apply_0 (proc, args), - scm_from_ulong (i)); - i += SCM_ARRAY_DIMS (ra)[k].inc; - } - k--; - continue; - } - if (vinds[k] < SCM_ARRAY_DIMS (ra)[k].ubnd) - { - vinds[k]++; - k++; - continue; - } - vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd - 1; - k--; - } - while (k >= 0); - return SCM_UNSPECIFIED; - } + size_t length = scm_c_generalized_vector_length (ra); + for (i = 0; i < length; i++) + scm_c_generalized_vector_set_x (ra, i, + scm_call_1 (proc, scm_from_ulong (i))); + return SCM_UNSPECIFIED; } + else if (SCM_ARRAYP (ra)) + { + SCM args = SCM_EOL; + SCM inds = scm_make_uve (SCM_ARRAY_NDIM (ra), scm_from_int (-1)); + long *vinds = (long *) SCM_VELTS (inds); + int j, k, kmax = SCM_ARRAY_NDIM (ra) - 1; + if (kmax < 0) + return scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL); + for (k = 0; k <= kmax; k++) + vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd; + k = kmax; + do + { + if (k == kmax) + { + vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd; + i = cind (ra, inds); + for (; vinds[k] <= SCM_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++) + { + for (j = kmax + 1, args = SCM_EOL; j--;) + args = scm_cons (scm_from_long (vinds[j]), args); + scm_array_set_x (SCM_ARRAY_V (ra), + scm_apply_0 (proc, args), + scm_from_ulong (i)); + i += SCM_ARRAY_DIMS (ra)[k].inc; + } + k--; + continue; + } + if (vinds[k] < SCM_ARRAY_DIMS (ra)[k].ubnd) + { + vinds[k]++; + k++; + continue; + } + vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd - 1; + k--; + } + while (k >= 0); + return SCM_UNSPECIFIED; + } + else + scm_wrong_type_arg_msg (NULL, 0, ra, "array"); } #undef FUNC_NAME @@ -1309,21 +1153,17 @@ raeql_1 (SCM ra0, SCM as_equal, SCM ra1) ra0 = SCM_ARRAY_V (ra0); } else - n = scm_to_ulong (scm_uniform_vector_length (ra0)); + n = scm_c_generalized_vector_length (ra0); + if (SCM_ARRAYP (ra1)) { i1 = SCM_ARRAY_BASE (ra1); inc1 = SCM_ARRAY_DIMS (ra1)->inc; ra1 = SCM_ARRAY_V (ra1); } - if (scm_is_uniform_vector (ra0)) - goto uniform_vector; - switch (SCM_TYP7 (ra0)) + + if (scm_is_generalized_vector (ra0)) { - case scm_tc7_vector: - case scm_tc7_wvect: - default: - uniform_vector: for (; n--; i0 += inc0, i1 += inc1) { if (scm_is_false (as_equal)) @@ -1335,21 +1175,9 @@ raeql_1 (SCM ra0, SCM as_equal, SCM ra1) return 0; } return 1; - case scm_tc7_string: - { - const char *v0 = scm_i_string_chars (ra0) + i0; - const char *v1 = scm_i_string_chars (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - if (*v0 != *v1) - return 0; - return 1; - } - case scm_tc7_bvect: - for (; n--; i0 += inc0, i1 += inc1) - if (SCM_BITVEC_REF (ra0, i0) != SCM_BITVEC_REF (ra1, i1)) - return 0; - return 1; } + else + return 0; } @@ -1442,35 +1270,9 @@ static char s_array_equal_p[] = "array-equal?"; SCM scm_array_equal_p (SCM ra0, SCM ra1) { - if (SCM_IMP (ra0) || SCM_IMP (ra1)) - callequal:return scm_equal_p (ra0, ra1); - switch (SCM_TYP7(ra0)) - { - default: - goto callequal; - case scm_tc7_bvect: - case scm_tc7_string: - case scm_tc7_vector: - case scm_tc7_wvect: - break; - case scm_tc7_smob: - if (!SCM_ARRAYP (ra0)) - goto callequal; - } - switch (SCM_TYP7 (ra1)) - { - default: - goto callequal; - case scm_tc7_bvect: - case scm_tc7_string: - case scm_tc7_vector: - case scm_tc7_wvect: - break; - case scm_tc7_smob: - if (!SCM_ARRAYP (ra1)) - goto callequal; - } - return scm_from_bool(raeql (ra0, SCM_BOOL_F, ra1)); + if (SCM_ARRAYP (ra0) || SCM_ARRAYP (ra1)) + return scm_from_bool(raeql (ra0, SCM_BOOL_F, ra1)); + return scm_equal_p (ra0, ra1); }