-/* 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, 2009 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
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* 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
#include "libguile/srfi-13.h"
#include "libguile/srfi-4.h"
#include "libguile/vectors.h"
+#include "libguile/bytevectors.h"
#include "libguile/list.h"
#include "libguile/deprecation.h"
#include "libguile/dynwind.h"
{ "f64", SCM_UNSPECIFIED, scm_make_f64vector },
{ "c32", SCM_UNSPECIFIED, scm_make_c32vector },
{ "c64", SCM_UNSPECIFIED, scm_make_c64vector },
+ { "vu8", SCM_UNSPECIFIED, scm_make_bytevector },
{ NULL }
};
scm_from_bool (((scm_t_uint32 *)h->elements)[pos/32] & (1l << (pos % 32)));
}
+static SCM
+bytevector_ref (scm_t_array_handle *h, ssize_t pos)
+{
+ return scm_from_uint8 (((scm_t_uint8 *) h->elements)[pos]);
+}
+
static SCM
memoize_ref (scm_t_array_handle *h, ssize_t pos)
{
h->elements = scm_array_handle_bit_elements (h);
h->ref = bitvector_ref;
}
+ else if (scm_is_bytevector (v))
+ {
+ h->elements = scm_array_handle_uniform_elements (h);
+ h->ref = bytevector_ref;
+ }
else
scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
{
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
+bytevector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
+{
+ scm_t_uint8 c_value;
+ scm_t_uint8 *elements;
+
+ c_value = scm_to_uint8 (val);
+ elements = (scm_t_uint8 *) h->elements;
+ elements[pos] = (scm_t_uint8) c_value;
}
static void
h->writable_elements = scm_array_handle_bit_writable_elements (h);
h->set = bitvector_set;
}
+ else if (scm_is_bytevector (v))
+ {
+ h->elements = scm_array_handle_uniform_writable_elements (h);
+ h->set = bytevector_set;
+ }
else
scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
}
#undef FUNC_NAME
+SCM
+scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
+ size_t byte_len)
+#define FUNC_NAME "scm_from_contiguous_typed_array"
+{
+ size_t k, rlen = 1;
+ scm_t_array_dim *s;
+ creator_proc *creator;
+ SCM ra;
+ scm_t_array_handle h;
+ void *base;
+ size_t sz;
+
+ creator = type_to_creator (type);
+ ra = scm_i_shap2ra (bounds);
+ SCM_SET_ARRAY_CONTIGUOUS_FLAG (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 + 1);
+ rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
+ }
+ SCM_I_ARRAY_V (ra) = creator (scm_from_size_t (rlen), SCM_UNDEFINED);
+
+
+ scm_array_get_handle (ra, &h);
+ base = scm_array_handle_uniform_writable_elements (&h);
+ sz = scm_array_handle_uniform_element_size (&h);
+ scm_array_handle_release (&h);
+
+ if (byte_len % sz)
+ SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL);
+ if (byte_len / sz != rlen)
+ SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
+
+ memcpy (base, bytes, byte_len);
+
+ 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_I_ARRAY_V (ra);
+ return ra;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
(SCM fill, SCM bounds),
"Create and return an array.")
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 (ra) = new_min = new_max = i + old_base;
indptr = inds;
k = SCM_I_ARRAY_NDIM (ra);
while (k--)
#define FUNC_NAME s_scm_enclose_array
{
SCM axv, res, ra_inr;
- const char *c_axv;
scm_t_array_dim vdim, *s = &vdim;
int ndim, j, k, ninr, noutr;
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);
for (j = 0, k = 0; k < noutr; k++, j++)
{
- while (c_axv[j])
+ while (!scm_i_string_ref (axv, j) == '\0')
j++;
SCM_I_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd;
SCM_I_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd;
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_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v))
+ 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");
SCM res = vec;
scm_t_uint32 mask;
- size_t k, j;
- const char *c_str;
+ size_t k, j, p;
scm_t_uint32 *data;
data = scm_bitvector_writable_elements (vec, &handle, NULL, NULL, NULL);
- c_str = scm_i_string_chars (str);
+ p = 0;
for (k = 0; k < (len + 31) / 32; k++)
{
data[k] = 0L;
if (j > 32)
j = 32;
for (mask = 1L; j--; mask <<= 1)
- switch (*c_str++)
+ switch (scm_i_string_ref (str, p++))
{
case '0':
break;
}
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));
}
args = scm_list_1 (args);
scm_array_get_handle (ra, &handle);
- pos = scm_array_handle_pos (&handle, args);
+ pos = scm_array_handle_pos (&handle, args) + SCM_I_ARRAY_BASE (ra);
scm_array_handle_release (&handle);
return pos;
}
HCoop / bpt / guile.git / blobdiff