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

/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2013 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)
{
  return scm_i_array_implementation_for_obj (obj) ? 1 : 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_i_array_implementation_for_obj (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_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
336c9211	1	/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2013 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	{
	45	return scm_i_array_implementation_for_obj (obj) ? 1 : 0;
	46	}
	47
ec370c6f LC	48	SCM_DEFINE (scm_array_p_2, "array?", 1, 0, 0,
ec370c6f LC	49	(SCM obj),
1030b450 AW	50	"Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
1030b450 AW	51	"not.")
61aab1c3	52	#define FUNC_NAME s_scm_array_p_2
1030b450 AW	53	{
	54	return scm_from_bool (scm_is_array (obj));
	55	}
	56	#undef FUNC_NAME
	57
ec370c6f LC	58	/* The array type predicate, with an extra argument kept for backward
	59	compatibility. Note that we can't use `SCM_DEFINE' directly because there
	60	would be an argument count mismatch that would be caught by
	61	`snarf-check-and-output-texi.scm'. */
	62	SCM
	63	scm_array_p (SCM obj, SCM unused)
	64	{
	65	return scm_array_p_2 (obj);
	66	}
	67
1030b450 AW	68	int
	69	scm_is_typed_array (SCM obj, SCM type)
	70	{
	71	int ret = 0;
	72	if (scm_i_array_implementation_for_obj (obj))
	73	{
	74	scm_t_array_handle h;
	75
	76	scm_array_get_handle (obj, &h);
	77	ret = scm_is_eq (scm_array_handle_element_type (&h), type);
	78	scm_array_handle_release (&h);
	79	}
	80
	81	return ret;
	82	}
	83
	84	SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
	85	(SCM obj, SCM type),
	86	"Return @code{#t} if the @var{obj} is an array of type\n"
	87	"@var{type}, and @code{#f} if not.")
	88	#define FUNC_NAME s_scm_typed_array_p
	89	{
	90	return scm_from_bool (scm_is_typed_array (obj, type));
	91	}
	92	#undef FUNC_NAME
	93
	94	size_t
	95	scm_c_array_rank (SCM array)
	96	{
	97	scm_t_array_handle handle;
	98	size_t res;
	99
	100	scm_array_get_handle (array, &handle);
	101	res = scm_array_handle_rank (&handle);
	102	scm_array_handle_release (&handle);
	103	return res;
	104	}
	105
	106	SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
	107	(SCM array),
	108	"Return the number of dimensions of the array @var{array.}\n")
	109	#define FUNC_NAME s_scm_array_rank
	110	{
	111	return scm_from_size_t (scm_c_array_rank (array));
	112	}
	113	#undef FUNC_NAME
	114
	115
118ff892 AW	116	size_t
	117	scm_c_array_length (SCM array)
	118	{
	119	scm_t_array_handle handle;
	120	size_t res;
	121
	122	scm_array_get_handle (array, &handle);
	123	if (scm_array_handle_rank (&handle) < 1)
	124	{
	125	scm_array_handle_release (&handle);
	126	scm_wrong_type_arg_msg (NULL, 0, array, "array of nonzero rank");
	127	}
	128	res = handle.dims[0].ubnd - handle.dims[0].lbnd + 1;
	129	scm_array_handle_release (&handle);
	130
	131	return res;
	132	}
	133
	134	SCM_DEFINE (scm_array_length, "array-length", 1, 0, 0,
	135	(SCM array),
73994167 DL	136	"Return the length of an array: its first dimension.\n"
73994167 DL	137	"It is an error to ask for the length of an array of rank 0.")
06589f5c	138	#define FUNC_NAME s_scm_array_length
118ff892 AW	139	{
	140	return scm_from_size_t (scm_c_array_length (array));
	141	}
	142	#undef FUNC_NAME
	143
	144
1030b450 AW	145	SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
	146	(SCM ra),
	147	"@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
	148	"elements with a @code{0} minimum with one greater than the maximum. So:\n"
	149	"@lisp\n"
	150	"(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
	151	"@end lisp")
	152	#define FUNC_NAME s_scm_array_dimensions
	153	{
	154	scm_t_array_handle handle;
	155	scm_t_array_dim *s;
	156	SCM res = SCM_EOL;
	157	size_t k;
	158
	159	scm_array_get_handle (ra, &handle);
	160	s = scm_array_handle_dims (&handle);
	161	k = scm_array_handle_rank (&handle);
	162
	163	while (k--)
	164	res = scm_cons (s[k].lbnd
	165	? scm_cons2 (scm_from_ssize_t (s[k].lbnd),
	166	scm_from_ssize_t (s[k].ubnd),
	167	SCM_EOL)
	168	: scm_from_ssize_t (1 + s[k].ubnd),
	169	res);
	170
	171	scm_array_handle_release (&handle);
	172	return res;
	173	}
	174	#undef FUNC_NAME
	175
1030b450 AW	176	SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
	177	(SCM ra),
	178	"")
	179	#define FUNC_NAME s_scm_array_type
	180	{
	181	scm_t_array_handle h;
	182	SCM type;
	183
1030b450 AW	184	scm_array_get_handle (ra, &h);
	185	type = scm_array_handle_element_type (&h);
	186	scm_array_handle_release (&h);
	187
	188	return type;
	189	}
	190	#undef FUNC_NAME
	191
	192	SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
	193	(SCM ra, SCM args),
	194	"Return @code{#t} if its arguments would be acceptable to\n"
	195	"@code{array-ref}.")
	196	#define FUNC_NAME s_scm_array_in_bounds_p
	197	{
	198	SCM res = SCM_BOOL_T;
	199	size_t k, ndim;
	200	scm_t_array_dim *s;
	201	scm_t_array_handle handle;
	202
	203	SCM_VALIDATE_REST_ARGUMENT (args);
	204
	205	scm_array_get_handle (ra, &handle);
	206	s = scm_array_handle_dims (&handle);
	207	ndim = scm_array_handle_rank (&handle);
	208
	209	for (k = 0; k < ndim; k++)
	210	{
	211	long ind;
	212
	213	if (!scm_is_pair (args))
	214	SCM_WRONG_NUM_ARGS ();
	215	ind = scm_to_long (SCM_CAR (args));
	216	args = SCM_CDR (args);
	217
	218	if (ind < s[k].lbnd \|\| ind > s[k].ubnd)
	219	{
	220	res = SCM_BOOL_F;
	221	/* We do not stop the checking after finding a violation
	222	since we want to validate the type-correctness and
	223	number of arguments in any case.
	224	*/
	225	}
	226	}
	227
	228	scm_array_handle_release (&handle);
	229	return res;
	230	}
	231	#undef FUNC_NAME
	232
336c9211 AW	233
	234	SCM
	235	scm_c_array_ref_1 (SCM array, ssize_t idx0)
	236	{
	237	scm_t_array_handle handle;
	238	SCM res;
	239
	240	scm_array_get_handle (array, &handle);
	241	res = scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, idx0));
	242	scm_array_handle_release (&handle);
	243	return res;
	244	}
	245
	246
	247	SCM
	248	scm_c_array_ref_2 (SCM array, ssize_t idx0, ssize_t idx1)
	249	{
	250	scm_t_array_handle handle;
	251	SCM res;
	252
	253	scm_array_get_handle (array, &handle);
	254	res = scm_array_handle_ref (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1));
	255	scm_array_handle_release (&handle);
	256	return res;
	257	}
	258
	259
	260	SCM
	261	scm_array_ref (SCM v, SCM args)
1030b450 AW	262	{
	263	scm_t_array_handle handle;
	264	SCM res;
	265
	266	scm_array_get_handle (v, &handle);
	267	res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args));
	268	scm_array_handle_release (&handle);
	269	return res;
	270	}
1030b450 AW	271
1030b450 AW	272
336c9211 AW	273	void
	274	scm_c_array_set_1_x (SCM array, SCM obj, ssize_t idx0)
	275	{
	276	scm_t_array_handle handle;
	277
	278	scm_array_get_handle (array, &handle);
	279	scm_array_handle_set (&handle, scm_array_handle_pos_1 (&handle, idx0),
	280	obj);
	281	scm_array_handle_release (&handle);
	282	}
	283
	284
	285	void
	286	scm_c_array_set_2_x (SCM array, SCM obj, ssize_t idx0, ssize_t idx1)
	287	{
	288	scm_t_array_handle handle;
	289
	290	scm_array_get_handle (array, &handle);
	291	scm_array_handle_set (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1),
	292	obj);
	293	scm_array_handle_release (&handle);
	294	}
	295
	296
	297	SCM
	298	scm_array_set_x (SCM v, SCM obj, SCM args)
