mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
move generic array foo out to its own file
* libguile/arrays.h: * libguile/arrays.c: * libguile/generalized-arrays.h: * libguile/generalized-arrays.c: Move some generic functionality out of arrays.c to a new file. * libguile/array-map.c: * libguile/deprecated.c: * libguile/init.c: Update includers.
This commit is contained in:
Andy Wingo
parent
66b9d7d304
commit
1030b45049
9 changed files with 355 additions and 272 deletions
|
|
@ -54,6 +54,7 @@ extern "C" {
|
|||
#include "libguile/futures.h"
|
||||
#include "libguile/gc.h"
|
||||
#include "libguile/gdbint.h"
|
||||
#include "libguile/generalized-arrays.h"
|
||||
#include "libguile/goops.h"
|
||||
#include "libguile/gsubr.h"
|
||||
#include "libguile/guardians.h"
|
||||
|
|
|
|||
|
|
@ -143,6 +143,7 @@ libguile_la_SOURCES = \
|
|||
gc_os_dep.c \
|
||||
gdbint.c \
|
||||
gettext.c \
|
||||
generalized-arrays.c \
|
||||
goops.c \
|
||||
gsubr.c \
|
||||
guardians.c \
|
||||
|
|
@ -250,6 +251,7 @@ DOT_X_FILES = \
|
|||
gc-segment.x \
|
||||
gc.x \
|
||||
gettext.x \
|
||||
generalized-arrays.x \
|
||||
goops.x \
|
||||
gsubr.x \
|
||||
guardians.x \
|
||||
|
|
@ -348,6 +350,7 @@ DOT_DOC_FILES = \
|
|||
gc-segment.doc \
|
||||
gc.doc \
|
||||
gettext.doc \
|
||||
generalized-arrays.doc \
|
||||
goops.doc \
|
||||
gsubr.doc \
|
||||
guardians.doc \
|
||||
|
|
@ -490,6 +493,7 @@ modinclude_HEADERS = \
|
|||
gdb_interface.h \
|
||||
gdbint.h \
|
||||
gettext.h \
|
||||
generalized-arrays.h \
|
||||
goops.h \
|
||||
gsubr.h \
|
||||
guardians.h \
|
||||
|
|
|
|||
|
|
@ -38,6 +38,7 @@
|
|||
#include "libguile/bitvectors.h"
|
||||
#include "libguile/srfi-4.h"
|
||||
#include "libguile/dynwind.h"
|
||||
#include "libguile/generalized-arrays.h"
|
||||
|
||||
#include "libguile/validate.h"
|
||||
#include "libguile/array-map.h"
|
||||
|
|
|
|||
|
|
@ -17,13 +17,6 @@
|
|||
*/
|
||||
|
||||
|
||||
/*
|
||||
This file has code for arrays in lots of variants (double, integer,
|
||||
unsigned etc. ). It suffers from hugely repetitive code because
|
||||
there is similar (but different) code for every variant included. (urg.)
|
||||
|
||||
--hwn
|
||||
*/
|
||||
|
||||
|
||||
#ifdef HAVE_CONFIG_H
|
||||
|
|
@ -54,6 +47,7 @@
|
|||
|
||||
#include "libguile/validate.h"
|
||||
#include "libguile/arrays.h"
|
||||
#include "libguile/generalized-arrays.h"
|
||||
#include "libguile/array-map.h"
|
||||
#include "libguile/print.h"
|
||||
#include "libguile/read.h"
|
||||
|
|
@ -145,107 +139,6 @@ make_typed_vector (SCM type, size_t len)
|
|||
return creator (scm_from_size_t (len), SCM_UNDEFINED);
|
||||
}
|
||||
|
||||
int
|
||||
scm_is_array (SCM obj)
|
||||
{
|
||||
return (SCM_I_ARRAYP (obj)
|
||||
|| scm_is_generalized_vector (obj));
|
||||
}
|
||||
|
||||
int
|
||||
scm_is_typed_array (SCM obj, SCM type)
|
||||
{
|
||||
/* Get storage vector.
|
||||
*/
|
||||
if (SCM_I_ARRAYP (obj))
|
||||
obj = SCM_I_ARRAY_V (obj);
|
||||
|
||||
/* It must be a generalized vector (which includes vectors, strings, etc).
|
||||
*/
|
||||
if (!scm_is_generalized_vector (obj))
|
||||
return 0;
|
||||
|
||||
return scm_is_eq (type, scm_i_generalized_vector_type (obj));
|
||||
}
|
||||
|
||||
/* We keep the old 2-argument C prototype for a while although the old
|
||||
PROT argument is always ignored now. C code should probably use
|
||||
scm_is_array or scm_is_typed_array anyway.
|
||||
*/
|
||||
|
||||
SCM_DEFINE (scm_array_p, "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
|
||||
{
|
||||
return scm_from_bool (scm_is_array (obj));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
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
|
||||
|
||||
|
||||
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_shared_array_root, "shared-array-root", 1, 0, 0,
|
||||
(SCM ra),
|
||||
|
|
@ -679,97 +572,6 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
|
||||
(SCM v, 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;
|
||||
|
||||
SCM_VALIDATE_REST_ARGUMENT (args);
|
||||
|
||||
if (SCM_I_ARRAYP (v))
|
||||
{
|
||||
size_t k, ndim = SCM_I_ARRAY_NDIM (v);
|
||||
scm_t_array_dim *s = SCM_I_ARRAY_DIMS (v);
|
||||
|
||||
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.
|
||||
*/
|
||||
}
|
||||
}
|
||||
}
|
||||
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");
|
||||
|
||||
if (!scm_is_null (args))
|
||||
SCM_WRONG_NUM_ARGS ();
|
||||
|
||||
return res;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
|
||||
(SCM v, SCM args),
|
||||
"Return the element at the @code{(index1, index2)} element in\n"
|
||||
"@var{array}.")
|
||||
#define FUNC_NAME s_scm_array_ref
|
||||
{
|
||||
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;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
|
||||
(SCM v, SCM obj, SCM args),
|
||||
"Set the element at the @code{(index1, index2)} element in @var{array} to\n"
|
||||
"@var{new-value}. The value returned by array-set! is unspecified.")
|
||||
#define FUNC_NAME s_scm_array_set_x
|
||||
{
|
||||
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;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
/* attempts to unroll an array into a one-dimensional array.
|
||||
returns the unrolled array or #f if it can't be done. */
|
||||
/* if strict is not SCM_UNDEFINED, return #f if returned array
|
||||
|
|
@ -975,46 +777,6 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
|
|||
#undef FUNC_NAME
|
||||
|
||||
|
||||
static SCM
|
||||
ra2l (SCM ra, unsigned long base, unsigned long k)
|
||||
{
|
||||
SCM res = SCM_EOL;
|
||||
long inc;
|
||||
size_t i;
|
||||
|
||||
if (k == SCM_I_ARRAY_NDIM (ra))
|
||||
return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (ra), base);
|
||||
|
||||
inc = SCM_I_ARRAY_DIMS (ra)[k].inc;
|
||||
if (SCM_I_ARRAY_DIMS (ra)[k].ubnd < SCM_I_ARRAY_DIMS (ra)[k].lbnd)
|
||||
return SCM_EOL;
|
||||
i = base + (1 + SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * inc;
|
||||
do
|
||||
{
|
||||
i -= inc;
|
||||
res = scm_cons (ra2l (ra, i, k + 1), res);
|
||||
}
|
||||
while (i != base);
|
||||
return res;
|
||||
}
|
||||
|
||||
|
||||
SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
|
||||
(SCM v),
|
||||
"Return a list consisting of all the elements, in order, of\n"
|
||||
"@var{array}.")
|
||||
#define FUNC_NAME s_scm_array_to_list
|
||||
{
|
||||
if (scm_is_generalized_vector (v))
|
||||
return scm_generalized_vector_to_list (v);
|
||||
else if (SCM_I_ARRAYP (v))
|
||||
return ra2l (v, SCM_I_ARRAY_BASE (v), 0);
|
||||
|
||||
scm_wrong_type_arg_msg (NULL, 0, v, "array");
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
static void l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k);
|
||||
|
||||
SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
|
||||
|
|
@ -1410,19 +1172,6 @@ scm_i_read_array (SCM port, int c)
|
|||
return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements);
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
|
||||
(SCM ra),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_array_type
|
||||
{
|
||||
if (SCM_I_ARRAYP (ra))
|
||||
return scm_i_generalized_vector_type (SCM_I_ARRAY_V (ra));
|
||||
else if (scm_is_generalized_vector (ra))
|
||||
return scm_i_generalized_vector_type (ra);
|
||||
else
|
||||
scm_wrong_type_arg_msg (NULL, 0, ra, "array");
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
static SCM
|
||||
array_mark (SCM ptr)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
/* classes: h_files */
|
||||
|
||||
#ifndef SCM_UNIF_H
|
||||
#define SCM_UNIF_H
|
||||
#ifndef SCM_ARRAY_H
|
||||
#define SCM_ARRAY_H
|
||||
|
||||
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
|
||||
*
|
||||
|
|
@ -25,47 +25,33 @@
|
|||
|
||||
#include "libguile/__scm.h"
|
||||
#include "libguile/print.h"
|
||||
#include "libguile/array-handle.h"
|
||||
|
||||
|
||||
|
||||
/* This file contains the definitions for arrays and bit vectors.
|
||||
Uniform numeric vectors are now in srfi-4.c.
|
||||
*/
|
||||
/* Multidimensional arrays. Woo hoo!
|
||||
Also see ....
|
||||
*/
|
||||
|
||||
|
||||
/** Arrays */
|
||||
|
||||
SCM_API SCM scm_array_p (SCM v);
|
||||
SCM_API SCM scm_typed_array_p (SCM v, SCM type);
|
||||
SCM_API SCM scm_make_array (SCM fill, SCM bounds);
|
||||
SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds);
|
||||
SCM_API SCM scm_from_contiguous_typed_array (SCM type, SCM bounds,
|
||||
const void *bytes,
|
||||
size_t byte_len);
|
||||
SCM_API SCM scm_array_rank (SCM ra);
|
||||
SCM_API size_t scm_c_array_rank (SCM ra);
|
||||
SCM_API SCM scm_array_dimensions (SCM ra);
|
||||
SCM_API SCM scm_shared_array_root (SCM ra);
|
||||
SCM_API SCM scm_shared_array_offset (SCM ra);
|
||||
SCM_API SCM scm_shared_array_increments (SCM ra);
|
||||
SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims);
|
||||
SCM_API SCM scm_transpose_array (SCM ra, SCM args);
|
||||
SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args);
|
||||
SCM_API SCM scm_array_ref (SCM v, SCM args);
|
||||
SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args);
|
||||
SCM_API SCM scm_array_contents (SCM ra, SCM strict);
|
||||
SCM_API SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd,
|
||||
SCM start, SCM end);
|
||||
SCM_API SCM scm_uniform_array_write (SCM v, SCM port_or_fd,
|
||||
SCM start, SCM end);
|
||||
SCM_API SCM scm_array_to_list (SCM v);
|
||||
SCM_API SCM scm_list_to_array (SCM ndim, SCM lst);
|
||||
SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);
|
||||
SCM_API SCM scm_array_type (SCM ra);
|
||||
|
||||
SCM_API int scm_is_array (SCM obj);
|
||||
SCM_API int scm_is_typed_array (SCM obj, SCM type);
|
||||
|
||||
SCM_API SCM scm_ra2contig (SCM ra, int copy);
|
||||
|
||||
|
|
@ -96,7 +82,7 @@ SCM_INTERNAL SCM scm_i_read_array (SCM port, int c);
|
|||
|
||||
SCM_INTERNAL void scm_init_arrays (void);
|
||||
|
||||
#endif /* SCM_UNIF_H */
|
||||
#endif /* SCM_ARRAYS_H */
|
||||
|
||||
/*
|
||||
Local Variables:
|
||||
|
|
|
|||
|
|
@ -34,6 +34,7 @@
|
|||
#include "libguile/strings.h"
|
||||
#include "libguile/srfi-13.h"
|
||||
#include "libguile/modules.h"
|
||||
#include "libguile/generalized-arrays.h"
|
||||
#include "libguile/eval.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/procprop.h"
|
||||
|
|
|
|||
276
libguile/generalized-arrays.c
Normal file
276
libguile/generalized-arrays.c
Normal file
|
|
@ -0,0 +1,276 @@
|
|||
/* 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 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
|
||||
*/
|
||||
|
||||
|
||||
|
||||
|
||||
#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"
|
||||
|
||||
|
||||
int
|
||||
scm_is_array (SCM obj)
|
||||
{
|
||||
return scm_i_array_implementation_for_obj (obj) ? 1 : 0;
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_array_p, "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
|
||||
{
|
||||
return scm_from_bool (scm_is_array (obj));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
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
|
||||
|
||||
|
||||
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
|
||||
|
||||
/* HACK*/
|
||||
#include "libguile/bytevectors.h"
|
||||
|
||||
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;
|
||||
|
||||
/* a hack, until srfi-4 and bytevectors are reunited */
|
||||
if (scm_is_bytevector (ra))
|
||||
return scm_from_locale_symbol ("vu8");
|
||||
|
||||
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_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
|
||||
(SCM v, SCM args),
|
||||
"Return the element at the @code{(index1, index2)} element in\n"
|
||||
"@var{array}.")
|
||||
#define FUNC_NAME s_scm_array_ref
|
||||
{
|
||||
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;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
|
||||
(SCM v, SCM obj, SCM args),
|
||||
"Set the element at the @code{(index1, index2)} element in @var{array} to\n"
|
||||
"@var{new-value}. The value returned by array-set! is unspecified.")
|
||||
#define FUNC_NAME s_scm_array_set_x
|
||||
{
|
||||
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;
|
||||
}
|
||||
#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, lbnd;
|
||||
|
||||
i = h->dims[dim].ubnd;
|
||||
lbnd = h->dims[dim].lbnd;
|
||||
inc = h->dims[dim].inc;
|
||||
pos += (i - h->dims[dim].ubnd) * inc;
|
||||
|
||||
for (; i >= lbnd; 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),
|
||||
"FIXME description a list consisting of all the elements, in order, of\n"
|
||||
"@var{array}.")
|
||||
#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:
|
||||
*/
|
||||
63
libguile/generalized-arrays.h
Normal file
63
libguile/generalized-arrays.h
Normal file
|
|
@ -0,0 +1,63 @@
|
|||
/* classes: h_files */
|
||||
|
||||
#ifndef SCM_GENERALIZED_ARRAYS_H
|
||||
#define SCM_GENERALIZED_ARRAYS_H
|
||||
|
||||
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 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 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
|
||||
*/
|
||||
|
||||
|
||||
|
||||
#include "libguile/__scm.h"
|
||||
#include "libguile/array-handle.h"
|
||||
|
||||
|
||||
|
||||
/* These functions operate on all kinds of arrays that Guile knows about.
|
||||
*/
|
||||
|
||||
|
||||
/** Arrays */
|
||||
|
||||
SCM_API int scm_is_array (SCM obj);
|
||||
SCM_API SCM scm_array_p (SCM v);
|
||||
|
||||
SCM_API int scm_is_typed_array (SCM obj, SCM type);
|
||||
SCM_API SCM scm_typed_array_p (SCM v, SCM type);
|
||||
|
||||
SCM_API size_t scm_c_array_rank (SCM ra);
|
||||
SCM_API SCM scm_array_rank (SCM ra);
|
||||
|
||||
SCM_API SCM scm_array_dimensions (SCM ra);
|
||||
SCM_API SCM scm_array_type (SCM ra);
|
||||
SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args);
|
||||
|
||||
SCM_API SCM scm_array_ref (SCM v, SCM args);
|
||||
SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args);
|
||||
SCM_API SCM scm_array_to_list (SCM v);
|
||||
|
||||
SCM_INTERNAL void scm_init_generalized_arrays (void);
|
||||
|
||||
|
||||
#endif /* SCM_GENERALIZED_ARRAYS_H */
|
||||
|
||||
/*
|
||||
Local Variables:
|
||||
c-file-style: "gnu"
|
||||
End:
|
||||
*/
|
||||
|
|
@ -63,6 +63,7 @@
|
|||
#include "libguile/futures.h"
|
||||
#include "libguile/gc.h"
|
||||
#include "libguile/gdbint.h"
|
||||
#include "libguile/generalized-arrays.h"
|
||||
#include "libguile/goops.h"
|
||||
#include "libguile/gsubr.h"
|
||||
#include "libguile/hash.h"
|
||||
|
|
@ -542,6 +543,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
|
|||
scm_init_debug (); /* Requires macro smobs */
|
||||
scm_init_random ();
|
||||
scm_init_array_handle ();
|
||||
scm_init_generalized_arrays ();
|
||||
scm_init_bitvectors ();
|
||||
scm_init_array_map ();
|
||||
scm_init_arrays ();
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue