-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005,
+ * 2006, 2009, 2010, 2011, 2012, 2013, 2014 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
#include <stdio.h>
#include <errno.h>
#include <string.h>
+#include <assert.h>
#include "libguile/_scm.h"
#include "libguile/__scm.h"
(SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
-SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
+SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
(SCM ra),
"Return the root vector of a shared array.")
#define FUNC_NAME s_scm_shared_array_root
{
- if (SCM_I_ARRAYP (ra))
+ if (!scm_is_array (ra))
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
+ else if (SCM_I_ARRAYP (ra))
return SCM_I_ARRAY_V (ra);
- else if (scm_is_generalized_vector (ra))
+ else
return ra;
- scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME
-SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
+SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
(SCM ra),
"Return the root vector index of the first element in the array.")
#define FUNC_NAME s_scm_shared_array_offset
scm_make_generalized_vector (type, scm_from_size_t (rlen), fill);
if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
- if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
+ if (0 == s->lbnd)
return SCM_I_ARRAY_V (ra);
+
return ra;
}
#undef FUNC_NAME
}
else if (sz < 8)
{
- /* byte_len ?= ceil (rlen * sz / 8) */
- if (byte_len != (rlen * sz + 7) / 8)
+ /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
+ units. */
+ if (byte_len != ((rlen * sz + 31) / 32) * 4)
SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
}
else
memcpy (elts, 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))
+ if (0 == s->lbnd)
return SCM_I_ARRAY_V (ra);
return ra;
}
scm_array_handle_release (&h);
if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
- if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
+ if (0 == s->lbnd)
return SCM_I_ARRAY_V (ra);
return ra;
}
{
SCM_I_ARRAY_V (ra) = oldra;
old_base = old_min = 0;
- old_max = scm_c_generalized_vector_length (oldra) - 1;
+ old_max = scm_c_array_length (oldra) - 1;
}
inds = SCM_EOL;
if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
{
SCM v = SCM_I_ARRAY_V (ra);
- size_t length = scm_c_generalized_vector_length (v);
+ size_t length = scm_c_array_length (v);
if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
return v;
if (s->ubnd < s->lbnd)
SCM_VALIDATE_REST_ARGUMENT (args);
SCM_ASSERT (SCM_HEAP_OBJECT_P (ra), ra, SCM_ARG1, FUNC_NAME);
- if (scm_is_generalized_vector (ra))
+ switch (scm_c_array_rank (ra))
{
+ case 0:
+ if (!scm_is_null (args))
+ SCM_WRONG_NUM_ARGS ();
+ return ra;
+ case 1:
/* Make sure that we are called with a single zero as
- arguments.
+ arguments.
*/
if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
SCM_WRONG_NUM_ARGS ();
SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
return ra;
- }
-
- if (SCM_I_ARRAYP (ra))
- {
+ default:
vargs = scm_vector (args);
if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
SCM_WRONG_NUM_ARGS ();
scm_i_ra_set_contp (res);
return res;
}
-
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
}
#undef FUNC_NAME
return SCM_BOOL_F;
}
}
-
+
{
SCM v = SCM_I_ARRAY_V (ra);
- size_t length = scm_c_generalized_vector_length (v);
+ size_t length = scm_c_array_length (v);
if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc)
return v;
}
-
+
sra = scm_i_make_array (1);
SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
}
-/* Read an array. This function can also read vectors and uniform
- vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
- handled here.
-
- C is the first character read after the '#'.
-*/
-
-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_unlocked (port);
- }
-
- while ('0' <= c && c <= '9')
- {
- res = 10*res + c-'0';
- got_it = 1;
- c = scm_getc_unlocked (port);
- }
-
- if (got_it)
- *resp = sign * res;
- return c;
-}
-
-SCM
-scm_i_read_array (SCM port, int c)
-{
- ssize_t rank;
- scm_t_wchar tag_buf[8];
- int tag_len;
-
- SCM tag, 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
- we want to allow zero-length vectors, of course.
- */
- if (c == '(')
- {
- scm_ungetc_unlocked (c, port);
- return scm_vector (scm_read (port));
- }
-
- /* Disambiguate between '#f' and uniform floating point vectors.
- */
- if (c == 'f')
- {
- c = scm_getc_unlocked (port);
- if (c != '3' && c != '6')
- {
- if (c != EOF)
- scm_ungetc_unlocked (c, port);
- return SCM_BOOL_F;
- }
- rank = 1;
- tag_buf[0] = 'f';
- tag_len = 1;
- goto continue_reading_tag;
- }
-
- /* 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.
- */
- tag_len = 0;
- continue_reading_tag:
- while (c != EOF && c != '(' && c != '@' && c != ':'
- && tag_len < sizeof tag_buf / sizeof tag_buf[0])
- {
- tag_buf[tag_len++] = c;
- c = scm_getc_unlocked (port);
- }
- if (tag_len == 0)
- tag = SCM_BOOL_T;
- else
- {
- tag = scm_string_to_symbol (scm_from_utf32_stringn (tag_buf, tag_len));
- if (tag_len == sizeof tag_buf / sizeof tag_buf[0])
- scm_i_input_error (NULL, port, "invalid array tag, starting with: ~a",
- scm_list_1 (tag));
- }
-
- /* Read shape.
- */
- if (c == '@' || c == ':')
- {
- shape = SCM_EOL;
-
- do
- {
- ssize_t lbnd = 0, len = 0;
- SCM s;
-
- if (c == '@')
- {
- c = scm_getc_unlocked (port);
- c = read_decimal_integer (port, c, &lbnd);
- }
-
- s = scm_from_ssize_t (lbnd);
-
- if (c == ':')
- {
- c = scm_getc_unlocked (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.
- */
- if (c != '(')
- scm_i_input_error (NULL, port,
- "missing '(' in vector or array literal",
- SCM_EOL);
- scm_ungetc_unlocked (c, port);
- elements = scm_read (port);
-
- 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);
-
- /* 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);
- }
-
- /* Construct array.
- */
- return scm_list_to_typed_array (tag, shape, elements);
-}
-
-
static SCM
-array_handle_ref (scm_t_array_handle *h, size_t pos)
+array_handle_ref (scm_t_array_handle *hh, size_t pos)
{
- return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h->array), pos);
+ return scm_c_array_ref_1 (SCM_I_ARRAY_V (hh->array), pos);
}
static void
-array_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
+array_handle_set (scm_t_array_handle *hh, size_t pos, SCM val)
{
- scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h->array), pos, val);
+ scm_c_array_set_1_x (SCM_I_ARRAY_V (hh->array), val, pos);
}
/* FIXME: should be handle for vect? maybe not, because of dims */
{
scm_t_array_handle vh;
scm_array_get_handle (SCM_I_ARRAY_V (array), &vh);
+ assert (vh.dims[0].inc == 1 && vh.dims[0].lbnd == 0 && vh.base == 0);
h->element_type = vh.element_type;
h->elements = vh.elements;
h->writable_elements = vh.writable_elements;
HCoop / bpt / guile.git / blobdiff