[bpt/guile.git] / libguile / array-handle.c

/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005,
 * 2006, 2009, 2011, 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
 * 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
 * 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., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */


\f

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#include "libguile/_scm.h"
#include "libguile/__scm.h"

#include "libguile/array-handle.h"


SCM scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_LAST + 1];


/* Bytevectors as generalized vectors & arrays.  */

#define DEFINE_BYTEVECTOR_ACCESSORS(type, tag, infix)           \
  static SCM                                                    \
  bytevector_##tag##_ref (SCM bv, size_t pos)                   \
  {                                                             \
    SCM idx = scm_from_size_t (pos * sizeof (type));            \
    return scm_bytevector_##infix##_ref (bv, idx);              \
  }                                                             \
  static void                                                   \
  bytevector_##tag##_set (SCM bv, size_t pos, SCM val)          \
  {                                                             \
    SCM idx = scm_from_size_t (pos * sizeof (type));            \
    scm_bytevector_##infix##_set_x (bv, idx, val);              \
  }

DEFINE_BYTEVECTOR_ACCESSORS (uint8_t, u8, u8);
DEFINE_BYTEVECTOR_ACCESSORS (int8_t, s8, s8);
DEFINE_BYTEVECTOR_ACCESSORS (uint16_t, u16, u16_native);
DEFINE_BYTEVECTOR_ACCESSORS (int16_t, s16, s16_native);
DEFINE_BYTEVECTOR_ACCESSORS (uint32_t, u32, u32_native);
DEFINE_BYTEVECTOR_ACCESSORS (int32_t, s32, s32_native);
DEFINE_BYTEVECTOR_ACCESSORS (uint64_t, u64, u64_native);
DEFINE_BYTEVECTOR_ACCESSORS (int64_t, s64, s64_native);
DEFINE_BYTEVECTOR_ACCESSORS (float, f32, ieee_single_native);
DEFINE_BYTEVECTOR_ACCESSORS (double, f64, ieee_double_native);

/* Since these functions are only called by Guile's C code, we can abort
   instead of throwing if there is an error.  */
