[bpt/guile.git] / libguile / generalized-arrays.c

/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 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 <stdio.h>
#include <errno.h>
#include <string.h>

#include "libguile/_scm.h"
#include "libguile/__scm.h"
#include "libguile/array-handle.h"
#include "libguile/generalized-arrays.h"


SCM_INTERNAL SCM scm_i_array_ref (SCM v,
                                  SCM idx0, SCM idx1, SCM idxN);
SCM_INTERNAL SCM scm_i_array_set_x (SCM v, SCM obj,
                                    SCM idx0, SCM idx1, SCM idxN);


int
scm_is_array (SCM obj)
{
  if (!SCM_HEAP_OBJECT_P (obj))
    return 0;

  switch (SCM_TYP7 (obj))
    {
    case scm_tc7_string:
    case scm_tc7_vector:
    case scm_tc7_bitvector:
    case scm_tc7_bytevector:
    case scm_tc7_array:
      return 1;
    default:
      return 0;
    }
}

SCM_DEFINE (scm_array_p_2, "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_2
{
  return scm_from_bool (scm_is_array (obj));
}
#undef FUNC_NAME

/* The array type predicate, with an extra argument kept for backward
   compatibility.  Note that we can't use `SCM_DEFINE' directly because there
   would be an argument count mismatch that would be caught by
   `snarf-check-and-output-texi.scm'.  */
SCM
scm_array_p (SCM obj, SCM unused)
{
  return scm_array_p_2 (obj);
}

int
scm_is_typed_array (SCM obj, SCM type)
{
  int ret = 0;
  if (scm_is_array (obj))
    {
      scm_t_array_handle h;

      scm_array_get_handle (obj, &h);
      ret = scm_is_eq (scm_array_handle_element_type (&h), type);
      scm_array_handle_release (&h);
    }

  return ret;
}

SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
           (SCM obj, SCM type),
	    "Return @code{#t} if the @var{obj} is an array of type\n"
	    "@var{type}, and @code{#f} if not.")
#define FUNC_NAME s_scm_typed_array_p
{
  return scm_from_bool (scm_is_typed_array (obj, type));
}
#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
{
  return scm_from_size_t (scm_c_array_rank (array));
}
#undef FUNC_NAME


size_t
scm_c_array_length (SCM array)
{
  scm_t_array_handle handle;
  size_t res;

  scm_array_get_handle (array, &handle);
  if (scm_array_handle_rank (&handle) < 1)
    {
      scm_array_handle_release (&handle);
      scm_wrong_type_arg_msg (NULL, 0, array, "array of nonzero rank");
    }
  res = handle.dims[0].ubnd - handle.dims[0].lbnd + 1;
  scm_array_handle_release (&handle);

  return res;
}

SCM_DEFINE (scm_array_length, "array-length", 1, 0, 0, 
           (SCM array),
	    "Return the length of an array: its first dimension.\n"
            "It is an error to ask for the length of an array of rank 0.")
#define FUNC_NAME s_scm_array_length
{
  return scm_from_size_t (scm_c_array_length (array));
}
#undef FUNC_NAME


SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, 
           (SCM ra),
	    "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
	    "elements with a @code{0} minimum with one greater than the maximum. So:\n"
	    "@lisp\n"
	    "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
	    "@end lisp")
#define FUNC_NAME s_scm_array_dimensions
{
  scm_t_array_handle handle;
  scm_t_array_dim *s;
  SCM res = SCM_EOL;
  size_t k;
      
  scm_array_get_handle (ra, &handle);
  s = scm_array_handle_dims (&handle);
  k = scm_array_handle_rank (&handle);

  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

SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0, 
           (SCM ra),
	    "")
#define FUNC_NAME s_scm_array_type
{
  scm_t_array_handle h;
  SCM type;

  scm_array_get_handle (ra, &h);
  type = scm_array_handle_element_type (&h);
  scm_array_handle_release (&h);
  
  return type;
}
#undef FUNC_NAME

SCM_DEFINE (scm_array_type_code,
            "array-type-code", 1, 0, 0,
	    (SCM array),
	    "Return the type of the elements in @var{array},\n"
            "as an integer code.")