1030b450 AW	299	{
	300	scm_t_array_handle handle;
	301
	302	scm_array_get_handle (v, &handle);
	303	scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj);
	304	scm_array_handle_release (&handle);
	305	return SCM_UNSPECIFIED;
	306	}
336c9211 AW	307
	308
	309	SCM_DEFINE (scm_i_array_ref, "array-ref", 1, 2, 1,
	310	(SCM v, SCM idx0, SCM idx1, SCM idxN),
	311	"Return the element at the @code{(idx0, idx1, idxN...)}\n"
	312	"position in array @var{v}.")
	313	#define FUNC_NAME s_scm_i_array_ref
	314	{
	315	if (SCM_UNBNDP (idx0))
	316	return scm_array_ref (v, SCM_EOL);
	317	else if (SCM_UNBNDP (idx1))
	318	return scm_c_array_ref_1 (v, scm_to_ssize_t (idx0));
	319	else if (scm_is_null (idxN))
	320	return scm_c_array_ref_2 (v, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1));
	321	else
	322	return scm_array_ref (v, scm_cons (idx0, scm_cons (idx1, idxN)));
	323	}
	324	#undef FUNC_NAME
	325
	326
	327	SCM_DEFINE (scm_i_array_set_x, "array-set!", 2, 2, 1,
	328	(SCM v, SCM obj, SCM idx0, SCM idx1, SCM idxN),
	329	"Set the element at the @code{(idx0, idx1, idxN...)} position\n"
	330	"in the array @var{v} to @var{obj}. The value returned by\n"
	331	"@code{array-set!} is unspecified.")
	332	#define FUNC_NAME s_scm_i_array_set_x
	333	{
	334	if (SCM_UNBNDP (idx0))
	335	scm_array_set_x (v, obj, SCM_EOL);
	336	else if (SCM_UNBNDP (idx1))
	337	scm_c_array_set_1_x (v, obj, scm_to_ssize_t (idx0));
	338	else if (scm_is_null (idxN))
	339	scm_c_array_set_2_x (v, obj, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1));
	340	else
	341	scm_array_set_x (v, obj, scm_cons (idx0, scm_cons (idx1, idxN)));
	342
	343	return SCM_UNSPECIFIED;
	344	}
1030b450 AW	345	#undef FUNC_NAME
1030b450 AW	346
336c9211	347
1030b450 AW	348	static SCM
	349	array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos)
	350	{
	351	if (dim == scm_array_handle_rank (h))
	352	return scm_array_handle_ref (h, pos);
	353	else
	354	{
	355	SCM res = SCM_EOL;
	356	long inc;
cf9a806d	357	size_t i;
1030b450	358
cf9a806d	359	i = h->dims[dim].ubnd - h->dims[dim].lbnd + 1;
1030b450	360	inc = h->dims[dim].inc;
cf9a806d	361	pos += (i - 1) * inc;
1030b450	362
cf9a806d	363	for (; i > 0; i--, pos -= inc)
1030b450 AW	364	res = scm_cons (array_to_list (h, dim + 1, pos), res);
	365	return res;
	366	}
	367	}
	368
	369	SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
	370	(SCM array),
e48a2f87 AW	371	"Return a list representation of @var{array}.\n\n"
	372	"It is easiest to specify the behavior of this function by\n"
	373	"example:\n"
	374	"@example\n"
	375	"(array->list #0(a)) @result{} 1\n"
	376	"(array->list #1(a b)) @result{} (a b)\n"
	377	"(array->list #2((aa ab) (ba bb)) @result{} ((aa ab) (ba bb))\n"
	378	"@end example\n")
1030b450 AW	379	#define FUNC_NAME s_scm_array_to_list
	380	{
	381	scm_t_array_handle h;
	382	SCM res;
	383
	384	scm_array_get_handle (array, &h);
	385	res = array_to_list (&h, 0, 0);
	386	scm_array_handle_release (&h);
	387
	388	return res;
	389	}
	390	#undef FUNC_NAME
	391
	392	void
	393	scm_init_generalized_arrays ()
	394	{
	395	#include "libguile/generalized-arrays.x"
	396	}
	397
	398	/*
	399	Local Variables:
	400	c-file-style: "gnu"
	401	End:
	402	*/