static SCM
bytevector_c32_ref (SCM bv, size_t pos)
{
  char *c_bv;
  float real, imag;

  if (!SCM_BYTEVECTOR_P (bv))
    abort ();
  c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
  pos *= 2 * sizeof (float);
  if (pos + 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
    abort ();

  memcpy (&real, &c_bv[pos], sizeof (float));
  memcpy (&imag, &c_bv[pos + sizeof (float)], sizeof (float));
  return scm_c_make_rectangular (real, imag);
}

static SCM
bytevector_c64_ref (SCM bv, size_t pos)
{
  char *c_bv;
  double real, imag;

  if (!SCM_BYTEVECTOR_P (bv))
    abort ();
  c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
  pos *= 2 * sizeof (double);
  if (pos + 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
    abort ();

  memcpy (&real, &c_bv[pos], sizeof (double));
  memcpy (&imag, &c_bv[pos + sizeof (double)], sizeof (double));
  return scm_c_make_rectangular (real, imag);
}

static void
bytevector_c32_set (SCM bv, size_t pos, SCM val)
{
  char *c_bv;
  float real, imag;

  if (!SCM_BYTEVECTOR_P (bv))
    abort ();
  c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
  pos *= 2 * sizeof (float);
  if (pos + 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
    abort ();

  real = scm_c_real_part (val);
  imag = scm_c_imag_part (val);
  memcpy (&c_bv[pos], &real, sizeof (float));
  memcpy (&c_bv[pos + sizeof (float)], &imag, sizeof (float));
}

static void
bytevector_c64_set (SCM bv, size_t pos, SCM val)
{
  char *c_bv;
  double real, imag;

  if (!SCM_BYTEVECTOR_P (bv))
    abort ();
  c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
  pos *= 2 * sizeof (double);
  if (pos + 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
    abort ();

  real = scm_c_real_part (val);
  imag = scm_c_imag_part (val);
  memcpy (&c_bv[pos], &real, sizeof (double));
  memcpy (&c_bv[pos + sizeof (double)], &imag, sizeof (double));
}

static void
initialize_vector_handle (scm_t_array_handle *h, size_t len,
                          scm_t_array_element_type element_type,
                          scm_t_vector_ref vref, scm_t_vector_set vset,
                          void *writable_elements)
{
  h->base = 0;
  h->ndims = 1;
  h->dims = &h->dim0;
  h->dim0.lbnd = 0;
  h->dim0.ubnd = (ssize_t) (len - 1U);
  h->dim0.inc = 1;
  h->element_type = element_type;
  h->elements = h->writable_elements = writable_elements;
  h->vector = h->array;
  h->vref = vref;
  h->vset = vset;
}

void
scm_array_get_handle (SCM array, scm_t_array_handle *h)
{
  if (!SCM_HEAP_OBJECT_P (array))
    scm_wrong_type_arg_msg (NULL, 0, array, "array");

  h->array = array;

  switch (SCM_TYP7 (array))
    {
    case scm_tc7_string:
      initialize_vector_handle (h, scm_c_string_length (array),
                                SCM_ARRAY_ELEMENT_TYPE_CHAR,
                                scm_c_string_ref, scm_c_string_set_x,
                                NULL);
      break;
    case scm_tc7_vector:
      initialize_vector_handle (h, scm_c_vector_length (array),
                                SCM_ARRAY_ELEMENT_TYPE_SCM,
                                scm_c_vector_ref, scm_c_vector_set_x,
                                SCM_I_VECTOR_WELTS (array));
      break;
    case scm_tc7_bitvector:
      initialize_vector_handle (h, scm_c_bitvector_length (array),
                                SCM_ARRAY_ELEMENT_TYPE_BIT,
                                scm_c_bitvector_ref, scm_c_bitvector_set_x,
                                scm_i_bitvector_bits (array));
      break;
    case scm_tc7_bytevector:
      {
        size_t byte_length, length, element_byte_size;
        scm_t_array_element_type element_type;
        scm_t_vector_ref vref;
        scm_t_vector_set vset;

        byte_length = scm_c_bytevector_length (array);
        element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (array);
        element_byte_size = scm_i_array_element_type_sizes[element_type] / 8;
        length = byte_length / element_byte_size;

        switch (element_type)
          {
#define ACCESSOR_CASE(tag, TAG)                 \
          case SCM_ARRAY_ELEMENT_TYPE_##TAG:    \
            vref = bytevector_##tag##_ref;      \
            vset = bytevector_##tag##_set;      \
            break

          case SCM_ARRAY_ELEMENT_TYPE_VU8:
          ACCESSOR_CASE(u8, U8);
          ACCESSOR_CASE(s8, S8);
          ACCESSOR_CASE(u16, U16);
          ACCESSOR_CASE(s16, S16);
          ACCESSOR_CASE(u32, U32);
          ACCESSOR_CASE(s32, S32);
          ACCESSOR_CASE(u64, U64);
          ACCESSOR_CASE(s64, S64);
          ACCESSOR_CASE(f32, F32);
          ACCESSOR_CASE(f64, F64);
          ACCESSOR_CASE(c32, C32);
          ACCESSOR_CASE(c64, C64);

          case SCM_ARRAY_ELEMENT_TYPE_SCM:
          case SCM_ARRAY_ELEMENT_TYPE_BIT:
          case SCM_ARRAY_ELEMENT_TYPE_CHAR:
          default:
            abort ();

#undef ACCESSOR_CASE
          }

        initialize_vector_handle (h, length, element_type, vref, vset,
                                  SCM_BYTEVECTOR_CONTENTS (array));
      }
      break;
    case scm_tc7_array:
      scm_array_get_handle (SCM_I_ARRAY_V (array), h);
      h->array = array;
      h->base = SCM_I_ARRAY_BASE (array);
      h->ndims = SCM_I_ARRAY_NDIM (array);
      h->dims = SCM_I_ARRAY_DIMS (array);
      break;
    default:
      scm_wrong_type_arg_msg (NULL, 0, array, "array");
    }
}

ssize_t
scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
{
  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))
    {
      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 (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 void
check_array_index_bounds (scm_t_array_dim *dim, ssize_t idx)
{
  if (idx < dim->lbnd || idx > dim->ubnd)
    scm_error (scm_out_of_range_key, NULL, "Value out of range ~S to ~S: ~S",
               scm_list_3 (scm_from_ssize_t (dim->lbnd),
                           scm_from_ssize_t (dim->ubnd),
                           scm_from_ssize_t (idx)),
               scm_list_1 (scm_from_ssize_t (idx)));
}

ssize_t
scm_array_handle_pos_1 (scm_t_array_handle *h, ssize_t idx0)
{
  scm_t_array_dim *dim = scm_array_handle_dims (h);

  if (scm_array_handle_rank (h) != 1)
    scm_misc_error (NULL, "wrong number of indices, expecting ~A",
		    scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));

  check_array_index_bounds (&dim[0], idx0);

  return (idx0 - dim[0].lbnd) * dim[0].inc;
}

ssize_t
scm_array_handle_pos_2 (scm_t_array_handle *h, ssize_t idx0, ssize_t idx1)
{
  scm_t_array_dim *dim = scm_array_handle_dims (h);

  if (scm_array_handle_rank (h) != 2)
    scm_misc_error (NULL, "wrong number of indices, expecting ~A",
		    scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));

  check_array_index_bounds (&dim[0], idx0);
  check_array_index_bounds (&dim[1], idx1);

  return ((idx0 - dim[0].lbnd) * dim[0].inc
          + (idx1 - dim[1].lbnd) * dim[1].inc);
}

SCM
scm_array_handle_element_type (scm_t_array_handle *h)
{
  if (h->element_type < 0 || h->element_type > SCM_ARRAY_ELEMENT_TYPE_LAST)
    abort (); /* guile programming error */
  return scm_i_array_element_types[h->element_type];
}

void
scm_array_handle_release (scm_t_array_handle *h)
{
  /* Nothing to do here until arrays need to be reserved for real.
   */
}

const SCM *
scm_array_handle_elements (scm_t_array_handle *h)
{
  if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
    scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
  return ((const SCM*)h->elements) + h->base;
}

SCM *
scm_array_handle_writable_elements (scm_t_array_handle *h)
{
  if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
    scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
  return ((SCM*)h->elements) + h->base;
}

void
scm_init_array_handle (void)
{
#define DEFINE_ARRAY_TYPE(tag, TAG)                             \
  scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] = scm_from_utf8_symbol (#tag)
  
  scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T;
  DEFINE_ARRAY_TYPE (a, CHAR);
  DEFINE_ARRAY_TYPE (b, BIT);
  DEFINE_ARRAY_TYPE (vu8, VU8);
  DEFINE_ARRAY_TYPE (u8, U8);
  DEFINE_ARRAY_TYPE (s8, S8);
  DEFINE_ARRAY_TYPE (u16, U16);
  DEFINE_ARRAY_TYPE (s16, S16);
  DEFINE_ARRAY_TYPE (u32, U32);
  DEFINE_ARRAY_TYPE (s32, S32);
  DEFINE_ARRAY_TYPE (u64, U64);
  DEFINE_ARRAY_TYPE (s64, S64);
  DEFINE_ARRAY_TYPE (f32, F32);
  DEFINE_ARRAY_TYPE (f64, F64);
  DEFINE_ARRAY_TYPE (c32, C32);
  DEFINE_ARRAY_TYPE (c64, C64);

#include "libguile/array-handle.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/
Commit	Line	Data
9b977c83	1	/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005,
7070f12b	2	* 2006, 2009, 2011, 2013, 2014 Free Software Foundation, Inc.
c53c0893 AW	3	*
	4	* This library is free software; you can redistribute it and/or
	5	* modify it under the terms of the GNU Lesser General Public License
	6	* as published by the Free Software Foundation; either version 3 of
	7	* the License, or (at your option) any later version.
	8	*
	9	* This library is distributed in the hope that it will be useful, but
	10	* WITHOUT ANY WARRANTY; without even the implied warranty of
	11	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	12	* Lesser General Public License for more details.
	13	*
	14	* You should have received a copy of the GNU Lesser General Public
	15	* License along with this library; if not, write to the Free Software
	16	* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
	17	* 02110-1301 USA
	18	*/
	19
	20
	21	\f
	22
	23	#ifdef HAVE_CONFIG_H
	24	# include <config.h>
	25	#endif
	26
	27	#include "libguile/_scm.h"
	28	#include "libguile/__scm.h"
	29
	30	#include "libguile/array-handle.h"
c53c0893 AW	31
c53c0893 AW	32
2a610be5	33	SCM scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_LAST + 1];
c53c0893	34
c53c0893	35
cf64dca6	36	/* Bytevectors as generalized vectors & arrays. */
c53c0893	37
cf64dca6 AW	38	#define DEFINE_BYTEVECTOR_ACCESSORS(type, tag, infix) \
	39	static SCM \
	40	bytevector_##tag##_ref (SCM bv, size_t pos) \
	41	{ \
	42	SCM idx = scm_from_size_t (pos * sizeof (type)); \
	43	return scm_bytevector_##infix##_ref (bv, idx); \
	44	} \
	45	static void \
	46	bytevector_##tag##_set (SCM bv, size_t pos, SCM val) \
	47	{ \
	48	SCM idx = scm_from_size_t (pos * sizeof (type)); \
	49	scm_bytevector_##infix##_set_x (bv, idx, val); \
	50	}
c53c0893	51
cf64dca6 AW	52	DEFINE_BYTEVECTOR_ACCESSORS (uint8_t, u8, u8);
	53	DEFINE_BYTEVECTOR_ACCESSORS (int8_t, s8, s8);
	54	DEFINE_BYTEVECTOR_ACCESSORS (uint16_t, u16, u16_native);
	55	DEFINE_BYTEVECTOR_ACCESSORS (int16_t, s16, s16_native);
	56	DEFINE_BYTEVECTOR_ACCESSORS (uint32_t, u32, u32_native);
	57	DEFINE_BYTEVECTOR_ACCESSORS (int32_t, s32, s32_native);
	58	DEFINE_BYTEVECTOR_ACCESSORS (uint64_t, u64, u64_native);
	59	DEFINE_BYTEVECTOR_ACCESSORS (int64_t, s64, s64_native);
	60	DEFINE_BYTEVECTOR_ACCESSORS (float, f32, ieee_single_native);
	61	DEFINE_BYTEVECTOR_ACCESSORS (double, f64, ieee_double_native);
	62
	63	/* Since these functions are only called by Guile's C code, we can abort
	64	instead of throwing if there is an error. */
	65	static SCM
	66	bytevector_c32_ref (SCM bv, size_t pos)
	67	{
	68	char *c_bv;
	69	float real, imag;
	70
	71	if (!SCM_BYTEVECTOR_P (bv))
	72	abort ();
	73	c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
	74	pos = 2 sizeof (float);
	75	if (pos + 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
	76	abort ();
	77
	78	memcpy (&real, &c_bv[pos], sizeof (float));
	79	memcpy (&imag, &c_bv[pos + sizeof (float)], sizeof (float));
	80	return scm_c_make_rectangular (real, imag);
	81	}
	82
	83	static SCM
	84	bytevector_c64_ref (SCM bv, size_t pos)
c53c0893	85	{
cf64dca6 AW	86	char *c_bv;
	87	double real, imag;
	88
	89	if (!SCM_BYTEVECTOR_P (bv))
2a610be5	90	abort ();
cf64dca6 AW	91	c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
	92	pos = 2 sizeof (double);
	93	if (pos + 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
	94	abort ();
	95
	96	memcpy (&real, &c_bv[pos], sizeof (double));
	97	memcpy (&imag, &c_bv[pos + sizeof (double)], sizeof (double));
	98	return scm_c_make_rectangular (real, imag);
c53c0893 AW	99	}
c53c0893 AW	100
cf64dca6 AW	101	static void
cf64dca6 AW	102	bytevector_c32_set (SCM bv, size_t pos, SCM val)
c53c0893	103	{
cf64dca6 AW	104	char *c_bv;
	105	float real, imag;
	106
	107	if (!SCM_BYTEVECTOR_P (bv))
	108	abort ();
	109	c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
	110	pos = 2 sizeof (float);
	111	if (pos + 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
	112	abort ();
	113
	114	real = scm_c_real_part (val);
	115	imag = scm_c_imag_part (val);
	116	memcpy (&c_bv[pos], &real, sizeof (float));
	117	memcpy (&c_bv[pos + sizeof (float)], &imag, sizeof (float));
	118	}
	119
	120	static void
	121	bytevector_c64_set (SCM bv, size_t pos, SCM val)
	122	{
	123	char *c_bv;
	124	double real, imag;
	125
	126	if (!SCM_BYTEVECTOR_P (bv))
	127	abort ();
	128	c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
	129	pos = 2 sizeof (double);
	130	if (pos + 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
	131	abort ();
	132
	133	real = scm_c_real_part (val);
	134	imag = scm_c_imag_part (val);
	135	memcpy (&c_bv[pos], &real, sizeof (double));
	136	memcpy (&c_bv[pos + sizeof (double)], &imag, sizeof (double));
	137	}
	138
	139	static void
	140	initialize_vector_handle (scm_t_array_handle *h, size_t len,
	141	scm_t_array_element_type element_type,
	142	scm_t_vector_ref vref, scm_t_vector_set vset,
	143	void *writable_elements)
	144	{
	145	h->base = 0;
	146	h->ndims = 1;
	147	h->dims = &h->dim0;
	148	h->dim0.lbnd = 0;
	149	h->dim0.ubnd = (ssize_t) (len - 1U);
	150	h->dim0.inc = 1;
	151	h->element_type = element_type;
	152	h->elements = h->writable_elements = writable_elements;
	153	h->vector = h->array;
	154	h->vref = vref;
	155	h->vset = vset;
c53c0893 AW	156	}
	157
	158	void
	159	scm_array_get_handle (SCM array, scm_t_array_handle *h)
	160	{
cf64dca6	161	if (!SCM_HEAP_OBJECT_P (array))
2a610be5	162	scm_wrong_type_arg_msg (NULL, 0, array, "array");
cf64dca6	163
c53c0893	164	h->array = array;
cf64dca6 AW	165
	166	switch (SCM_TYP7 (array))
	167	{
	168	case scm_tc7_string:
	169	initialize_vector_handle (h, scm_c_string_length (array),
	170	SCM_ARRAY_ELEMENT_TYPE_CHAR,
	171	scm_c_string_ref, scm_c_string_set_x,
	172	NULL);
	173	break;
	174	case scm_tc7_vector:
	175	initialize_vector_handle (h, scm_c_vector_length (array),
	176	SCM_ARRAY_ELEMENT_TYPE_SCM,
	177	scm_c_vector_ref, scm_c_vector_set_x,
	178	SCM_I_VECTOR_WELTS (array));
	179	break;
	180	case scm_tc7_bitvector:
	181	initialize_vector_handle (h, scm_c_bitvector_length (array),
	182	SCM_ARRAY_ELEMENT_TYPE_BIT,
	183	scm_c_bitvector_ref, scm_c_bitvector_set_x,
	184	scm_i_bitvector_bits (array));
	185	break;
	186	case scm_tc7_bytevector:
	187	{
	188	size_t byte_length, length, element_byte_size;
	189	scm_t_array_element_type element_type;
	190	scm_t_vector_ref vref;
	191	scm_t_vector_set vset;
	192
	193	byte_length = scm_c_bytevector_length (array);
	194	element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (array);
	195	element_byte_size = scm_i_array_element_type_sizes[element_type] / 8;
	196	length = byte_length / element_byte_size;
	197
	198	switch (element_type)
	199	{
	200	#define ACCESSOR_CASE(tag, TAG) \
	201	case SCM_ARRAY_ELEMENT_TYPE_##TAG: \
	202	vref = bytevector_##tag##_ref; \
	203	vset = bytevector_##tag##_set; \
	204	break
	205
	206	case SCM_ARRAY_ELEMENT_TYPE_VU8:
	207	ACCESSOR_CASE(u8, U8);
	208	ACCESSOR_CASE(s8, S8);
	209	ACCESSOR_CASE(u16, U16);
	210	ACCESSOR_CASE(s16, S16);
	211	ACCESSOR_CASE(u32, U32);
	212	ACCESSOR_CASE(s32, S32);
	213	ACCESSOR_CASE(u64, U64);
	214	ACCESSOR_CASE(s64, S64);
	215	ACCESSOR_CASE(f32, F32);
	216	ACCESSOR_CASE(f64, F64);
	217	ACCESSOR_CASE(c32, C32);
	218	ACCESSOR_CASE(c64, C64);
	219
	220	case SCM_ARRAY_ELEMENT_TYPE_SCM:
	221	case SCM_ARRAY_ELEMENT_TYPE_BIT:
	222	case SCM_ARRAY_ELEMENT_TYPE_CHAR:
	223	default:
	224	abort ();
	225
	226	#undef ACCESSOR_CASE
	227	}
	228
229	initialize_vector_handle (h, length, element_type, vref, vset,
230	SCM_BYTEVECTOR_CONTENTS (array));
231	}
232	break;
233	case scm_tc7_array:
4e915304 AW	234	scm_array_get_handle (SCM_I_ARRAY_V (array), h);
4e915304 AW	235	h->array = array;
cf64dca6 AW	236	h->base = SCM_I_ARRAY_BASE (array);
	237	h->ndims = SCM_I_ARRAY_NDIM (array);
	238	h->dims = SCM_I_ARRAY_DIMS (array);
cf64dca6 AW	239	break;
	240	default:
	241	scm_wrong_type_arg_msg (NULL, 0, array, "array");
	242	}
2a610be5 AW	243	}
	244
	245	ssize_t
	246	scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
	247	{
	248	scm_t_array_dim *s = scm_array_handle_dims (h);
	249	ssize_t pos = 0, i;
	250	size_t k = scm_array_handle_rank (h);
	251
	252	while (k > 0 && scm_is_pair (indices))
c53c0893	253	{
2a610be5 AW	254	i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd);
	255	pos += (i - s->lbnd) * s->inc;
	256	k--;
	257	s++;
	258	indices = SCM_CDR (indices);
c53c0893	259	}
2a610be5 AW	260	if (k > 0 \|\| !scm_is_null (indices))
	261	scm_misc_error (NULL, "wrong number of indices, expecting ~a",
	262	scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
	263	return pos;
	264	}
	265
336c9211 AW	266	static void
	267	check_array_index_bounds (scm_t_array_dim *dim, ssize_t idx)
	268	{
	269	if (idx < dim->lbnd \|\| idx > dim->ubnd)
	270	scm_error (scm_out_of_range_key, NULL, "Value out of range ~S to ~S: ~S",
	271	scm_list_3 (scm_from_ssize_t (dim->lbnd),
	272	scm_from_ssize_t (dim->ubnd),
	273	scm_from_ssize_t (idx)),
	274	scm_list_1 (scm_from_ssize_t (idx)));
	275	}
	276
	277	ssize_t
	278	scm_array_handle_pos_1 (scm_t_array_handle *h, ssize_t idx0)
	279	{
	280	scm_t_array_dim *dim = scm_array_handle_dims (h);
	281
	282	if (scm_array_handle_rank (h) != 1)
	283	scm_misc_error (NULL, "wrong number of indices, expecting ~A",
	284	scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
	285
	286	check_array_index_bounds (&dim[0], idx0);
	287
	288	return (idx0 - dim[0].lbnd) * dim[0].inc;
	289	}
	290
	291	ssize_t
	292	scm_array_handle_pos_2 (scm_t_array_handle *h, ssize_t idx0, ssize_t idx1)
	293	{
	294	scm_t_array_dim *dim = scm_array_handle_dims (h);
	295
	296	if (scm_array_handle_rank (h) != 2)
	297	scm_misc_error (NULL, "wrong number of indices, expecting ~A",
	298	scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
	299
	300	check_array_index_bounds (&dim[0], idx0);
	301	check_array_index_bounds (&dim[1], idx1);
	302
	303	return ((idx0 - dim[0].lbnd) * dim[0].inc
	304	+ (idx1 - dim[1].lbnd) * dim[1].inc);
	305	}
	306
2a610be5 AW	307	SCM
	308	scm_array_handle_element_type (scm_t_array_handle *h)
	309	{
	310	if (h->element_type < 0 \|\| h->element_type > SCM_ARRAY_ELEMENT_TYPE_LAST)
	311	abort (); /* guile programming error */
	312	return scm_i_array_element_types[h->element_type];
c53c0893 AW	313	}
	314
	315	void
	316	scm_array_handle_release (scm_t_array_handle *h)
	317	{
	318	/* Nothing to do here until arrays need to be reserved for real.
	319	*/
	320	}
	321
c53c0893 AW	322	const SCM *
	323	scm_array_handle_elements (scm_t_array_handle *h)
	324	{
2a610be5 AW	325	if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
	326	scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
	327	return ((const SCM*)h->elements) + h->base;
c53c0893 AW	328	}
	329
	330	SCM *
	331	scm_array_handle_writable_elements (scm_t_array_handle *h)
	332	{
2a610be5 AW	333	if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
	334	scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
	335	return ((SCM*)h->elements) + h->base;
c53c0893 AW	336	}
c53c0893 AW	337
c53c0893 AW	338	void
	339	scm_init_array_handle (void)
	340	{
2a610be5	341	#define DEFINE_ARRAY_TYPE(tag, TAG) \
25d50a05	342	scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] = scm_from_utf8_symbol (#tag)
2a610be5 AW	343
	344	scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T;
	345	DEFINE_ARRAY_TYPE (a, CHAR);
	346	DEFINE_ARRAY_TYPE (b, BIT);
	347	DEFINE_ARRAY_TYPE (vu8, VU8);
	348	DEFINE_ARRAY_TYPE (u8, U8);
	349	DEFINE_ARRAY_TYPE (s8, S8);
	350	DEFINE_ARRAY_TYPE (u16, U16);
	351	DEFINE_ARRAY_TYPE (s16, S16);
	352	DEFINE_ARRAY_TYPE (u32, U32);
	353	DEFINE_ARRAY_TYPE (s32, S32);
	354	DEFINE_ARRAY_TYPE (u64, U64);
	355	DEFINE_ARRAY_TYPE (s64, S64);
	356	DEFINE_ARRAY_TYPE (f32, F32);
	357	DEFINE_ARRAY_TYPE (f64, F64);
	358	DEFINE_ARRAY_TYPE (c32, C32);
	359	DEFINE_ARRAY_TYPE (c64, C64);
	360
c53c0893 AW	361	#include "libguile/array-handle.x"
	362	}
	363
	364	/*
	365	Local Variables:
	366	c-file-style: "gnu"
	367	End:
	368	*/