#define FUNC_NAME s_scm_array_type_code
{
  scm_t_array_handle h;
  scm_t_array_element_type element_type;

  scm_array_get_handle (array, &h);
  element_type = h.element_type;
  scm_array_handle_release (&h);

  return scm_from_uint16 (element_type);
}
#undef FUNC_NAME

SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, 
           (SCM ra, SCM args),
	    "Return @code{#t} if its arguments would be acceptable to\n"
	    "@code{array-ref}.")
#define FUNC_NAME s_scm_array_in_bounds_p
{
  SCM res = SCM_BOOL_T;
  size_t k, ndim;
  scm_t_array_dim *s;
  scm_t_array_handle handle;

  SCM_VALIDATE_REST_ARGUMENT (args);

  scm_array_get_handle (ra, &handle);
  s = scm_array_handle_dims (&handle);
  ndim = scm_array_handle_rank (&handle);

  for (k = 0; k < ndim; k++)
    {
      long ind;

      if (!scm_is_pair (args))
        SCM_WRONG_NUM_ARGS ();
      ind = scm_to_long (SCM_CAR (args));
      args = SCM_CDR (args);

      if (ind < s[k].lbnd || ind > s[k].ubnd)
        {
          res = SCM_BOOL_F;
          /* We do not stop the checking after finding a violation
             since we want to validate the type-correctness and
             number of arguments in any case.
          */
        }
    }

  scm_array_handle_release (&handle);
  return res;
}
#undef FUNC_NAME


SCM
scm_c_array_ref_1 (SCM array, ssize_t idx0)
{
  scm_t_array_handle handle;
  SCM res;

  scm_array_get_handle (array, &handle);
  res = scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, idx0));
  scm_array_handle_release (&handle);
  return res;
}


SCM
scm_c_array_ref_2 (SCM array, ssize_t idx0, ssize_t idx1)
{
  scm_t_array_handle handle;
  SCM res;

  scm_array_get_handle (array, &handle);
  res = scm_array_handle_ref (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1));
  scm_array_handle_release (&handle);
  return res;
}


SCM
scm_array_ref (SCM v, SCM args)
{
  scm_t_array_handle handle;
  SCM res;

  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;
}


void
scm_c_array_set_1_x (SCM array, SCM obj, ssize_t idx0)
{
  scm_t_array_handle handle;

  scm_array_get_handle (array, &handle);
  scm_array_handle_set (&handle, scm_array_handle_pos_1 (&handle, idx0),
                        obj);
  scm_array_handle_release (&handle);
}


void
scm_c_array_set_2_x (SCM array, SCM obj, ssize_t idx0, ssize_t idx1)
{
  scm_t_array_handle handle;

  scm_array_get_handle (array, &handle);
  scm_array_handle_set (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1),
                        obj);
  scm_array_handle_release (&handle);
}


SCM
scm_array_set_x (SCM v, SCM obj, SCM args)
{
  scm_t_array_handle handle;

  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;
}


SCM_DEFINE (scm_i_array_ref, "array-ref", 1, 2, 1,
            (SCM v, SCM idx0, SCM idx1, SCM idxN),
	    "Return the element at the @code{(idx0, idx1, idxN...)}\n"
            "position in array @var{v}.")
#define FUNC_NAME s_scm_i_array_ref
{
  if (SCM_UNBNDP (idx0))
    return scm_array_ref (v, SCM_EOL);
  else if (SCM_UNBNDP (idx1))
    return scm_c_array_ref_1 (v, scm_to_ssize_t (idx0));
  else if (scm_is_null (idxN))
    return scm_c_array_ref_2 (v, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1));
  else
    return scm_array_ref (v, scm_cons (idx0, scm_cons (idx1, idxN)));
}
#undef FUNC_NAME


SCM_DEFINE (scm_i_array_set_x, "array-set!", 2, 2, 1,
            (SCM v, SCM obj, SCM idx0, SCM idx1, SCM idxN),
	    "Set the element at the @code{(idx0, idx1, idxN...)} position\n"
	    "in the array @var{v} to @var{obj}.  The value returned by\n"
            "@code{array-set!} is unspecified.")
