-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005 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
*/
\f
-#if HAVE_CONFIG_H
+#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
{
pos += h->base;
if (SCM_I_ARRAYP (h->array))
- return scm_c_string_set_x (SCM_I_ARRAY_V (h->array), pos, val);
+ scm_c_string_set_x (SCM_I_ARRAY_V (h->array), pos, val);
else
- return scm_c_string_set_x (h->array, pos, val);
+ scm_c_string_set_x (h->array, pos, val);
}
static void
pos += scm_array_handle_bit_elements_offset (h);
mask = 1l << (pos % 32);
if (scm_to_bool (val))
- ((scm_t_uint32 *)h->elements)[pos/32] |= mask;
+ ((scm_t_uint32 *)h->writable_elements)[pos/32] |= mask;
else
- ((scm_t_uint32 *)h->elements)[pos/32] &= ~mask;
+ ((scm_t_uint32 *)h->writable_elements)[pos/32] &= ~mask;
}
static void
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
SCM imap;
size_t k;
ssize_t i;
- long old_min, new_min, old_max, new_max;
+ long old_base, old_min, new_min, old_max, new_max;
scm_t_array_dim *s;
SCM_VALIDATE_REST_ARGUMENT (dims);
if (SCM_I_ARRAYP (oldra))
{
SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra);
- old_min = old_max = SCM_I_ARRAY_BASE (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--)
else
{
SCM_I_ARRAY_V (ra) = oldra;
- old_min = 0;
+ old_base = old_min = 0;
old_max = scm_c_generalized_vector_length (oldra) - 1;
}
imap = scm_apply_0 (mapfunc, scm_reverse (inds));
i = scm_array_handle_pos (&old_handle, imap);
- SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + SCM_I_ARRAY_BASE (oldra);
+ SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base;
indptr = inds;
k = SCM_I_ARRAY_NDIM (ra);
while (k--)
SCM_VALIDATE_REST_ARGUMENT (args);
- if (scm_is_generalized_vector (v))
+ if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (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_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v))
- {
- size_t k = SCM_I_ARRAY_NDIM (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");
#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)
}
if (got_it)
- *resp = res;
+ *resp = sign * res;
return 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));
}
#endif
-static SCM
-array_mark (SCM ptr)
-{
- return SCM_I_ARRAY_V (ptr);
-}
-
-static size_t
-array_free (SCM ptr)
-{
- scm_gc_free (SCM_I_ARRAY_MEM (ptr),
- (sizeof (scm_i_t_array)
- + SCM_I_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)),
- "array");
- return 0;
-}
#if SCM_ENABLE_DEPRECATED
scm_init_unif ()
{
scm_i_tc16_array = scm_make_smob_type ("array", 0);
- scm_set_smob_mark (scm_i_tc16_array, array_mark);
- scm_set_smob_free (scm_i_tc16_array, array_free);
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_i_tc16_enclosed_array = scm_make_smob_type ("enclosed-array", 0);
- scm_set_smob_mark (scm_i_tc16_enclosed_array, array_mark);
- scm_set_smob_free (scm_i_tc16_enclosed_array, array_free);
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