-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
*/
\f
-#if HAVE_CONFIG_H
+#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
* long long llvect s64
*/
-scm_t_bits scm_tc16_array;
-scm_t_bits scm_tc16_enclosed_array;
+scm_t_bits scm_i_tc16_array;
+scm_t_bits scm_i_tc16_enclosed_array;
+
+#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
+ (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
+#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
+ (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
typedef SCM creator_proc (SCM len, SCM fill);
SCM_SYMBOL (scm_sym_s, "s");
SCM_SYMBOL (scm_sym_l, "l");
+static int
+singp (SCM obj)
+{
+ if (!SCM_REALP (obj))
+ return 0;
+ else
+ {
+ double x = SCM_REAL_VALUE (obj);
+ float fx = x;
+ return (- SCM_FLTMAX < x) && (x < SCM_FLTMAX) && (fx == x);
+ }
+}
+
+SCM_API int scm_i_inump (SCM obj);
+SCM_API scm_t_signed_bits scm_i_inum (SCM obj);
+
static SCM
prototype_to_type (SCM proto)
{
if (scm_is_eq (proto, SCM_BOOL_T))
type_name = "b";
- else if (scm_is_eq (proto, SCM_MAKE_CHAR ('a')))
- type_name = "a";
else if (scm_is_eq (proto, SCM_MAKE_CHAR (0)))
type_name = "s8";
+ else if (SCM_CHARP (proto))
+ type_name = "a";
+ else if (scm_i_inump (proto))
+ {
+ if (scm_i_inum (proto) > 0)
+ type_name = "u32";
+ else
+ type_name = "s32";
+ }
else if (scm_is_eq (proto, scm_sym_s))
type_name = "s16";
- else if (scm_is_true (scm_eqv_p (proto, scm_from_int (1))))
- type_name = "u32";
- else if (scm_is_true (scm_eqv_p (proto, scm_from_int (-1))))
- type_name = "s32";
else if (scm_is_eq (proto, scm_sym_l))
type_name = "s64";
- else if (scm_is_true (scm_eqv_p (proto, scm_from_double (1.0))))
- type_name = "f32";
- else if (scm_is_true (scm_eqv_p (proto, scm_divide (scm_from_int (1),
- scm_from_int (3)))))
- type_name = "f64";
- else if (scm_is_true (scm_eqv_p (proto, scm_c_make_rectangular (0, 1))))
+ else if (SCM_REALP (proto)
+ || scm_is_true (scm_eqv_p (proto,
+ scm_divide (scm_from_int (1),
+ scm_from_int (3)))))
+ {
+ if (singp (proto))
+ type_name = "f32";
+ else
+ type_name = "f64";
+ }
+ else if (SCM_COMPLEXP (proto))
type_name = "c64";
else if (scm_is_null (proto))
type_name = NULL;
scm_misc_error (NULL, "~a has no prototype", scm_list_1 (uvec));
}
-SCM
+SCM
scm_make_uve (long k, SCM prot)
#define FUNC_NAME "scm_make_uve"
{
int
scm_is_array (SCM obj)
{
- return (SCM_ENCLOSED_ARRAYP (obj)
- || SCM_ARRAYP (obj)
+ return (SCM_I_ENCLOSED_ARRAYP (obj)
+ || SCM_I_ARRAYP (obj)
|| scm_is_generalized_vector (obj));
}
int
scm_is_typed_array (SCM obj, SCM type)
{
- if (SCM_ENCLOSED_ARRAYP (obj))
+ if (SCM_I_ENCLOSED_ARRAYP (obj))
{
/* Enclosed arrays are arrays but are not of any type.
*/
/* Get storage vector.
*/
- if (SCM_ARRAYP (obj))
- obj = SCM_ARRAY_V (obj);
+ if (SCM_I_ARRAYP (obj))
+ obj = SCM_I_ARRAY_V (obj);
/* It must be a generalized vector (which includes vectors, strings, etc).
*/
return scm_is_eq (type, scm_i_generalized_vector_type (obj));
}
+static SCM
+enclosed_ref (scm_t_array_handle *h, ssize_t pos)
+{
+ return scm_i_cvref (SCM_I_ARRAY_V (h->array), pos + h->base, 1);
+}
+
+static SCM
+vector_ref (scm_t_array_handle *h, ssize_t pos)
+{
+ return ((const SCM *)h->elements)[pos];
+}
+
+static SCM
+string_ref (scm_t_array_handle *h, ssize_t pos)
+{
+ pos += h->base;
+ if (SCM_I_ARRAYP (h->array))
+ return scm_c_string_ref (SCM_I_ARRAY_V (h->array), pos);
+ else
+ return scm_c_string_ref (h->array, pos);
+}
+
+static SCM
+bitvector_ref (scm_t_array_handle *h, ssize_t pos)
+{
+ pos += scm_array_handle_bit_elements_offset (h);
+ return
+ scm_from_bool (((scm_t_uint32 *)h->elements)[pos/32] & (1l << (pos % 32)));
+}
+
+static SCM
+memoize_ref (scm_t_array_handle *h, ssize_t pos)
+{
+ SCM v = h->array;
+
+ if (SCM_I_ENCLOSED_ARRAYP (v))
+ {
+ h->ref = enclosed_ref;
+ return enclosed_ref (h, pos);
+ }
+
+ if (SCM_I_ARRAYP (v))
+ v = SCM_I_ARRAY_V (v);
+
+ if (scm_is_vector (v))
+ {
+ h->elements = scm_array_handle_elements (h);
+ h->ref = vector_ref;
+ }
+ else if (scm_is_uniform_vector (v))
+ {
+ h->elements = scm_array_handle_uniform_elements (h);
+ h->ref = scm_i_uniform_vector_ref_proc (v);
+ }
+ else if (scm_is_string (v))
+ {
+ h->ref = string_ref;
+ }
+ else if (scm_is_bitvector (v))
+ {
+ h->elements = scm_array_handle_bit_elements (h);
+ h->ref = bitvector_ref;
+ }
+ else
+ scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
+
+ return h->ref (h, pos);
+}
+
+static void
+enclosed_set (scm_t_array_handle *h, ssize_t pos, SCM val)
+{
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "non-enclosed array");
+}
+
+static void
+vector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
+{
+ ((SCM *)h->writable_elements)[pos] = val;
+}
+
+static void
+string_set (scm_t_array_handle *h, ssize_t pos, SCM val)
+{
+ pos += h->base;
+ if (SCM_I_ARRAYP (h->array))
+ scm_c_string_set_x (SCM_I_ARRAY_V (h->array), pos, val);
+ else
+ scm_c_string_set_x (h->array, pos, val);
+}
+
+static void
+bitvector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
+{
+ scm_t_uint32 mask;
+ pos += scm_array_handle_bit_elements_offset (h);
+ mask = 1l << (pos % 32);
+ if (scm_to_bool (val))
+ ((scm_t_uint32 *)h->writable_elements)[pos/32] |= mask;
+ else
+ ((scm_t_uint32 *)h->writable_elements)[pos/32] &= ~mask;
+}
+
+static void
+memoize_set (scm_t_array_handle *h, ssize_t pos, SCM val)
+{
+ SCM v = h->array;
+
+ if (SCM_I_ENCLOSED_ARRAYP (v))
+ {
+ h->set = enclosed_set;
+ enclosed_set (h, pos, val);
+ return;
+ }
+
+ if (SCM_I_ARRAYP (v))
+ v = SCM_I_ARRAY_V (v);
+
+ if (scm_is_vector (v))
+ {
+ h->writable_elements = scm_array_handle_writable_elements (h);
+ h->set = vector_set;
+ }
+ else if (scm_is_uniform_vector (v))
+ {
+ h->writable_elements = scm_array_handle_uniform_writable_elements (h);
+ h->set = scm_i_uniform_vector_set_proc (v);
+ }
+ else if (scm_is_string (v))
+ {
+ h->set = string_set;
+ }
+ else if (scm_is_bitvector (v))
+ {
+ h->writable_elements = scm_array_handle_bit_writable_elements (h);
+ h->set = bitvector_set;
+ }
+ else
+ scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
+
+ h->set (h, pos, val);
+}
+
+void
+scm_array_get_handle (SCM array, scm_t_array_handle *h)
+{
+ h->array = array;
+ h->ref = memoize_ref;
+ h->set = memoize_set;
+
+ if (SCM_I_ARRAYP (array) || SCM_I_ENCLOSED_ARRAYP (array))
+ {
+ h->dims = SCM_I_ARRAY_DIMS (array);
+ h->base = SCM_I_ARRAY_BASE (array);
+ }
+ else if (scm_is_generalized_vector (array))
+ {
+ h->dim0.lbnd = 0;
+ h->dim0.ubnd = scm_c_generalized_vector_length (array) - 1;
+ h->dim0.inc = 1;
+ h->dims = &h->dim0;
+ h->base = 0;
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, array, "array");
+}
+
+void
+scm_array_handle_release (scm_t_array_handle *h)
+{
+ /* Nothing to do here until arrays need to be reserved for real.
+ */
+}
+
+size_t
+scm_array_handle_rank (scm_t_array_handle *h)
+{
+ if (SCM_I_ARRAYP (h->array) || SCM_I_ENCLOSED_ARRAYP (h->array))
+ return SCM_I_ARRAY_NDIM (h->array);
+ else
+ return 1;
+}
+
+scm_t_array_dim *
+scm_array_handle_dims (scm_t_array_handle *h)
+{
+ return h->dims;
+}
+
+const SCM *
+scm_array_handle_elements (scm_t_array_handle *h)
+{
+ SCM vec = h->array;
+ if (SCM_I_ARRAYP (vec))
+ vec = SCM_I_ARRAY_V (vec);
+ if (SCM_I_IS_VECTOR (vec))
+ return SCM_I_VECTOR_ELTS (vec) + h->base;
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
+}
+
+SCM *
+scm_array_handle_writable_elements (scm_t_array_handle *h)
+{
+ SCM vec = h->array;
+ if (SCM_I_ARRAYP (vec))
+ vec = SCM_I_ARRAY_V (vec);
+ if (SCM_I_IS_VECTOR (vec))
+ return SCM_I_VECTOR_WELTS (vec) + h->base;
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
+}
+
#if SCM_ENABLE_DEPRECATED
SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
scm_is_array or scm_is_typed_array anyway.
*/
-SCM_DEFINE (scm_array_p, "array?", 1, 0, 0,
- (SCM obj, SCM unused),
+static SCM scm_i_array_p (SCM obj);
+
+SCM_DEFINE (scm_i_array_p, "array?", 1, 0, 0,
+ (SCM obj),
"Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
"not.")
-#define FUNC_NAME s_scm_array_p
+#define FUNC_NAME s_scm_i_array_p
{
return scm_from_bool (scm_is_array (obj));
}
#undef FUNC_NAME
+SCM
+scm_array_p (SCM obj, SCM prot)
+{
+ return scm_from_bool (scm_is_array (obj));
+}
+
#endif /* !SCM_ENABLE_DEPRECATED */
}
#undef FUNC_NAME
+size_t
+scm_c_array_rank (SCM array)
+{
+ scm_t_array_handle handle;
+ size_t res;
+
+ scm_array_get_handle (array, &handle);
+ res = scm_array_handle_rank (&handle);
+ scm_array_handle_release (&handle);
+ return res;
+}
SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
(SCM array),
"Return the number of dimensions of the array @var{array.}\n")
#define FUNC_NAME s_scm_array_rank
{
- if (scm_is_generalized_vector (array))
- return scm_from_int (1);
-
- if (SCM_ARRAYP (array) || SCM_ENCLOSED_ARRAYP (array))
- return scm_from_size_t (SCM_ARRAY_NDIM (array));
-
- scm_wrong_type_arg_msg (NULL, 0, array, "array");
+ return scm_from_size_t (scm_c_array_rank (array));
}
#undef FUNC_NAME
"@end lisp")
#define FUNC_NAME s_scm_array_dimensions
{
- if (scm_is_generalized_vector (ra))
- return scm_list_1 (scm_generalized_vector_length (ra));
-
- if (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra))
- {
- SCM res = SCM_EOL;
- size_t k;
- scm_t_array_dim *s;
+ scm_t_array_handle handle;
+ scm_t_array_dim *s;
+ SCM res = SCM_EOL;
+ size_t k;
- k = SCM_ARRAY_NDIM (ra);
- s = SCM_ARRAY_DIMS (ra);
- while (k--)
- res = scm_cons (s[k].lbnd
- ? scm_cons2 (scm_from_long (s[k].lbnd),
- scm_from_long (s[k].ubnd),
- SCM_EOL)
- : scm_from_long (1 + s[k].ubnd),
- res);
- return res;
- }
+ scm_array_get_handle (ra, &handle);
+ s = scm_array_handle_dims (&handle);
+ k = scm_array_handle_rank (&handle);
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+ while (k--)
+ res = scm_cons (s[k].lbnd
+ ? scm_cons2 (scm_from_ssize_t (s[k].lbnd),
+ scm_from_ssize_t (s[k].ubnd),
+ SCM_EOL)
+ : scm_from_ssize_t (1 + s[k].ubnd),
+ res);
+
+ scm_array_handle_release (&handle);
+ return res;
}
#undef FUNC_NAME
"Return the root vector of a shared array.")
#define FUNC_NAME s_scm_shared_array_root
{
- SCM_ASSERT (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra), ra,
- SCM_ARG1, FUNC_NAME);
- return SCM_ARRAY_V (ra);
+ if (SCM_I_ARRAYP (ra) || SCM_I_ENCLOSED_ARRAYP (ra))
+ return SCM_I_ARRAY_V (ra);
+ else if (scm_is_generalized_vector (ra))
+ return ra;
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
}
#undef FUNC_NAME
"Return the root vector index of the first element in the array.")
#define FUNC_NAME s_scm_shared_array_offset
{
- SCM_ASSERT (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra), ra,
- SCM_ARG1, FUNC_NAME);
- return scm_from_int (SCM_ARRAY_BASE (ra));
+ scm_t_array_handle handle;
+ SCM res;
+
+ scm_array_get_handle (ra, &handle);
+ res = scm_from_size_t (handle.base);
+ scm_array_handle_release (&handle);
+ return res;
}
#undef FUNC_NAME
"For each dimension, return the distance between elements in the root vector.")
#define FUNC_NAME s_scm_shared_array_increments
{
+ scm_t_array_handle handle;
SCM res = SCM_EOL;
size_t k;
scm_t_array_dim *s;
- SCM_ASSERT (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra), ra,
- SCM_ARG1, FUNC_NAME);
- k = SCM_ARRAY_NDIM (ra);
- s = SCM_ARRAY_DIMS (ra);
+ scm_array_get_handle (ra, &handle);
+ k = scm_array_handle_rank (&handle);
+ s = scm_array_handle_dims (&handle);
while (k--)
- res = scm_cons (scm_from_long (s[k].inc), res);
+ res = scm_cons (scm_from_ssize_t (s[k].inc), res);
+ scm_array_handle_release (&handle);
return res;
}
#undef FUNC_NAME
-
-static char s_bad_ind[] = "Bad scm_array index";
-
-
-long
-scm_aind (SCM ra, SCM args, const char *what)
+ssize_t
+scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
{
- SCM ind;
- register long j;
- register unsigned long pos = SCM_ARRAY_BASE (ra);
- register unsigned long k = SCM_ARRAY_NDIM (ra);
- scm_t_array_dim *s = SCM_ARRAY_DIMS (ra);
-
- if (scm_is_integer (args))
- {
- if (k != 1)
- scm_error_num_args_subr (what);
- return pos + (scm_to_long (args) - s->lbnd) * (s->inc);
- }
- while (k && scm_is_pair (args))
+ scm_t_array_dim *s = scm_array_handle_dims (h);
+ ssize_t pos = 0, i;
+ size_t k = scm_array_handle_rank (h);
+
+ while (k > 0 && scm_is_pair (indices))
{
- ind = SCM_CAR (args);
- args = SCM_CDR (args);
- if (!scm_is_integer (ind))
- scm_misc_error (what, s_bad_ind, SCM_EOL);
- j = scm_to_long (ind);
- if (j < s->lbnd || j > s->ubnd)
- scm_out_of_range (what, ind);
- pos += (j - s->lbnd) * (s->inc);
+ i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd);
+ pos += (i - s->lbnd) * s->inc;
k--;
s++;
+ indices = SCM_CDR (indices);
}
- if (k != 0 || !scm_is_null (args))
- scm_error_num_args_subr (what);
-
+ if (k > 0 || !scm_is_null (indices))
+ scm_misc_error (NULL, "wrong number of indices, expecting ~a",
+ scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
return pos;
}
-
-static SCM
-scm_i_make_ra (int ndim, scm_t_bits tag)
+SCM
+scm_i_make_ra (int ndim, int enclosed)
{
+ scm_t_bits tag = enclosed? scm_i_tc16_enclosed_array : scm_i_tc16_array;
SCM ra;
SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + tag,
- scm_gc_malloc ((sizeof (scm_t_array) +
+ scm_gc_malloc ((sizeof (scm_i_t_array) +
ndim * sizeof (scm_t_array_dim)),
"array"));
- SCM_ARRAY_V (ra) = SCM_BOOL_F;
+ SCM_I_ARRAY_V (ra) = SCM_BOOL_F;
return ra;
}
-SCM
-scm_make_ra (int ndim)
-{
- return scm_i_make_ra (ndim, scm_tc16_array);
-}
-
-
static char s_bad_spec[] = "Bad scm_array dimension";
/* Increments will still need to be set. */
-SCM
-scm_shap2ra (SCM args, const char *what)
+static SCM
+scm_i_shap2ra (SCM args)
{
scm_t_array_dim *s;
SCM ra, spec, sp;
int ndim = scm_ilength (args);
if (ndim < 0)
- scm_misc_error (what, s_bad_spec, SCM_EOL);
+ scm_misc_error (NULL, s_bad_spec, SCM_EOL);
- ra = scm_make_ra (ndim);
- SCM_ARRAY_BASE (ra) = 0;
- s = SCM_ARRAY_DIMS (ra);
+ ra = scm_i_make_ra (ndim, 0);
+ SCM_I_ARRAY_BASE (ra) = 0;
+ s = SCM_I_ARRAY_DIMS (ra);
for (; !scm_is_null (args); s++, args = SCM_CDR (args))
{
spec = SCM_CAR (args);
if (scm_is_integer (spec))
{
if (scm_to_long (spec) < 0)
- scm_misc_error (what, s_bad_spec, SCM_EOL);
+ scm_misc_error (NULL, s_bad_spec, SCM_EOL);
s->lbnd = 0;
s->ubnd = scm_to_long (spec) - 1;
s->inc = 1;
else
{
if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec)))
- scm_misc_error (what, s_bad_spec, SCM_EOL);
+ scm_misc_error (NULL, s_bad_spec, SCM_EOL);
s->lbnd = scm_to_long (SCM_CAR (spec));
sp = SCM_CDR (spec);
if (!scm_is_pair (sp)
|| !scm_is_integer (SCM_CAR (sp))
|| !scm_is_null (SCM_CDR (sp)))
- scm_misc_error (what, s_bad_spec, SCM_EOL);
+ scm_misc_error (NULL, s_bad_spec, SCM_EOL);
s->ubnd = scm_to_long (SCM_CAR (sp));
s->inc = 1;
}
SCM ra;
creator = type_to_creator (type);
- ra = scm_shap2ra (bounds, FUNC_NAME);
+ ra = scm_i_shap2ra (bounds);
SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
- s = SCM_ARRAY_DIMS (ra);
- k = SCM_ARRAY_NDIM (ra);
+ s = SCM_I_ARRAY_DIMS (ra);
+ k = SCM_I_ARRAY_NDIM (ra);
while (k--)
{
s[k].inc = rlen;
- SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd);
+ SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
}
- if (scm_is_eq (fill, SCM_BOOL_F) && !scm_is_eq (type, SCM_BOOL_T))
+ if (scm_is_eq (fill, SCM_UNSPECIFIED))
fill = SCM_UNDEFINED;
- SCM_ARRAY_V (ra) = creator (scm_from_size_t (rlen), fill);
+ SCM_I_ARRAY_V (ra) = creator (scm_from_size_t (rlen), fill);
- if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
+ if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
- return SCM_ARRAY_V (ra);
+ return SCM_I_ARRAY_V (ra);
return ra;
}
#undef FUNC_NAME
if (scm_is_integer (dims))
dims = scm_list_1 (dims);
+
+ if (SCM_UNBNDP (fill))
+ {
+ /* Using #\nul as the prototype yields a s8 array, but numeric
+ arrays can't store characters, so we have to special case this.
+ */
+ if (scm_is_eq (prot, SCM_MAKE_CHAR (0)))
+ fill = scm_from_int (0);
+ else
+ fill = prot;
+ }
+
return scm_make_typed_array (prototype_to_type (prot), fill, dims);
}
#undef FUNC_NAME
#endif
-void
-scm_ra_set_contp (SCM ra)
+static void
+scm_i_ra_set_contp (SCM ra)
{
- /* XXX - correct? one-dimensional arrays are always 'contiguous',
- is that right?
- */
- size_t k = SCM_ARRAY_NDIM (ra);
+ size_t k = SCM_I_ARRAY_NDIM (ra);
if (k)
{
- long inc = SCM_ARRAY_DIMS (ra)[k - 1].inc;
+ long inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc;
while (k--)
{
- if (inc != SCM_ARRAY_DIMS (ra)[k].inc)
+ if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc)
{
SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
return;
}
- inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd
- - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
+ inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
+ - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
}
}
SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
"@end lisp")
#define FUNC_NAME s_scm_make_shared_array
{
+ scm_t_array_handle old_handle;
SCM ra;
SCM inds, indptr;
SCM imap;
- size_t k, i;
- long old_min, new_min, old_max, new_max;
+ size_t k;
+ ssize_t i;
+ long old_base, old_min, new_min, old_max, new_max;
scm_t_array_dim *s;
SCM_VALIDATE_REST_ARGUMENT (dims);
- SCM_VALIDATE_ARRAY (1, oldra);
SCM_VALIDATE_PROC (2, mapfunc);
- ra = scm_shap2ra (dims, FUNC_NAME);
- if (SCM_ARRAYP (oldra))
+ ra = scm_i_shap2ra (dims);
+
+ scm_array_get_handle (oldra, &old_handle);
+
+ if (SCM_I_ARRAYP (oldra))
{
- SCM_ARRAY_V (ra) = SCM_ARRAY_V (oldra);
- old_min = old_max = SCM_ARRAY_BASE (oldra);
- s = SCM_ARRAY_DIMS (oldra);
- k = SCM_ARRAY_NDIM (oldra);
+ SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra);
+ old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra);
+ s = scm_array_handle_dims (&old_handle);
+ k = scm_array_handle_rank (&old_handle);
while (k--)
{
if (s[k].inc > 0)
}
else
{
- SCM_ARRAY_V (ra) = oldra;
- old_min = 0;
+ SCM_I_ARRAY_V (ra) = oldra;
+ old_base = old_min = 0;
old_max = scm_c_generalized_vector_length (oldra) - 1;
}
+
inds = SCM_EOL;
- s = SCM_ARRAY_DIMS (ra);
- for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
+ s = SCM_I_ARRAY_DIMS (ra);
+ for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
{
inds = scm_cons (scm_from_long (s[k].lbnd), inds);
if (s[k].ubnd < s[k].lbnd)
{
- if (1 == SCM_ARRAY_NDIM (ra))
+ if (1 == SCM_I_ARRAY_NDIM (ra))
ra = make_typed_vector (scm_array_type (ra), 0);
else
- SCM_ARRAY_V (ra) = make_typed_vector (scm_array_type (ra), 0);
+ SCM_I_ARRAY_V (ra) = make_typed_vector (scm_array_type (ra), 0);
+ scm_array_handle_release (&old_handle);
return ra;
}
}
+
imap = scm_apply_0 (mapfunc, scm_reverse (inds));
- if (SCM_ARRAYP (oldra))
- i = (size_t) scm_aind (oldra, imap, FUNC_NAME);
- else
- {
- if (!scm_is_integer (imap))
- {
- if (scm_ilength (imap) != 1 || !scm_is_integer (SCM_CAR (imap)))
- SCM_MISC_ERROR (s_bad_ind, SCM_EOL);
- imap = SCM_CAR (imap);
- }
- i = scm_to_size_t (imap);
- }
- SCM_ARRAY_BASE (ra) = new_min = new_max = i;
+ i = scm_array_handle_pos (&old_handle, imap);
+ SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base;
indptr = inds;
- k = SCM_ARRAY_NDIM (ra);
+ k = SCM_I_ARRAY_NDIM (ra);
while (k--)
{
if (s[k].ubnd > s[k].lbnd)
{
SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1)));
imap = scm_apply_0 (mapfunc, scm_reverse (inds));
- if (SCM_ARRAYP (oldra))
-
- s[k].inc = scm_aind (oldra, imap, FUNC_NAME) - i;
- else
- {
- if (!scm_is_integer (imap))
- {
- if (scm_ilength (imap) != 1 || !scm_is_integer (SCM_CAR (imap)))
- SCM_MISC_ERROR (s_bad_ind, SCM_EOL);
- imap = SCM_CAR (imap);
- }
- s[k].inc = scm_to_long (imap) - i;
- }
+ s[k].inc = scm_array_handle_pos (&old_handle, imap) - i;
i += s[k].inc;
if (s[k].inc > 0)
new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
s[k].inc = new_max - new_min + 1; /* contiguous by default */
indptr = SCM_CDR (indptr);
}
+
+ scm_array_handle_release (&old_handle);
+
if (old_min > new_min || old_max < new_max)
SCM_MISC_ERROR ("mapping out of range", SCM_EOL);
- if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
+ if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
{
- SCM v = SCM_ARRAY_V (ra);
- unsigned long int length = scm_to_ulong (scm_uniform_vector_length (v));
+ SCM v = SCM_I_ARRAY_V (ra);
+ size_t length = scm_c_generalized_vector_length (v);
if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
return v;
if (s->ubnd < s->lbnd)
return make_typed_vector (scm_array_type (ra), 0);
}
- scm_ra_set_contp (ra);
+ scm_i_ra_set_contp (ra);
return ra;
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_transpose_array
{
SCM res, vargs;
- SCM const *ve = &vargs;
scm_t_array_dim *s, *r;
int ndim, i, k;
return ra;
}
- if (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra))
+ if (SCM_I_ARRAYP (ra) || SCM_I_ENCLOSED_ARRAYP (ra))
{
vargs = scm_vector (args);
- if (SCM_VECTOR_LENGTH (vargs) != SCM_ARRAY_NDIM (ra))
+ if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
SCM_WRONG_NUM_ARGS ();
- ve = SCM_VELTS (vargs);
ndim = 0;
- for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
+ for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
{
- i = scm_to_signed_integer (ve[k], 0, SCM_ARRAY_NDIM(ra));
+ i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k),
+ 0, SCM_I_ARRAY_NDIM(ra));
if (ndim < i)
ndim = i;
}
ndim++;
- res = scm_make_ra (ndim);
- SCM_ARRAY_V (res) = SCM_ARRAY_V (ra);
- SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra);
+ res = scm_i_make_ra (ndim, 0);
+ SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra);
+ SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra);
for (k = ndim; k--;)
{
- SCM_ARRAY_DIMS (res)[k].lbnd = 0;
- SCM_ARRAY_DIMS (res)[k].ubnd = -1;
+ SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
+ SCM_I_ARRAY_DIMS (res)[k].ubnd = -1;
}
- for (k = SCM_ARRAY_NDIM (ra); k--;)
+ for (k = SCM_I_ARRAY_NDIM (ra); k--;)
{
- i = scm_to_int (ve[k]);
- s = &(SCM_ARRAY_DIMS (ra)[k]);
- r = &(SCM_ARRAY_DIMS (res)[i]);
+ i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k));
+ s = &(SCM_I_ARRAY_DIMS (ra)[k]);
+ r = &(SCM_I_ARRAY_DIMS (res)[i]);
if (r->ubnd < r->lbnd)
{
r->lbnd = s->lbnd;
r->ubnd = s->ubnd;
if (r->lbnd < s->lbnd)
{
- SCM_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
+ SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
r->lbnd = s->lbnd;
}
r->inc += s->inc;
}
if (ndim > 0)
SCM_MISC_ERROR ("bad argument list", SCM_EOL);
- scm_ra_set_contp (res);
+ scm_i_ra_set_contp (res);
return res;
}
SCM_VALIDATE_REST_ARGUMENT (axes);
if (scm_is_null (axes))
- axes = scm_cons ((SCM_ARRAYP (ra) ? scm_from_size_t (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL);
+ axes = scm_cons ((SCM_I_ARRAYP (ra) ? scm_from_size_t (SCM_I_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL);
ninr = scm_ilength (axes);
if (ninr < 0)
SCM_WRONG_NUM_ARGS ();
- ra_inr = scm_make_ra (ninr);
+ ra_inr = scm_i_make_ra (ninr, 0);
if (scm_is_generalized_vector (ra))
{
s->lbnd = 0;
- s->ubnd = scm_to_long (scm_uniform_vector_length (ra)) - 1;
+ s->ubnd = scm_c_generalized_vector_length (ra) - 1;
s->inc = 1;
- SCM_ARRAY_V (ra_inr) = ra;
- SCM_ARRAY_BASE (ra_inr) = 0;
+ SCM_I_ARRAY_V (ra_inr) = ra;
+ SCM_I_ARRAY_BASE (ra_inr) = 0;
ndim = 1;
}
- else if (SCM_ARRAYP (ra))
+ else if (SCM_I_ARRAYP (ra))
{
- s = SCM_ARRAY_DIMS (ra);
- SCM_ARRAY_V (ra_inr) = SCM_ARRAY_V (ra);
- SCM_ARRAY_BASE (ra_inr) = SCM_ARRAY_BASE (ra);
- ndim = SCM_ARRAY_NDIM (ra);
+ s = SCM_I_ARRAY_DIMS (ra);
+ SCM_I_ARRAY_V (ra_inr) = SCM_I_ARRAY_V (ra);
+ SCM_I_ARRAY_BASE (ra_inr) = SCM_I_ARRAY_BASE (ra);
+ ndim = SCM_I_ARRAY_NDIM (ra);
}
else
scm_wrong_type_arg_msg (NULL, 0, ra, "array");
if (noutr < 0)
SCM_WRONG_NUM_ARGS ();
axv = scm_make_string (scm_from_int (ndim), SCM_MAKE_CHAR (0));
- res = scm_i_make_ra (noutr, scm_tc16_enclosed_array);
- SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr);
- SCM_ARRAY_V (res) = ra_inr;
+ res = scm_i_make_ra (noutr, 1);
+ SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra_inr);
+ SCM_I_ARRAY_V (res) = ra_inr;
for (k = 0; k < ninr; k++, axes = SCM_CDR (axes))
{
if (!scm_is_integer (SCM_CAR (axes)))
SCM_MISC_ERROR ("bad axis", SCM_EOL);
j = scm_to_int (SCM_CAR (axes));
- SCM_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd;
- SCM_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd;
- SCM_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc;
+ SCM_I_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd;
+ SCM_I_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd;
+ SCM_I_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc;
scm_c_string_set_x (axv, j, SCM_MAKE_CHAR (1));
}
c_axv = scm_i_string_chars (axv);
{
while (c_axv[j])
j++;
- SCM_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd;
- SCM_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd;
- SCM_ARRAY_DIMS (res)[k].inc = s[j].inc;
+ SCM_I_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd;
+ SCM_I_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd;
+ SCM_I_ARRAY_DIMS (res)[k].inc = s[j].inc;
}
scm_remember_upto_here_1 (axv);
- scm_ra_set_contp (ra_inr);
- scm_ra_set_contp (res);
+ scm_i_ra_set_contp (ra_inr);
+ scm_i_ra_set_contp (res);
return res;
}
#undef FUNC_NAME
SCM_VALIDATE_REST_ARGUMENT (args);
- if (scm_is_generalized_vector (v))
- {
- long ind;
-
- if (!scm_is_pair (args))
- SCM_WRONG_NUM_ARGS ();
- ind = scm_to_long (SCM_CAR (args));
- args = SCM_CDR (args);
- res = scm_from_bool (ind >= 0
- && ind < scm_c_generalized_vector_length (v));
- }
- else if (SCM_ARRAYP (v) || SCM_ENCLOSED_ARRAYP (v))
+ if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v))
{
- size_t k = SCM_ARRAY_NDIM (v);
- scm_t_array_dim *s = SCM_ARRAY_DIMS (v);
+ size_t k, ndim = SCM_I_ARRAY_NDIM (v);
+ scm_t_array_dim *s = SCM_I_ARRAY_DIMS (v);
- while (k > 0)
+ for (k = 0; k < ndim; k++)
{
long ind;
SCM_WRONG_NUM_ARGS ();
ind = scm_to_long (SCM_CAR (args));
args = SCM_CDR (args);
- k -= 1;
- if (ind < s->lbnd || ind > s->ubnd)
+ if (ind < s[k].lbnd || ind > s[k].ubnd)
{
res = SCM_BOOL_F;
/* We do not stop the checking after finding a violation
}
}
}
+ else if (scm_is_generalized_vector (v))
+ {
+ /* Since real arrays have been covered above, all generalized
+ vectors are guaranteed to be zero-origin here.
+ */
+
+ long ind;
+
+ if (!scm_is_pair (args))
+ SCM_WRONG_NUM_ARGS ();
+ ind = scm_to_long (SCM_CAR (args));
+ args = SCM_CDR (args);
+ res = scm_from_bool (ind >= 0
+ && ind < scm_c_generalized_vector_length (v));
+ }
else
scm_wrong_type_arg_msg (NULL, 0, v, "array");
{
if (enclosed)
{
- int k = SCM_ARRAY_NDIM (v);
- SCM res = scm_make_ra (k);
- SCM_ARRAY_V (res) = SCM_ARRAY_V (v);
- SCM_ARRAY_BASE (res) = pos;
+ int k = SCM_I_ARRAY_NDIM (v);
+ SCM res = scm_i_make_ra (k, 0);
+ SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (v);
+ SCM_I_ARRAY_BASE (res) = pos;
while (k--)
{
- SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd;
- SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd;
- SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc;
+ SCM_I_ARRAY_DIMS (res)[k].ubnd = SCM_I_ARRAY_DIMS (v)[k].ubnd;
+ SCM_I_ARRAY_DIMS (res)[k].lbnd = SCM_I_ARRAY_DIMS (v)[k].lbnd;
+ SCM_I_ARRAY_DIMS (res)[k].inc = SCM_I_ARRAY_DIMS (v)[k].inc;
}
return res;
}
return scm_c_generalized_vector_ref (v, pos);
}
-SCM
-scm_cvref (SCM v, unsigned long pos, SCM last)
-{
- return scm_i_cvref (v, pos, 0);
-}
-
SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
(SCM v, SCM args),
"Return the element at the @code{(index1, index2)} element in\n"
"@var{array}.")
#define FUNC_NAME s_scm_array_ref
{
- long pos;
- int enclosed = 0;
-
- if (SCM_ARRAYP (v) || SCM_ENCLOSED_ARRAYP (v))
- {
- enclosed = SCM_ENCLOSED_ARRAYP (v);
- pos = scm_aind (v, args, FUNC_NAME);
- v = SCM_ARRAY_V (v);
- }
- else
- {
- size_t length;
- if (SCM_NIMP (args))
- {
- SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, FUNC_NAME);
- pos = scm_to_long (SCM_CAR (args));
- SCM_ASRTGO (scm_is_null (SCM_CDR (args)), wna);
- }
- else
- pos = scm_to_long (args);
- length = scm_c_generalized_vector_length (v);
- SCM_ASRTGO (pos >= 0 && pos < length, outrng);
- }
-
- return scm_i_cvref (v, pos, enclosed);
+ scm_t_array_handle handle;
+ SCM res;
- wna:
- scm_wrong_num_args (NULL);
- outrng:
- scm_out_of_range (NULL, scm_from_long (pos));
+ scm_array_get_handle (v, &handle);
+ res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args));
+ scm_array_handle_release (&handle);
+ return res;
}
#undef FUNC_NAME
"@var{new-value}. The value returned by array-set! is unspecified.")
#define FUNC_NAME s_scm_array_set_x
{
- long pos = 0;
+ scm_t_array_handle handle;
- if (SCM_ARRAYP (v))
- {
- pos = scm_aind (v, args, FUNC_NAME);
- v = SCM_ARRAY_V (v);
- }
- else if (SCM_ENCLOSED_ARRAYP (v))
- scm_wrong_type_arg_msg (NULL, 0, v, "non-enclosed array");
- else if (scm_is_generalized_vector (v))
- {
- size_t length;
- if (scm_is_pair (args))
- {
- SCM_ASRTGO (scm_is_null (SCM_CDR (args)), wna);
- pos = scm_to_long (SCM_CAR (args));
- }
- else
- pos = scm_to_long (args);
- length = scm_c_generalized_vector_length (v);
- SCM_ASRTGO (pos >= 0 && pos < length, outrng);
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "array");
-
- scm_c_generalized_vector_set_x (v, pos, obj);
+ scm_array_get_handle (v, &handle);
+ scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj);
+ scm_array_handle_release (&handle);
return SCM_UNSPECIFIED;
-
- outrng:
- scm_out_of_range (NULL, scm_from_long (pos));
- wna:
- scm_wrong_num_args (NULL);
}
#undef FUNC_NAME
if (scm_is_generalized_vector (ra))
return ra;
- if (SCM_ARRAYP (ra))
+ if (SCM_I_ARRAYP (ra))
{
- size_t k, ndim = SCM_ARRAY_NDIM (ra), len = 1;
- if (!SCM_ARRAYP (ra) || !SCM_ARRAY_CONTP (ra))
+ size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
+ if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra))
return SCM_BOOL_F;
for (k = 0; k < ndim; k++)
- len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
+ len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
if (!SCM_UNBNDP (strict))
{
- if (ndim && (1 != SCM_ARRAY_DIMS (ra)[ndim - 1].inc))
+ if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc))
return SCM_BOOL_F;
- if (scm_is_bitvector (SCM_ARRAY_V (ra)))
+ if (scm_is_bitvector (SCM_I_ARRAY_V (ra)))
{
- if (len != scm_c_bitvector_length (SCM_ARRAY_V (ra)) ||
- SCM_ARRAY_BASE (ra) % SCM_LONG_BIT ||
+ if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
+ SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
len % SCM_LONG_BIT)
return SCM_BOOL_F;
}
}
{
- SCM v = SCM_ARRAY_V (ra);
+ SCM v = SCM_I_ARRAY_V (ra);
size_t length = scm_c_generalized_vector_length (v);
- if ((len == length) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc)
+ if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc)
return v;
}
- sra = scm_make_ra (1);
- SCM_ARRAY_DIMS (sra)->lbnd = 0;
- SCM_ARRAY_DIMS (sra)->ubnd = len - 1;
- SCM_ARRAY_V (sra) = SCM_ARRAY_V (ra);
- SCM_ARRAY_BASE (sra) = SCM_ARRAY_BASE (ra);
- SCM_ARRAY_DIMS (sra)->inc = (ndim ? SCM_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
+ sra = scm_i_make_ra (1, 0);
+ SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
+ SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
+ SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra);
+ SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra);
+ SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
return sra;
}
- else if (SCM_ENCLOSED_ARRAYP (ra))
+ else if (SCM_I_ENCLOSED_ARRAYP (ra))
scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array");
else
scm_wrong_type_arg_msg (NULL, 0, ra, "array");
SCM ret;
long inc = 1;
size_t k, len = 1;
- for (k = SCM_ARRAY_NDIM (ra); k--;)
- len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
- k = SCM_ARRAY_NDIM (ra);
- if (SCM_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_ARRAY_DIMS (ra)[k - 1].inc)))
+ for (k = SCM_I_ARRAY_NDIM (ra); k--;)
+ len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
+ k = SCM_I_ARRAY_NDIM (ra);
+ if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k - 1].inc)))
{
- if (!scm_is_bitvector (SCM_ARRAY_V (ra)))
+ if (!scm_is_bitvector (SCM_I_ARRAY_V (ra)))
return ra;
- if ((len == scm_c_bitvector_length (SCM_ARRAY_V (ra)) &&
- 0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT &&
+ if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) &&
+ 0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT &&
0 == len % SCM_LONG_BIT))
return ra;
}
- ret = scm_make_ra (k);
- SCM_ARRAY_BASE (ret) = 0;
+ ret = scm_i_make_ra (k, 0);
+ SCM_I_ARRAY_BASE (ret) = 0;
while (k--)
{
- SCM_ARRAY_DIMS (ret)[k].lbnd = SCM_ARRAY_DIMS (ra)[k].lbnd;
- SCM_ARRAY_DIMS (ret)[k].ubnd = SCM_ARRAY_DIMS (ra)[k].ubnd;
- SCM_ARRAY_DIMS (ret)[k].inc = inc;
- inc *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
+ SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
+ SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd;
+ SCM_I_ARRAY_DIMS (ret)[k].inc = inc;
+ inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
}
- SCM_ARRAY_V (ret) = make_typed_vector (scm_array_type (ra), inc);
+ SCM_I_ARRAY_V (ret) = make_typed_vector (scm_array_type (ra), inc);
if (copy)
scm_array_copy_x (ra, ret);
return ret;
#define FUNC_NAME s_scm_uniform_array_read_x
{
if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_cur_inp;
+ port_or_fd = scm_current_input_port ();
if (scm_is_uniform_vector (ura))
{
return scm_uniform_vector_read_x (ura, port_or_fd, start, end);
}
- else if (SCM_ARRAYP (ura))
+ else if (SCM_I_ARRAYP (ura))
{
size_t base, vlen, cstart, cend;
SCM cra, ans;
cra = scm_ra2contig (ura, 0);
- base = SCM_ARRAY_BASE (cra);
- vlen = SCM_ARRAY_DIMS (cra)->inc *
- (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1);
+ base = SCM_I_ARRAY_BASE (cra);
+ vlen = SCM_I_ARRAY_DIMS (cra)->inc *
+ (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
cstart = 0;
cend = vlen;
cend = scm_to_unsigned_integer (end, cstart, vlen);
}
- ans = scm_uniform_vector_read_x (SCM_ARRAY_V (cra), port_or_fd,
+ ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd,
scm_from_size_t (base + cstart),
scm_from_size_t (base + cend));
scm_array_copy_x (cra, ura);
return ans;
}
- else if (SCM_ENCLOSED_ARRAYP (ura))
+ else if (SCM_I_ENCLOSED_ARRAYP (ura))
scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array");
else
scm_wrong_type_arg_msg (NULL, 0, ura, "array");
#define FUNC_NAME s_scm_uniform_array_write
{
if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_cur_outp;
+ port_or_fd = scm_current_output_port ();
if (scm_is_uniform_vector (ura))
{
return scm_uniform_vector_write (ura, port_or_fd, start, end);
}
- else if (SCM_ARRAYP (ura))
+ else if (SCM_I_ARRAYP (ura))
{
size_t base, vlen, cstart, cend;
SCM cra, ans;
cra = scm_ra2contig (ura, 1);
- base = SCM_ARRAY_BASE (cra);
- vlen = SCM_ARRAY_DIMS (cra)->inc *
- (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1);
+ base = SCM_I_ARRAY_BASE (cra);
+ vlen = SCM_I_ARRAY_DIMS (cra)->inc *
+ (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
cstart = 0;
cend = vlen;
cend = scm_to_unsigned_integer (end, cstart, vlen);
}
- ans = scm_uniform_vector_write (SCM_ARRAY_V (cra), port_or_fd,
+ ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd,
scm_from_size_t (base + cstart),
scm_from_size_t (base + cend));
return ans;
}
- else if (SCM_ENCLOSED_ARRAYP (ura))
+ else if (SCM_I_ENCLOSED_ARRAYP (ura))
scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array");
else
scm_wrong_type_arg_msg (NULL, 0, ura, "array");
#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
#define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
-static size_t
-bitvector_free (SCM vec)
-{
- scm_gc_free (BITVECTOR_BITS (vec),
- sizeof (scm_t_uint32) * ((BITVECTOR_LENGTH (vec)+31)/32),
- "bitvector");
- return 0;
-}
static int
bitvector_print (SCM vec, SCM port, scm_print_state *pstate)
#undef FUNC_NAME
const scm_t_uint32 *
-scm_bitvector_elements (SCM vec)
+scm_array_handle_bit_elements (scm_t_array_handle *h)
{
- scm_assert_smob_type (scm_tc16_bitvector, vec);
- return BITVECTOR_BITS (vec);
+ return scm_array_handle_bit_writable_elements (h);
}
-void
-scm_bitvector_release_elements (SCM vec)
-{
- /* Nothing to do right now, but this function might come in handy
- when bitvectors need to be locked when giving away a pointer
- to their elements.
-
- Also, a call to scm_bitvector_release_elements acts like
- scm_remember_upto_here, which is needed in any case.
- */
-
- scm_remember_upto_here_1 (vec);
-}
-
-void
-scm_frame_bitvector_release_elements (SCM vec)
+scm_t_uint32 *
+scm_array_handle_bit_writable_elements (scm_t_array_handle *h)
{
- scm_frame_unwind_handler_with_scm (scm_bitvector_release_elements, vec,
- SCM_F_WIND_EXPLICITLY);
+ SCM vec = h->array;
+ if (SCM_I_ARRAYP (vec))
+ vec = SCM_I_ARRAY_V (vec);
+ if (IS_BITVECTOR (vec))
+ return BITVECTOR_BITS (vec) + h->base/32;
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array");
}
-scm_t_uint32 *
-scm_bitvector_writable_elements (SCM vec)
+size_t
+scm_array_handle_bit_elements_offset (scm_t_array_handle *h)
{
- scm_assert_smob_type (scm_tc16_bitvector, vec);
- return BITVECTOR_BITS (vec);
+ return h->base % 32;
}
-void
-scm_bitvector_release_writable_elements (SCM vec)
+const scm_t_uint32 *
+scm_bitvector_elements (SCM vec,
+ scm_t_array_handle *h,
+ size_t *offp,
+ size_t *lenp,
+ ssize_t *incp)
{
- scm_remember_upto_here_1 (vec);
+ return scm_bitvector_writable_elements (vec, h, offp, lenp, incp);
}
-void
-scm_frame_bitvector_release_writable_elements (SCM vec)
-{
- scm_frame_unwind_handler_with_scm
- (scm_bitvector_release_writable_elements, vec,
- SCM_F_WIND_EXPLICITLY);
+
+scm_t_uint32 *
+scm_bitvector_writable_elements (SCM vec,
+ scm_t_array_handle *h,
+ size_t *offp,
+ size_t *lenp,
+ ssize_t *incp)
+{
+ scm_generalized_vector_get_handle (vec, h);
+ if (offp)
+ {
+ scm_t_array_dim *dim = scm_array_handle_dims (h);
+ *offp = scm_array_handle_bit_elements_offset (h);
+ *lenp = dim->ubnd - dim->lbnd + 1;
+ *incp = dim->inc;
+ }
+ return scm_array_handle_bit_writable_elements (h);
}
SCM
scm_c_bitvector_ref (SCM vec, size_t idx)
{
- if (idx < scm_c_bitvector_length (vec))
+ scm_t_array_handle handle;
+ const scm_t_uint32 *bits;
+
+ if (IS_BITVECTOR (vec))
{
- const scm_t_uint32 *bits = scm_bitvector_elements (vec);
- SCM res = (bits[idx/32] & (1L << (idx%32)))? SCM_BOOL_T : SCM_BOOL_F;
- scm_bitvector_release_elements (vec);
- return res;
+ if (idx >= BITVECTOR_LENGTH (vec))
+ scm_out_of_range (NULL, scm_from_size_t (idx));
+ bits = BITVECTOR_BITS(vec);
+ return scm_from_bool (bits[idx/32] & (1L << (idx%32)));
}
else
- scm_out_of_range (NULL, scm_from_size_t (idx));
+ {
+ SCM res;
+ size_t len, off;
+ ssize_t inc;
+
+ bits = scm_bitvector_elements (vec, &handle, &off, &len, &inc);
+ if (idx >= len)
+ scm_out_of_range (NULL, scm_from_size_t (idx));
+ idx = idx*inc + off;
+ res = scm_from_bool (bits[idx/32] & (1L << (idx%32)));
+ scm_array_handle_release (&handle);
+ return res;
+ }
}
SCM_DEFINE (scm_bitvector_ref, "bitvector-ref", 2, 0, 0,
void
scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val)
{
- if (idx < scm_c_bitvector_length (vec))
+ scm_t_array_handle handle;
+ scm_t_uint32 *bits, mask;
+
+ if (IS_BITVECTOR (vec))
{
- scm_t_uint32 *bits = scm_bitvector_writable_elements (vec);
- scm_t_uint32 mask = 1L << (idx%32);
- if (scm_is_true (val))
- bits[idx/32] |= mask;
- else
- bits[idx/32] &= ~mask;
- scm_bitvector_release_writable_elements (vec);
+ if (idx >= BITVECTOR_LENGTH (vec))
+ scm_out_of_range (NULL, scm_from_size_t (idx));
+ bits = BITVECTOR_BITS(vec);
}
else
- scm_out_of_range (NULL, scm_from_size_t (idx));
+ {
+ size_t len, off;
+ ssize_t inc;
+
+ bits = scm_bitvector_writable_elements (vec, &handle, &off, &len, &inc);
+ if (idx >= len)
+ scm_out_of_range (NULL, scm_from_size_t (idx));
+ idx = idx*inc + off;
+ }
+
+ mask = 1L << (idx%32);
+ if (scm_is_true (val))
+ bits[idx/32] |= mask;
+ else
+ bits[idx/32] &= ~mask;
+
+ if (!IS_BITVECTOR (vec))
+ scm_array_handle_release (&handle);
}
SCM_DEFINE (scm_bitvector_set_x, "bitvector-set!", 3, 0, 0,
"@var{vec} when @var{val} is true, else clear them.")
#define FUNC_NAME s_scm_bitvector_fill_x
{
- scm_t_uint32 *bits = scm_bitvector_writable_elements (vec);
- size_t bit_len = BITVECTOR_LENGTH (vec);
- size_t word_len = (bit_len + 31) / 32;
- memset (bits, scm_is_true (val)? -1:0, sizeof (scm_t_uint32) * word_len);
- scm_bitvector_release_writable_elements (vec);
+ scm_t_array_handle handle;
+ size_t off, len;
+ ssize_t inc;
+ scm_t_uint32 *bits;
+
+ bits = scm_bitvector_writable_elements (vec, &handle,
+ &off, &len, &inc);
+
+ if (off == 0 && inc == 1 && len > 0)
+ {
+ /* the usual case
+ */
+ size_t word_len = (len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
+
+ if (scm_is_true (val))
+ {
+ memset (bits, 0xFF, sizeof(scm_t_uint32)*(word_len-1));
+ bits[word_len-1] |= last_mask;
+ }
+ else
+ {
+ memset (bits, 0x00, sizeof(scm_t_uint32)*(word_len-1));
+ bits[word_len-1] &= ~last_mask;
+ }
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < len; i++)
+ scm_array_handle_set (&handle, i*inc, val);
+ }
+
+ scm_array_handle_release (&handle);
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
size_t bit_len = scm_to_size_t (scm_length (list));
SCM vec = scm_c_make_bitvector (bit_len, SCM_UNDEFINED);
size_t word_len = (bit_len+31)/32;
- scm_t_uint32 *bits = scm_bitvector_writable_elements (vec);
+ scm_t_array_handle handle;
+ scm_t_uint32 *bits = scm_bitvector_writable_elements (vec, &handle,
+ NULL, NULL, NULL);
size_t i, j;
for (i = 0; i < word_len && scm_is_pair (list); i++, bit_len -= 32)
if (scm_is_true (SCM_CAR (list)))
bits[i] |= mask;
}
-
- scm_bitvector_release_writable_elements (vec);
+
+ scm_array_handle_release (&handle);
+
return vec;
}
#undef FUNC_NAME
"of the bitvector @var{vec}.")
#define FUNC_NAME s_scm_bitvector_to_list
{
- size_t bit_len = scm_c_bitvector_length (vec);
+ scm_t_array_handle handle;
+ size_t off, len;
+ ssize_t inc;
+ scm_t_uint32 *bits;
SCM res = SCM_EOL;
- size_t word_len = (bit_len+31)/32;
- const scm_t_uint32 *bits = scm_bitvector_elements (vec);
- size_t i, j;
- for (i = 0; i < word_len; i++, bit_len -= 32)
+ bits = scm_bitvector_writable_elements (vec, &handle,
+ &off, &len, &inc);
+
+ if (off == 0 && inc == 1)
{
- scm_t_uint32 mask = 1;
- for (j = 0; j < 32 && j < bit_len; j++, mask <<= 1)
- res = scm_cons ((bits[i] & mask)? SCM_BOOL_T : SCM_BOOL_F, res);
+ /* the usual case
+ */
+ size_t word_len = (len + 31) / 32;
+ size_t i, j;
+
+ for (i = 0; i < word_len; i++, len -= 32)
+ {
+ scm_t_uint32 mask = 1;
+ for (j = 0; j < 32 && j < len; j++, mask <<= 1)
+ res = scm_cons ((bits[i] & mask)? SCM_BOOL_T : SCM_BOOL_F, res);
+ }
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < len; i++)
+ res = scm_cons (scm_array_handle_ref (&handle, i*inc), res);
}
+
+ scm_array_handle_release (&handle);
- scm_bitvector_release_elements (vec);
return scm_reverse_x (res, SCM_EOL);
}
#undef FUNC_NAME
"@var{bitvector}.")
#define FUNC_NAME s_scm_bit_count
{
- size_t bit_len = scm_c_bitvector_length (bitvector);
- size_t word_len = (bit_len + 31) / 32;
- scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - bit_len);
- const scm_t_uint32 *bits = scm_bitvector_elements (bitvector);
-
+ scm_t_array_handle handle;
+ size_t off, len;
+ ssize_t inc;
+ scm_t_uint32 *bits;
int bit = scm_to_bool (b);
- size_t count = 0, i;
+ size_t count = 0;
- if (bit_len == 0)
- return 0;
+ bits = scm_bitvector_writable_elements (bitvector, &handle,
+ &off, &len, &inc);
- for (i = 0; i < word_len-1; i++)
- count += count_ones (bits[i]);
- count += count_ones (bits[i] & last_mask);
+ if (off == 0 && inc == 1 && len > 0)
+ {
+ /* the usual case
+ */
+ size_t word_len = (len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
+ size_t i;
- scm_bitvector_release_elements (bitvector);
- return scm_from_size_t (bit? count : bit_len-count);
+ for (i = 0; i < word_len-1; i++)
+ count += count_ones (bits[i]);
+ count += count_ones (bits[i] & last_mask);
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < len; i++)
+ if (scm_is_true (scm_array_handle_ref (&handle, i*inc)))
+ count++;
+ }
+
+ scm_array_handle_release (&handle);
+
+ return scm_from_size_t (bit? count : len-count);
}
#undef FUNC_NAME
"@end example")
#define FUNC_NAME s_scm_bit_position
{
- size_t bit_len = scm_c_bitvector_length (v);
- size_t word_len = (bit_len + 31) / 32;
- scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - bit_len);
- const scm_t_uint32 *bits = scm_bitvector_elements (v);
- size_t first_bit = scm_to_unsigned_integer (k, 0, bit_len);
- size_t first_word = first_bit / 32;
- scm_t_uint32 first_mask = ((scm_t_uint32)-1) << (first_bit - 32*first_word);
- scm_t_uint32 w;
-
+ scm_t_array_handle handle;
+ size_t off, len, first_bit;
+ ssize_t inc;
+ const scm_t_uint32 *bits;
int bit = scm_to_bool (item);
- size_t i;
SCM res = SCM_BOOL_F;
+
+ bits = scm_bitvector_elements (v, &handle, &off, &len, &inc);
+ first_bit = scm_to_unsigned_integer (k, 0, len);
- if (bit_len == 0)
- return 0;
-
- for (i = first_word; i < word_len; i++)
+ if (off == 0 && inc == 1 && len > 0)
{
- w = (bit? bits[i] : ~bits[i]);
- if (i == first_word)
- w &= first_mask;
- if (i == word_len-1)
- w &= last_mask;
- if (w)
+ size_t i, word_len = (len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
+ size_t first_word = first_bit / 32;
+ scm_t_uint32 first_mask =
+ ((scm_t_uint32)-1) << (first_bit - 32*first_word);
+ scm_t_uint32 w;
+
+ for (i = first_word; i < word_len; i++)
{
- res = scm_from_size_t (32*i + find_first_one (w));
- break;
+ w = (bit? bits[i] : ~bits[i]);
+ if (i == first_word)
+ w &= first_mask;
+ if (i == word_len-1)
+ w &= last_mask;
+ if (w)
+ {
+ res = scm_from_size_t (32*i + find_first_one (w));
+ break;
+ }
}
}
+ else
+ {
+ size_t i;
+ for (i = first_bit; i < len; i++)
+ {
+ SCM elt = scm_array_handle_ref (&handle, i*inc);
+ if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
+ {
+ res = scm_from_size_t (i);
+ break;
+ }
+ }
+ }
+
+ scm_array_handle_release (&handle);
- scm_bitvector_release_elements (v);
return res;
}
#undef FUNC_NAME
"@end example")
#define FUNC_NAME s_scm_bit_set_star_x
{
+ scm_t_array_handle v_handle;
+ size_t v_off, v_len;
+ ssize_t v_inc;
+ scm_t_uint32 *v_bits;
+ int bit;
+
+ /* Validate that OBJ is a boolean so this is done even if we don't
+ need BIT.
+ */
+ bit = scm_to_bool (obj);
+
+ v_bits = scm_bitvector_writable_elements (v, &v_handle,
+ &v_off, &v_len, &v_inc);
+
if (scm_is_bitvector (kv))
{
- size_t bit_len = scm_c_bitvector_length (kv);
- size_t word_len = (bit_len + 31) / 32;
- scm_t_uint32 *bits1;
- const scm_t_uint32 *bits2;
- size_t i;
- int bit = scm_to_bool (obj);
-
- if (scm_c_bitvector_length (v) != bit_len)
+ scm_t_array_handle kv_handle;
+ size_t kv_off, kv_len;
+ ssize_t kv_inc;
+ const scm_t_uint32 *kv_bits;
+
+ kv_bits = scm_bitvector_elements (v, &kv_handle,
+ &kv_off, &kv_len, &kv_inc);
+
+ if (v_len != kv_len)
scm_misc_error (NULL,
"bit vectors must have equal length",
SCM_EOL);
- bits1 = scm_bitvector_writable_elements (v);
- bits2 = scm_bitvector_elements (kv);
-
- if (bit == 0)
- for (i = 0; i < word_len; i++)
- bits1[i] &= ~bits2[i];
+ if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
+ {
+ size_t word_len = (kv_len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
+ size_t i;
+
+ if (bit == 0)
+ {
+ for (i = 0; i < word_len-1; i++)
+ v_bits[i] &= ~kv_bits[i];
+ v_bits[i] &= ~(kv_bits[i] & last_mask);
+ }
+ else
+ {
+ for (i = 0; i < word_len-1; i++)
+ v_bits[i] |= kv_bits[i];
+ v_bits[i] |= kv_bits[i] & last_mask;
+ }
+ }
else
- for (i = 0; i < word_len; i++)
- bits1[i] |= bits2[i];
+ {
+ size_t i;
+ for (i = 0; i < kv_len; i++)
+ if (scm_is_true (scm_array_handle_ref (&kv_handle, i*kv_inc)))
+ scm_array_handle_set (&v_handle, i*v_inc, obj);
+ }
+
+ scm_array_handle_release (&kv_handle);
- scm_bitvector_release_elements (kv);
- scm_bitvector_release_writable_elements (v);
}
else if (scm_is_true (scm_u32vector_p (kv)))
{
- size_t ulen, i;
- const scm_t_uint32 *indices;
-
- /* assert that obj is a boolean.
- */
- scm_to_bool (obj);
-
- scm_frame_begin (0);
-
- ulen = scm_c_uniform_vector_length (kv);
- indices = scm_u32vector_elements (kv);
- scm_frame_uniform_vector_release_elements (kv);
+ scm_t_array_handle kv_handle;
+ size_t i, kv_len;
+ ssize_t kv_inc;
+ const scm_t_uint32 *kv_elts;
- for (i = 0; i < ulen; i++)
- scm_c_bitvector_set_x (v, (size_t)indices[i], obj);
+ kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
+ for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
+ scm_array_handle_set (&v_handle, (*kv_elts)*v_inc, obj);
- scm_frame_end ();
+ scm_array_handle_release (&kv_handle);
}
else
scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
+ scm_array_handle_release (&v_handle);
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
"@end example")
#define FUNC_NAME s_scm_bit_count_star
{
+ scm_t_array_handle v_handle;
+ size_t v_off, v_len;
+ ssize_t v_inc;
+ const scm_t_uint32 *v_bits;
+ size_t count = 0;
+ int bit;
+
+ /* Validate that OBJ is a boolean so this is done even if we don't
+ need BIT.
+ */
+ bit = scm_to_bool (obj);
+
+ v_bits = scm_bitvector_elements (v, &v_handle,
+ &v_off, &v_len, &v_inc);
+
if (scm_is_bitvector (kv))
{
- size_t bit_len = scm_c_bitvector_length (kv);
- size_t word_len = (bit_len + 31) / 32;
- scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - bit_len);
- scm_t_uint32 xor_mask = scm_to_bool (obj)? 0 : ((scm_t_uint32)-1);
- const scm_t_uint32 *bits1, *bits2;
- size_t count = 0, i;
+ scm_t_array_handle kv_handle;
+ size_t kv_off, kv_len;
+ ssize_t kv_inc;
+ const scm_t_uint32 *kv_bits;
+
+ kv_bits = scm_bitvector_elements (v, &kv_handle,
+ &kv_off, &kv_len, &kv_inc);
- if (scm_c_bitvector_length (v) != bit_len)
+ if (v_len != kv_len)
scm_misc_error (NULL,
"bit vectors must have equal length",
SCM_EOL);
- if (bit_len == 0)
- return scm_from_size_t (0);
-
- bits1 = scm_bitvector_elements (v);
- bits2 = scm_bitvector_elements (kv);
-
- for (i = 0; i < word_len-1; i++)
- count += count_ones ((bits1[i]^xor_mask) & bits2[i]);
- count += count_ones ((bits1[i]^xor_mask) & bits2[i] & last_mask);
-
- scm_bitvector_release_elements (kv);
- scm_bitvector_release_elements (v);
+ if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
+ {
+ size_t i, word_len = (kv_len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
+ scm_t_uint32 xor_mask = bit? 0 : ((scm_t_uint32)-1);
+
+ for (i = 0; i < word_len-1; i++)
+ count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i]);
+ count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i] & last_mask);
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < kv_len; i++)
+ if (scm_is_true (scm_array_handle_ref (&kv_handle, i)))
+ {
+ SCM elt = scm_array_handle_ref (&v_handle, i*v_inc);
+ if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
+ count++;
+ }
+ }
+
+ scm_array_handle_release (&kv_handle);
- return scm_from_size_t (count);
}
else if (scm_is_true (scm_u32vector_p (kv)))
{
- size_t count = 0, ulen, i;
- const scm_t_uint32 *indices;
- int bit = scm_to_bool (obj);
-
- scm_frame_begin (0);
+ scm_t_array_handle kv_handle;
+ size_t i, kv_len;
+ ssize_t kv_inc;
+ const scm_t_uint32 *kv_elts;
- ulen = scm_c_uniform_vector_length (kv);
- indices = scm_u32vector_elements (kv);
- scm_frame_uniform_vector_release_elements (kv);
-
- for (i = 0; i < ulen; i++)
- if ((scm_is_true (scm_c_bitvector_ref (v, (size_t)indices[i])) != 0)
- == (bit != 0))
- count++;
-
- scm_frame_end ();
+ kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
+ for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
+ {
+ SCM elt = scm_array_handle_ref (&v_handle, (*kv_elts)*v_inc);
+ if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
+ count++;
+ }
- return scm_from_size_t (count);
+ scm_array_handle_release (&kv_handle);
}
else
scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
+
+ scm_array_handle_release (&v_handle);
+
+ return scm_from_size_t (count);
}
#undef FUNC_NAME
-
SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
(SCM v),
"Modify the bit vector @var{v} by replacing each element with\n"
"its negation.")
#define FUNC_NAME s_scm_bit_invert_x
{
- size_t bit_len = scm_c_bitvector_length (v);
- size_t word_len = (bit_len + 31) / 32;
- scm_t_uint32 *bits = scm_bitvector_writable_elements (v);
- size_t i;
+ scm_t_array_handle handle;
+ size_t off, len;
+ ssize_t inc;
+ scm_t_uint32 *bits;
+
+ bits = scm_bitvector_writable_elements (v, &handle, &off, &len, &inc);
+
+ if (off == 0 && inc == 1 && len > 0)
+ {
+ size_t word_len = (len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
+ size_t i;
+
+ for (i = 0; i < word_len-1; i++)
+ bits[i] = ~bits[i];
+ bits[i] = bits[i] ^ last_mask;
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < len; i++)
+ scm_array_handle_set (&handle, i*inc,
+ scm_not (scm_array_handle_ref (&handle, i*inc)));
+ }
- for (i = 0; i < word_len; i++)
- bits[i] = ~bits[i];
+ scm_array_handle_release (&handle);
- scm_bitvector_release_writable_elements (v);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-SCM
+SCM
scm_istr2bve (SCM str)
{
+ scm_t_array_handle handle;
size_t len = scm_i_string_length (str);
SCM vec = scm_c_make_bitvector (len, SCM_UNDEFINED);
SCM res = vec;
scm_t_uint32 mask;
size_t k, j;
- const char *c_str = scm_i_string_chars (str);
- scm_t_uint32 *data = scm_bitvector_writable_elements (vec);
+ const char *c_str;
+ scm_t_uint32 *data;
+
+ data = scm_bitvector_writable_elements (vec, &handle, NULL, NULL, NULL);
+ c_str = scm_i_string_chars (str);
for (k = 0; k < (len + 31) / 32; k++)
{
}
exit:
+ scm_array_handle_release (&handle);
scm_remember_upto_here_1 (str);
- scm_bitvector_release_writable_elements (vec);
return res;
}
ra2l (SCM ra, unsigned long base, unsigned long k)
{
SCM res = SCM_EOL;
- long inc = SCM_ARRAY_DIMS (ra)[k].inc;
+ long inc;
size_t i;
- int enclosed = SCM_ENCLOSED_ARRAYP (ra);
+ int enclosed = SCM_I_ENCLOSED_ARRAYP (ra);
- if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd)
+ if (k == SCM_I_ARRAY_NDIM (ra))
+ return scm_i_cvref (SCM_I_ARRAY_V (ra), base, enclosed);
+
+ inc = SCM_I_ARRAY_DIMS (ra)[k].inc;
+ if (SCM_I_ARRAY_DIMS (ra)[k].ubnd < SCM_I_ARRAY_DIMS (ra)[k].lbnd)
return SCM_EOL;
- i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc;
- if (k < SCM_ARRAY_NDIM (ra) - 1)
+ i = base + (1 + SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * inc;
+ do
{
- do
- {
- i -= inc;
- res = scm_cons (ra2l (ra, i, k + 1), res);
- }
- while (i != base);
+ i -= inc;
+ res = scm_cons (ra2l (ra, i, k + 1), res);
}
- else
- do
- {
- i -= inc;
- res = scm_cons (scm_i_cvref (SCM_ARRAY_V (ra), i, enclosed),
- res);
- }
- while (i != base);
+ while (i != base);
return res;
}
{
if (scm_is_generalized_vector (v))
return scm_generalized_vector_to_list (v);
- else if (SCM_ARRAYP (v) || SCM_ENCLOSED_ARRAYP (v))
- return ra2l (v, SCM_ARRAY_BASE (v), 0);
+ else if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v))
+ return ra2l (v, SCM_I_ARRAY_BASE (v), 0);
scm_wrong_type_arg_msg (NULL, 0, v, "array");
}
#undef FUNC_NAME
-static int l2ra(SCM lst, SCM ra, unsigned long base, unsigned long k);
+static void l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k);
SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
- (SCM type, SCM ndim, SCM lst),
+ (SCM type, SCM shape, SCM lst),
"Return an array of the type @var{type}\n"
"with elements the same as those of @var{lst}.\n"
"\n"
- "The argument @var{ndim} determines the number of dimensions\n"
- "of the array. It is either an exact integer, giving the\n"
- "number directly, or a list of exact integers, whose length\n"
- "specifies the number of dimensions and each element is the\n"
- "lower index bound of its dimension.")
+ "The argument @var{shape} determines the number of dimensions\n"
+ "of the array and their shape. It is either an exact integer,\n"
+ "giving the\n"
+ "number of dimensions directly, or a list whose length\n"
+ "specifies the number of dimensions and each element specified\n"
+ "the lower and optionally the upper bound of the corresponding\n"
+ "dimension.\n"
+ "When the element is list of two elements, these elements\n"
+ "give the lower and upper bounds. When it is an exact\n"
+ "integer, it gives only the lower bound.")
#define FUNC_NAME s_scm_list_to_typed_array
{
- SCM shape, row;
+ SCM row;
SCM ra;
- unsigned long k;
+ scm_t_array_handle handle;
- shape = SCM_EOL;
row = lst;
- if (scm_is_integer (ndim))
+ if (scm_is_integer (shape))
{
- size_t k = scm_to_size_t (ndim);
+ size_t k = scm_to_size_t (shape);
+ shape = SCM_EOL;
while (k-- > 0)
{
shape = scm_cons (scm_length (row), shape);
- if (k > 0)
+ if (k > 0 && !scm_is_null (row))
row = scm_car (row);
}
}
else
{
+ SCM shape_spec = shape;
+ shape = SCM_EOL;
while (1)
{
- shape = scm_cons (scm_list_2 (scm_car (ndim),
- scm_sum (scm_sum (scm_car (ndim),
- scm_length (row)),
- scm_from_int (-1))),
- shape);
- ndim = scm_cdr (ndim);
- if (scm_is_pair (ndim))
- row = scm_car (row);
+ SCM spec = scm_car (shape_spec);
+ if (scm_is_pair (spec))
+ shape = scm_cons (spec, shape);
+ else
+ shape = scm_cons (scm_list_2 (spec,
+ scm_sum (scm_sum (spec,
+ scm_length (row)),
+ scm_from_int (-1))),
+ shape);
+ shape_spec = scm_cdr (shape_spec);
+ if (scm_is_pair (shape_spec))
+ {
+ if (!scm_is_null (row))
+ row = scm_car (row);
+ }
else
break;
}
}
- ra = scm_make_typed_array (type, SCM_BOOL_F, scm_reverse_x (shape, SCM_EOL));
+ ra = scm_make_typed_array (type, SCM_UNSPECIFIED,
+ scm_reverse_x (shape, SCM_EOL));
- if (scm_is_null (shape))
- {
- SCM_ASRTGO (1 == scm_ilength (lst), badlst);
- scm_array_set_x (ra, SCM_CAR (lst), SCM_EOL);
- return ra;
- }
- if (!SCM_ARRAYP (ra))
- {
- size_t length = scm_c_generalized_vector_length (ra);
- for (k = 0; k < length; k++, lst = SCM_CDR (lst))
- scm_c_generalized_vector_set_x (ra, k, SCM_CAR (lst));
- return ra;
- }
- if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0))
- return ra;
- else
- badlst:SCM_MISC_ERROR ("Bad scm_array contents list: ~S",
- scm_list_1 (lst));
+ scm_array_get_handle (ra, &handle);
+ l2ra (lst, &handle, 0, 0);
+ scm_array_handle_release (&handle);
+
+ return ra;
}
#undef FUNC_NAME
}
#undef FUNC_NAME
-static int
-l2ra (SCM lst, SCM ra, unsigned long base, unsigned long k)
+static void
+l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
{
- register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
- register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd);
- int ok = 1;
- if (n <= 0)
- return (scm_is_null (lst));
- if (k < SCM_ARRAY_NDIM (ra) - 1)
- {
- while (n--)
- {
- if (!scm_is_pair (lst))
- return 0;
- ok = ok && l2ra (SCM_CAR (lst), ra, base, k + 1);
- base += inc;
- lst = SCM_CDR (lst);
- }
- if (!scm_is_null (lst))
- return 0;
- }
+ if (k == scm_array_handle_rank (handle))
+ scm_array_handle_set (handle, pos, lst);
else
{
- while (n--)
+ scm_t_array_dim *dim = scm_array_handle_dims (handle) + k;
+ ssize_t inc = dim->inc;
+ size_t len = 1 + dim->ubnd - dim->lbnd, n;
+ char *errmsg = NULL;
+
+ n = len;
+ while (n > 0 && scm_is_pair (lst))
{
- if (!scm_is_pair (lst))
- return 0;
- scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), scm_from_ulong (base));
- base += inc;
+ l2ra (SCM_CAR (lst), handle, pos, k + 1);
+ pos += inc;
lst = SCM_CDR (lst);
+ n -= 1;
}
+ if (n != 0)
+ errmsg = "too few elements for array dimension ~a, need ~a";
if (!scm_is_null (lst))
- return 0;
+ errmsg = "too many elements for array dimension ~a, want ~a";
+ if (errmsg)
+ scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k),
+ scm_from_size_t (len)));
}
- return ok;
}
#if SCM_ENABLE_DEPRECATED
scm_i_print_array_dimension (SCM array, int dim, int base, int enclosed,
SCM port, scm_print_state *pstate)
{
- scm_t_array_dim *dim_spec = SCM_ARRAY_DIMS (array) + dim;
+ scm_t_array_dim *dim_spec = SCM_I_ARRAY_DIMS (array) + dim;
long idx;
scm_putc ('(', port);
for (idx = dim_spec->lbnd; idx <= dim_spec->ubnd; idx++)
{
- if (dim < SCM_ARRAY_NDIM(array)-1)
+ if (dim < SCM_I_ARRAY_NDIM(array)-1)
scm_i_print_array_dimension (array, dim+1, base, enclosed,
port, pstate);
else
- scm_iprin1 (scm_i_cvref (SCM_ARRAY_V (array), base, enclosed),
+ scm_iprin1 (scm_i_cvref (SCM_I_ARRAY_V (array), base, enclosed),
port, pstate);
if (idx < dim_spec->ubnd)
scm_putc (' ', port);
static int
scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
{
- long ndim = SCM_ARRAY_NDIM (array);
- scm_t_array_dim *dim_specs = SCM_ARRAY_DIMS (array);
- SCM v = SCM_ARRAY_V (array);
- unsigned long base = SCM_ARRAY_BASE (array);
+ long ndim = SCM_I_ARRAY_NDIM (array);
+ scm_t_array_dim *dim_specs = SCM_I_ARRAY_DIMS (array);
+ SCM v = SCM_I_ARRAY_V (array);
+ unsigned long base = SCM_I_ARRAY_BASE (array);
long i;
+ int print_lbnds = 0, zero_size = 0, print_lens = 0;
scm_putc ('#', port);
if (ndim != 1 || dim_specs[0].lbnd != 0)
scm_puts ("?", port);
for (i = 0; i < ndim; i++)
- if (dim_specs[i].lbnd != 0)
+ {
+ if (dim_specs[i].lbnd != 0)
+ print_lbnds = 1;
+ if (dim_specs[i].ubnd - dim_specs[i].lbnd + 1 == 0)
+ zero_size = 1;
+ else if (zero_size)
+ print_lens = 1;
+ }
+
+ if (print_lbnds || print_lens)
+ for (i = 0; i < ndim; i++)
{
- for (i = 0; i < ndim; i++)
+ if (print_lbnds)
{
scm_putc ('@', port);
- scm_uintprint (dim_specs[i].lbnd, 10, port);
+ scm_intprint (dim_specs[i].lbnd, 10, port);
+ }
+ if (print_lens)
+ {
+ scm_putc (':', port);
+ scm_intprint (dim_specs[i].ubnd - dim_specs[i].lbnd + 1,
+ 10, port);
}
- break;
}
- return scm_i_print_array_dimension (array, 0, base, 0, port, pstate);
+ if (ndim == 0)
+ {
+ /* Rank zero arrays, which are really just scalars, are printed
+ specially. The consequent way would be to print them as
+
+ #0 OBJ
+
+ where OBJ is the printed representation of the scalar, but we
+ print them instead as
+
+ #0(OBJ)
+
+ to make them look less strange.
+
+ Just printing them as
+
+ OBJ
+
+ would be correct in a way as well, but zero rank arrays are
+ not really the same as Scheme values since they are boxed and
+ can be modified with array-set!, say.
+ */
+ scm_putc ('(', port);
+ scm_iprin1 (scm_i_cvref (v, base, 0), port, pstate);
+ scm_putc (')', port);
+ return 1;
+ }
+ else
+ return scm_i_print_array_dimension (array, 0, base, 0, port, pstate);
}
static int
size_t base;
scm_putc ('#', port);
- base = SCM_ARRAY_BASE (array);
+ base = SCM_I_ARRAY_BASE (array);
scm_puts ("<enclosed-array ", port);
scm_i_print_array_dimension (array, 0, base, 1, port, pstate);
scm_putc ('>', port);
}
}
#endif
+
+ if (*tag == '\0')
+ return SCM_BOOL_T;
+ else
+ return scm_from_locale_symbol (tag);
+}
- return scm_from_locale_symbol (tag);
+static int
+read_decimal_integer (SCM port, int c, ssize_t *resp)
+{
+ ssize_t sign = 1;
+ ssize_t res = 0;
+ int got_it = 0;
+
+ if (c == '-')
+ {
+ sign = -1;
+ c = scm_getc (port);
+ }
+
+ while ('0' <= c && c <= '9')
+ {
+ res = 10*res + c-'0';
+ got_it = 1;
+ c = scm_getc (port);
+ }
+
+ if (got_it)
+ *resp = sign * res;
+ return c;
}
SCM
scm_i_read_array (SCM port, int c)
{
- size_t rank;
+ ssize_t rank;
int got_rank;
char tag[80];
int tag_len;
- SCM lower_bounds, elements;
+ SCM shape = SCM_BOOL_F, elements;
/* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
the array code can not deal with zero-length dimensions yet, and
goto continue_reading_tag;
}
- /* Read rank. We disallow arrays of rank zero since they do not
- seem to work reliably yet. */
- rank = 0;
- got_rank = 0;
- while ('0' <= c && c <= '9')
- {
- rank = 10*rank + c-'0';
- got_rank = 1;
- c = scm_getc (port);
- }
- if (!got_rank)
- rank = 1;
- else if (rank == 0)
- scm_i_input_error (NULL, port,
- "array rank must be positive", SCM_EOL);
+ /* Read rank.
+ */
+ rank = 1;
+ c = read_decimal_integer (port, c, &rank);
+ if (rank < 0)
+ scm_i_input_error (NULL, port, "array rank must be non-negative",
+ SCM_EOL);
- /* Read tag. */
+ /* Read tag.
+ */
tag_len = 0;
continue_reading_tag:
- while (c != EOF && c != '(' && c != '@' && tag_len < 80)
+ while (c != EOF && c != '(' && c != '@' && c != ':' && tag_len < 80)
{
tag[tag_len++] = c;
c = scm_getc (port);
}
tag[tag_len] = '\0';
- /* Read lower bounds. */
- lower_bounds = SCM_EOL;
- while (c == '@')
+ /* Read shape.
+ */
+ if (c == '@' || c == ':')
{
- /* Yeah, right, we should use some ready-made integer parsing
- routine for this...
- */
+ shape = SCM_EOL;
+
+ do
+ {
+ ssize_t lbnd = 0, len = 0;
+ SCM s;
- long lbnd = 0;
- long sign = 1;
+ if (c == '@')
+ {
+ c = scm_getc (port);
+ c = read_decimal_integer (port, c, &lbnd);
+ }
+
+ s = scm_from_ssize_t (lbnd);
- c = scm_getc (port);
- if (c == '-')
- {
- sign = -1;
- c = scm_getc (port);
- }
- while ('0' <= c && c <= '9')
- {
- lbnd = 10*lbnd + c-'0';
- c = scm_getc (port);
- }
- lower_bounds = scm_cons (scm_from_long (sign*lbnd), lower_bounds);
+ if (c == ':')
+ {
+ c = scm_getc (port);
+ c = read_decimal_integer (port, c, &len);
+ if (len < 0)
+ scm_i_input_error (NULL, port,
+ "array length must be non-negative",
+ SCM_EOL);
+
+ s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1));
+ }
+
+ shape = scm_cons (s, shape);
+ } while (c == '@' || c == ':');
+
+ shape = scm_reverse_x (shape, SCM_EOL);
}
/* Read nested lists of elements.
scm_ungetc (c, port);
elements = scm_read (port);
- if (scm_is_null (lower_bounds))
- lower_bounds = scm_from_size_t (rank);
- else if (scm_ilength (lower_bounds) != rank)
- scm_i_input_error (NULL, port,
- "the number of lower bounds must match the array rank",
- SCM_EOL);
+ if (scm_is_false (shape))
+ shape = scm_from_ssize_t (rank);
+ else if (scm_ilength (shape) != rank)
+ scm_i_input_error
+ (NULL, port,
+ "the number of shape specifications must match the array rank",
+ SCM_EOL);
- /* Construct array. */
- return scm_list_to_typed_array (tag_to_type (tag, port),
- lower_bounds,
- elements);
-}
+ /* Handle special print syntax of rank zero arrays; see
+ scm_i_print_array for a rationale.
+ */
+ if (rank == 0)
+ {
+ if (!scm_is_pair (elements))
+ scm_i_input_error (NULL, port,
+ "too few elements in array literal, need 1",
+ SCM_EOL);
+ if (!scm_is_null (SCM_CDR (elements)))
+ scm_i_input_error (NULL, port,
+ "too many elements in array literal, want 1",
+ SCM_EOL);
+ elements = SCM_CAR (elements);
+ }
-int
-scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
-{
- scm_iprin1 (exp, port, pstate);
- return 1;
+ /* Construct array.
+ */
+ return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements);
}
SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
"")
#define FUNC_NAME s_scm_array_type
{
- if (SCM_ARRAYP (ra))
- return scm_i_generalized_vector_type (SCM_ARRAY_V (ra));
+ if (SCM_I_ARRAYP (ra))
+ return scm_i_generalized_vector_type (SCM_I_ARRAY_V (ra));
else if (scm_is_generalized_vector (ra))
return scm_i_generalized_vector_type (ra);
- else if (SCM_ENCLOSED_ARRAYP (ra))
+ else if (SCM_I_ENCLOSED_ARRAYP (ra))
scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array");
else
scm_wrong_type_arg_msg (NULL, 0, ra, "array");
"@code{make-uniform-array}.")
#define FUNC_NAME s_scm_array_prototype
{
- if (SCM_ARRAYP (ra))
- return scm_i_get_old_prototype (SCM_ARRAY_V (ra));
+ if (SCM_I_ARRAYP (ra))
+ return scm_i_get_old_prototype (SCM_I_ARRAY_V (ra));
else if (scm_is_generalized_vector (ra))
return scm_i_get_old_prototype (ra);
- else if (SCM_ENCLOSED_ARRAYP (ra))
+ else if (SCM_I_ENCLOSED_ARRAYP (ra))
return SCM_UNSPECIFIED;
else
scm_wrong_type_arg_msg (NULL, 0, ra, "array");
#endif
-static SCM
-array_mark (SCM ptr)
+
+#if SCM_ENABLE_DEPRECATED
+
+SCM
+scm_make_ra (int ndim)
{
- return SCM_ARRAY_V (ptr);
+ scm_c_issue_deprecation_warning
+ ("scm_make_ra is deprecated. Use scm_make_array or similar instead.");
+ return scm_i_make_ra (ndim, 0);
}
-static size_t
-array_free (SCM ptr)
+SCM
+scm_shap2ra (SCM args, const char *what)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_shap2ra is deprecated. Use scm_make_array or similar instead.");
+ return scm_i_shap2ra (args);
+}
+
+SCM
+scm_cvref (SCM v, unsigned long pos, SCM last)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_cvref is deprecated. Use scm_c_generalized_vector_ref instead.");
+ return scm_c_generalized_vector_ref (v, pos);
+}
+
+void
+scm_ra_set_contp (SCM ra)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_ra_set_contp is deprecated. There should be no need for it.");
+ scm_i_ra_set_contp (ra);
+}
+
+long
+scm_aind (SCM ra, SCM args, const char *what)
{
- scm_gc_free (SCM_ARRAY_MEM (ptr),
- (sizeof (scm_t_array)
- + SCM_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)),
- "array");
- return 0;
+ scm_t_array_handle handle;
+ ssize_t pos;
+
+ scm_c_issue_deprecation_warning
+ ("scm_aind is deprecated. Use scm_array_handle_pos instead.");
+
+ if (scm_is_integer (args))
+ args = scm_list_1 (args);
+
+ scm_array_get_handle (ra, &handle);
+ pos = scm_array_handle_pos (&handle, args) + SCM_I_ARRAY_BASE (ra);
+ scm_array_handle_release (&handle);
+ return pos;
}
+int
+scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_raprin1 is deprecated. Use scm_display or scm_write instead.");
+
+ scm_iprin1 (exp, port, pstate);
+ return 1;
+}
+
+#endif
+
void
scm_init_unif ()
{
- scm_tc16_array = scm_make_smob_type ("array", 0);
- scm_set_smob_mark (scm_tc16_array, array_mark);
- scm_set_smob_free (scm_tc16_array, array_free);
- scm_set_smob_print (scm_tc16_array, scm_i_print_array);
- scm_set_smob_equalp (scm_tc16_array, scm_array_equal_p);
+ scm_i_tc16_array = scm_make_smob_type ("array", 0);
+ scm_set_smob_print (scm_i_tc16_array, scm_i_print_array);
+ scm_set_smob_equalp (scm_i_tc16_array, scm_array_equal_p);
- scm_tc16_enclosed_array = scm_make_smob_type ("enclosed-array", 0);
- scm_set_smob_mark (scm_tc16_enclosed_array, array_mark);
- scm_set_smob_free (scm_tc16_enclosed_array, array_free);
- scm_set_smob_print (scm_tc16_enclosed_array, scm_i_print_enclosed_array);
- scm_set_smob_equalp (scm_tc16_enclosed_array, scm_array_equal_p);
+ scm_i_tc16_enclosed_array = scm_make_smob_type ("enclosed-array", 0);
+ scm_set_smob_print (scm_i_tc16_enclosed_array, scm_i_print_enclosed_array);
+ scm_set_smob_equalp (scm_i_tc16_enclosed_array, scm_array_equal_p);
scm_add_feature ("array");
scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0);
- scm_set_smob_free (scm_tc16_bitvector, bitvector_free);
scm_set_smob_print (scm_tc16_bitvector, bitvector_print);
scm_set_smob_equalp (scm_tc16_bitvector, bitvector_equalp);
HCoop / bpt / guile.git / blobdiff