#define FUNC_NAME s_scm_i_array_set_x
{
  if (SCM_UNBNDP (idx0))
    scm_array_set_x (v, obj, SCM_EOL);
  else if (SCM_UNBNDP (idx1))
    scm_c_array_set_1_x (v, obj, scm_to_ssize_t (idx0));
  else if (scm_is_null (idxN))
    scm_c_array_set_2_x (v, obj, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1));
  else
    scm_array_set_x (v, obj, scm_cons (idx0, scm_cons (idx1, idxN)));

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME


static SCM 
array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos)
{
  if (dim == scm_array_handle_rank (h))
    return scm_array_handle_ref (h, pos);
  else
    {
      SCM res = SCM_EOL;
      long inc;
      size_t i;

      i = h->dims[dim].ubnd - h->dims[dim].lbnd + 1;
      inc = h->dims[dim].inc;
      pos += (i - 1) * inc;

      for (; i > 0; i--, pos -= inc)
        res = scm_cons (array_to_list (h, dim + 1, pos), res);
      return res;
    }
}

SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, 
            (SCM array),
	    "Return a list representation of @var{array}.\n\n"
            "It is easiest to specify the behavior of this function by\n"
            "example:\n"
            "@example\n"
            "(array->list #0(a)) @result{} 1\n"
            "(array->list #1(a b)) @result{} (a b)\n"
            "(array->list #2((aa ab) (ba bb)) @result{} ((aa ab) (ba bb))\n"
            "@end example\n")
#define FUNC_NAME s_scm_array_to_list
{
  scm_t_array_handle h;
  SCM res;  
  
  scm_array_get_handle (array, &h);
  res = array_to_list (&h, 0, 0);
  scm_array_handle_release (&h);

  return res;
}
#undef FUNC_NAME

void
scm_init_generalized_arrays ()
{
#include "libguile/generalized-arrays.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/
Commit	Line	Data
8051cf23	1	/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2013, 2014 Free Software Foundation, Inc.
1030b450 AW	2	*
	3	* This library is free software; you can redistribute it and/or
	4	* modify it under the terms of the GNU Lesser General Public License
	5	* as published by the Free Software Foundation; either version 3 of
	6	* the License, or (at your option) any later version.
	7	*
	8	* This library is distributed in the hope that it will be useful, but
	9	* WITHOUT ANY WARRANTY; without even the implied warranty of
	10	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	11	* Lesser General Public License for more details.
	12	*
	13	* You should have received a copy of the GNU Lesser General Public
	14	* License along with this library; if not, write to the Free Software
	15	* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
	16	* 02110-1301 USA
	17	*/
	18
	19
	20	\f
	21
	22	#ifdef HAVE_CONFIG_H
	23	# include <config.h>
	24	#endif
	25
	26	#include <stdio.h>
	27	#include <errno.h>
	28	#include <string.h>
	29
	30	#include "libguile/_scm.h"
	31	#include "libguile/__scm.h"
	32	#include "libguile/array-handle.h"
	33	#include "libguile/generalized-arrays.h"
	34
	35
336c9211 AW	36	SCM_INTERNAL SCM scm_i_array_ref (SCM v,
	37	SCM idx0, SCM idx1, SCM idxN);
	38	SCM_INTERNAL SCM scm_i_array_set_x (SCM v, SCM obj,
	39	SCM idx0, SCM idx1, SCM idxN);
	40
	41
1030b450 AW	42	int
	43	scm_is_array (SCM obj)
	44	{
2b5625ad AW	45	if (!SCM_HEAP_OBJECT_P (obj))
	46	return 0;
	47
	48	switch (SCM_TYP7 (obj))
	49	{
	50	case scm_tc7_string:
	51	case scm_tc7_vector:
	52	case scm_tc7_bitvector:
	53	case scm_tc7_bytevector:
	54	case scm_tc7_array:
	55	return 1;
	56	default:
	57	return 0;
	58	}
1030b450 AW	59	}
1030b450 AW	60
ec370c6f LC	61	SCM_DEFINE (scm_array_p_2, "array?", 1, 0, 0,
ec370c6f LC	62	(SCM obj),
1030b450 AW	63	"Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
1030b450 AW	64	"not.")
61aab1c3	65	#define FUNC_NAME s_scm_array_p_2
1030b450 AW	66	{
	67	return scm_from_bool (scm_is_array (obj));
	68	}
	69	#undef FUNC_NAME
	70
ec370c6f LC	71	/* The array type predicate, with an extra argument kept for backward
	72	compatibility. Note that we can't use `SCM_DEFINE' directly because there
	73	would be an argument count mismatch that would be caught by
	74	`snarf-check-and-output-texi.scm'. */
	75	SCM
	76	scm_array_p (SCM obj, SCM unused)
	77	{
	78	return scm_array_p_2 (obj);
	79	}
	80
1030b450 AW	81	int
	82	scm_is_typed_array (SCM obj, SCM type)
	83	{
	84	int ret = 0;
2b5625ad	85	if (scm_is_array (obj))
1030b450 AW	86	{
	87	scm_t_array_handle h;
	88
	89	scm_array_get_handle (obj, &h);
	90	ret = scm_is_eq (scm_array_handle_element_type (&h), type);
	91	scm_array_handle_release (&h);
	92	}
	93
	94	return ret;
	95	}
	96
	97	SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
	98	(SCM obj, SCM type),
	99	"Return @code{#t} if the @var{obj} is an array of type\n"
	100	"@var{type}, and @code{#f} if not.")
	101	#define FUNC_NAME s_scm_typed_array_p
	102	{
	103	return scm_from_bool (scm_is_typed_array (obj, type));
	104	}
	105	#undef FUNC_NAME
	106
	107	size_t
	108	scm_c_array_rank (SCM array)
	109	{
	110	scm_t_array_handle handle;
	111	size_t res;
	112
	113	scm_array_get_handle (array, &handle);
	114	res = scm_array_handle_rank (&handle);
	115	scm_array_handle_release (&handle);
	116	return res;
	117	}
	118
	119	SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
	120	(SCM array),
	121	"Return the number of dimensions of the array @var{array.}\n")
	122	#define FUNC_NAME s_scm_array_rank
	123	{
	124	return scm_from_size_t (scm_c_array_rank (array));
	125	}
	126	#undef FUNC_NAME
	127
	128
118ff892 AW	129	size_t
	130	scm_c_array_length (SCM array)
	131	{
	132	scm_t_array_handle handle;
	133	size_t res;
	134
	135	scm_array_get_handle (array, &handle);
	136	if (scm_array_handle_rank (&handle) < 1)
	137	{
	138	scm_array_handle_release (&handle);
	139	scm_wrong_type_arg_msg (NULL, 0, array, "array of nonzero rank");
	140	}
	141	res = handle.dims[0].ubnd - handle.dims[0].lbnd + 1;
	142	scm_array_handle_release (&handle);
	143
	144	return res;
	145	}
	146
	147	SCM_DEFINE (scm_array_length, "array-length", 1, 0, 0,
	148	(SCM array),
73994167 DL	149	"Return the length of an array: its first dimension.\n"
73994167 DL	150	"It is an error to ask for the length of an array of rank 0.")
06589f5c	151	#define FUNC_NAME s_scm_array_length
118ff892 AW	152	{
	153	return scm_from_size_t (scm_c_array_length (array));
	154	}
	155	#undef FUNC_NAME
	156
	157
1030b450 AW	158	SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
	159	(SCM ra),
	160	"@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
	161	"elements with a @code{0} minimum with one greater than the maximum. So:\n"
	162	"@lisp\n"
	163	"(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
	164	"@end lisp")
	165	#define FUNC_NAME s_scm_array_dimensions
	166	{
	167	scm_t_array_handle handle;
	168	scm_t_array_dim *s;
	169	SCM res = SCM_EOL;
	170	size_t k;
	171
	172	scm_array_get_handle (ra, &handle);
	173	s = scm_array_handle_dims (&handle);
	174	k = scm_array_handle_rank (&handle);
	175
	176	while (k--)
	177	res = scm_cons (s[k].lbnd
	178	? scm_cons2 (scm_from_ssize_t (s[k].lbnd),
	179	scm_from_ssize_t (s[k].ubnd),
	180	SCM_EOL)
	181	: scm_from_ssize_t (1 + s[k].ubnd),
	182	res);
	183
	184	scm_array_handle_release (&handle);
	185	return res;
	186	}
	187	#undef FUNC_NAME
	188
1030b450 AW	189	SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
	190	(SCM ra),
	191	"")
	192	#define FUNC_NAME s_scm_array_type
	193	{
	194	scm_t_array_handle h;
	195	SCM type;
	196
1030b450 AW	197	scm_array_get_handle (ra, &h);
	198	type = scm_array_handle_element_type (&h);
	199	scm_array_handle_release (&h);
	200
	201	return type;
	202	}
	203	#undef FUNC_NAME
	204
8051cf23 AW	205	SCM_DEFINE (scm_array_type_code,
	206	"array-type-code", 1, 0, 0,
	207	(SCM array),
	208	"Return the type of the elements in @var{array},\n"
	209	"as an integer code.")
	210	#define FUNC_NAME s_scm_array_type_code
	211	{
	212	scm_t_array_handle h;
	213	scm_t_array_element_type element_type;
	214
	215	scm_array_get_handle (array, &h);
	216	element_type = h.element_type;
	217	scm_array_handle_release (&h);
	218
	219	return scm_from_uint16 (element_type);
	220	}
	221	#undef FUNC_NAME
	222
1030b450 AW	223	SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
	224	(SCM ra, SCM args),
	225	"Return @code{#t} if its arguments would be acceptable to\n"
	226	"@code{array-ref}.")
	227	#define FUNC_NAME s_scm_array_in_bounds_p
	228	{
	229	SCM res = SCM_BOOL_T;
	230	size_t k, ndim;
	231	scm_t_array_dim *s;
	232	scm_t_array_handle handle;
	233
	234	SCM_VALIDATE_REST_ARGUMENT (args);
	235
	236	scm_array_get_handle (ra, &handle);
	237	s = scm_array_handle_dims (&handle);
	238	ndim = scm_array_handle_rank (&handle);
	239
	240	for (k = 0; k < ndim; k++)
	241	{
	242	long ind;
	243
	244	if (!scm_is_pair (args))
	245	SCM_WRONG_NUM_ARGS ();
	246	ind = scm_to_long (SCM_CAR (args));
	247	args = SCM_CDR (args);
	248
	249	if (ind < s[k].lbnd \|\| ind > s[k].ubnd)
	250	{
	251	res = SCM_BOOL_F;
	252	/* We do not stop the checking after finding a violation
	253	since we want to validate the type-correctness and
	254	number of arguments in any case.
	255	*/
	256	}
	257	}
	258
	259	scm_array_handle_release (&handle);
	260	return res;
	261	}
	262	#undef FUNC_NAME
	263
336c9211 AW	264
	265	SCM
	266	scm_c_array_ref_1 (SCM array, ssize_t idx0)
	267	{
	268	scm_t_array_handle handle;
	269	SCM res;
	270
	271	scm_array_get_handle (array, &handle);
	272	res = scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, idx0));
	273	scm_array_handle_release (&handle);
	274	return res;
	275	}
	276
	277
	278	SCM
	279	scm_c_array_ref_2 (SCM array, ssize_t idx0, ssize_t idx1)
	280	{
	281	scm_t_array_handle handle;
	282	SCM res;
	283
	284	scm_array_get_handle (array, &handle);
	285	res = scm_array_handle_ref (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1));
	286	scm_array_handle_release (&handle);
	287	return res;
	288	}
	289
	290
	291	SCM
	292	scm_array_ref (SCM v, SCM args)
1030b450 AW	293	{
	294	scm_t_array_handle handle;
	295	SCM res;
	296
	297	scm_array_get_handle (v, &handle);
	298	res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args));
	299	scm_array_handle_release (&handle);
	300	return res;
	301	}
1030b450 AW	302
1030b450 AW	303
336c9211 AW	304	void
	305	scm_c_array_set_1_x (SCM array, SCM obj, ssize_t idx0)
	306	{
	307	scm_t_array_handle handle;
	308
	309	scm_array_get_handle (array, &handle);
	310	scm_array_handle_set (&handle, scm_array_handle_pos_1 (&handle, idx0),
	311	obj);
	312	scm_array_handle_release (&handle);
	313	}
	314
	315
	316	void
	317	scm_c_array_set_2_x (SCM array, SCM obj, ssize_t idx0, ssize_t idx1)
	318	{
	319	scm_t_array_handle handle;
	320
	321	scm_array_get_handle (array, &handle);
	322	scm_array_handle_set (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1),
	323	obj);
	324	scm_array_handle_release (&handle);
	325	}
	326
	327
	328	SCM
	329	scm_array_set_x (SCM v, SCM obj, SCM args)
1030b450 AW	330	{
	331	scm_t_array_handle handle;
	332
	333	scm_array_get_handle (v, &handle);
	334	scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj);
	335	scm_array_handle_release (&handle);
	336	return SCM_UNSPECIFIED;
	337	}
336c9211 AW	338
	339
	340	SCM_DEFINE (scm_i_array_ref, "array-ref", 1, 2, 1,
	341	(SCM v, SCM idx0, SCM idx1, SCM idxN),
	342	"Return the element at the @code{(idx0, idx1, idxN...)}\n"
	343	"position in array @var{v}.")
	344	#define FUNC_NAME s_scm_i_array_ref
	345	{
	346	if (SCM_UNBNDP (idx0))
	347	return scm_array_ref (v, SCM_EOL);
	348	else if (SCM_UNBNDP (idx1))
	349	return scm_c_array_ref_1 (v, scm_to_ssize_t (idx0));
	350	else if (scm_is_null (idxN))
	351	return scm_c_array_ref_2 (v, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1));
	352	else
	353	return scm_array_ref (v, scm_cons (idx0, scm_cons (idx1, idxN)));
	354	}
	355	#undef FUNC_NAME
	356
	357
	358	SCM_DEFINE (scm_i_array_set_x, "array-set!", 2, 2, 1,
	359	(SCM v, SCM obj, SCM idx0, SCM idx1, SCM idxN),
	360	"Set the element at the @code{(idx0, idx1, idxN...)} position\n"
	361	"in the array @var{v} to @var{obj}. The value returned by\n"
	362	"@code{array-set!} is unspecified.")
	363	#define FUNC_NAME s_scm_i_array_set_x
	364	{
	365	if (SCM_UNBNDP (idx0))
	366	scm_array_set_x (v, obj, SCM_EOL);
	367	else if (SCM_UNBNDP (idx1))
	368	scm_c_array_set_1_x (v, obj, scm_to_ssize_t (idx0));
	369	else if (scm_is_null (idxN))
	370	scm_c_array_set_2_x (v, obj, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1));
	371	else
	372	scm_array_set_x (v, obj, scm_cons (idx0, scm_cons (idx1, idxN)));
	373
	374	return SCM_UNSPECIFIED;
	375	}
1030b450 AW	376	#undef FUNC_NAME
1030b450 AW	377
336c9211	378
1030b450 AW	379	static SCM
	380	array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos)
	381	{
	382	if (dim == scm_array_handle_rank (h))
	383	return scm_array_handle_ref (h, pos);
	384	else
	385	{
	386	SCM res = SCM_EOL;
	387	long inc;
cf9a806d	388	size_t i;
1030b450	389
cf9a806d	390	i = h->dims[dim].ubnd - h->dims[dim].lbnd + 1;
1030b450	391	inc = h->dims[dim].inc;
cf9a806d	392	pos += (i - 1) * inc;
1030b450	393
cf9a806d	394	for (; i > 0; i--, pos -= inc)
1030b450 AW	395	res = scm_cons (array_to_list (h, dim + 1, pos), res);
	396	return res;
	397	}
	398	}
	399
	400	SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
	401	(SCM array),
e48a2f87 AW	402	"Return a list representation of @var{array}.\n\n"
	403	"It is easiest to specify the behavior of this function by\n"
	404	"example:\n"
	405	"@example\n"
	406	"(array->list #0(a)) @result{} 1\n"
	407	"(array->list #1(a b)) @result{} (a b)\n"
	408	"(array->list #2((aa ab) (ba bb)) @result{} ((aa ab) (ba bb))\n"
	409	"@end example\n")
1030b450 AW	410	#define FUNC_NAME s_scm_array_to_list
	411	{
	412	scm_t_array_handle h;
	413	SCM res;
	414
	415	scm_array_get_handle (array, &h);
	416	res = array_to_list (&h, 0, 0);
	417	scm_array_handle_release (&h);
	418
	419	return res;
	420	}
	421	#undef FUNC_NAME
	422
	423	void
	424	scm_init_generalized_arrays ()
	425	{
	426	#include "libguile/generalized-arrays.x"
	427	}
	428
	429	/*
	430	Local Variables:
	431	c-file-style: "gnu"
	432	End:
	433	*/