* Patchset related to array functions
@ 2016-07-12 7:48 Daniel Llorens
2016-07-12 14:11 ` Andy Wingo
0 siblings, 1 reply; 16+ messages in thread
From: Daniel Llorens @ 2016-07-12 7:48 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 949 bytes --]
I propose this patchset to be merged in master. It is rebased on top of current master (867316ffcd65bd1e5e23813c22ba2515586ae845). I have pushed it as branch lloda-squash0 to savannah (http://git.savannah.gnu.org/gitweb/?p=guile.git;a=shortlog;h=refs/heads/lloda-squash0).
A summary:
* Enable typed arrays in (restricted-sort!), (sort!), (sort).
* New functions (array-from) (array-from*) (array-amend!) (array-for-each-cell) (array-for-each-cell) (array-for-each-cell-in-order), including documentation and tests.
* Some speed ups and removal of deprecated code.
* A minor bug fix in the compiler.
* Move to C99. Some of the patches above depend on this. Surely there's more to be done to take advantage of C99, but I don't think it's necessary to do it all in one patch, so I would ask that this be applied anyway. Otherwise, I'd prefer to rebase the patchset on top of any other enable-C99 patch.
Thanks,
Daniel
[-- Attachment #2: 0001-Compile-in-C99-mode.patch --]
[-- Type: application/octet-stream, Size: 4582 bytes --]
From bdd14209a37af33f3092a607574ec54e85ad02b3 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 11 Feb 2015 14:05:08 +0100
Subject: [PATCH 01/13] Compile in C99 mode
* configure.ac: Require C99 flags. Remove -Wdeclaration-after-statement.
---
configure.ac | 33 ++++++++++++++++-----------------
1 file changed, 16 insertions(+), 17 deletions(-)
diff --git a/configure.ac b/configure.ac
index 1735c56..5d76407 100644
--- a/configure.ac
+++ b/configure.ac
@@ -65,7 +65,7 @@ AC_CANONICAL_HOST
AC_LIBTOOL_WIN32_DLL
AC_PROG_INSTALL
-AC_PROG_CC
+AC_PROG_CC_C99
gl_EARLY
AC_PROG_CPP
AC_PROG_SED
@@ -175,19 +175,19 @@ dnl investigation of problems with "64" system and library calls on
dnl Darwin (MacOS X). The libguile code (_scm.h) assumes that if a
dnl system has stat64, it will have all the other 64 APIs too; but on
dnl Darwin, stat64 is there but other APIs are missing.
-dnl
+dnl
dnl It also appears, from the Darwin docs, that most system call APIs
dnl there (i.e. the traditional ones _without_ "64" in their names) have
dnl been 64-bit-capable for a long time now, so it isn't necessary to
dnl use "64" versions anyway. For example, Darwin's off_t is 64-bit.
-dnl
+dnl
dnl A similar problem has been reported for HP-UX:
dnl http://www.nabble.com/Building-guile-1.8.2-on-hpux-td13106681.html
-dnl
+dnl
dnl Therefore, and also because a Guile without LARGEFILE64 support is
dnl better than no Guile at all, we provide this option to suppress
dnl trying to use "64" calls.
-dnl
+dnl
dnl It may be that for some 64-bit function on Darwin/HP-UX we do need
dnl to use a "64" call, and hence that by using --without-64-calls we're
dnl missing out on that. If so, someone can work on that in the future.
@@ -850,7 +850,7 @@ volatile complex double z = - _Complex_I;
int
main (void)
{
- z = csqrt (z);
+ z = csqrt (z);
if (creal (z) > 0.0)
return 0; /* good */
else
@@ -914,9 +914,9 @@ AC_CHECK_SIZEOF(size_t)
AC_CHECK_SIZEOF(ssize_t)
ffi_size_type=uint$(($ac_cv_sizeof_size_t*8))
ffi_ssize_type=sint$(($ac_cv_sizeof_ssize_t*8))
-AC_DEFINE_UNQUOTED([ffi_type_size_t], ffi_type_${ffi_size_type},
+AC_DEFINE_UNQUOTED([ffi_type_size_t], ffi_type_${ffi_size_type},
[ffi type for size_t])
-AC_DEFINE_UNQUOTED([ffi_type_ssize_t], ffi_type_${ffi_ssize_type},
+AC_DEFINE_UNQUOTED([ffi_type_ssize_t], ffi_type_${ffi_ssize_type},
[ffi type for ssize_t])
dnl i18n tests
@@ -1271,7 +1271,7 @@ LIBS="$save_LIBS"
AC_CHECK_SIZEOF(float)
if test "$ac_cv_sizeof_float" -le "$ac_cv_sizeof_long"; then
- AC_DEFINE([SCM_SINGLES], 1,
+ AC_DEFINE([SCM_SINGLES], 1,
[Define this if floats are the same size as longs.])
fi
@@ -1402,7 +1402,7 @@ case "$with_threads" in
# On Solaris, sched_yield lives in -lrt.
AC_SEARCH_LIBS(sched_yield, rt)
-
+
;;
esac
@@ -1478,7 +1478,7 @@ GUILE_THREAD_LOCAL_STORAGE
fi # with_threads=pthreads
-## Cross building
+## Cross building
if test "$cross_compiling" = "yes"; then
AC_MSG_CHECKING(cc for build)
## /usr/bin/cc still uses wrong assembler
@@ -1486,8 +1486,8 @@ if test "$cross_compiling" = "yes"; then
CC_FOR_BUILD="${CC_FOR_BUILD-PATH=/usr/bin:$PATH cc}"
else
CC_FOR_BUILD="${CC_FOR_BUILD-$CC}"
-fi
-
+fi
+
## AC_MSG_CHECKING("if we are cross compiling")
## AC_MSG_RESULT($cross_compiling)
if test "$cross_compiling" = "yes"; then
@@ -1500,14 +1500,14 @@ CCLD_FOR_BUILD="$CC_FOR_BUILD"
AC_SUBST(cross_compiling)
AC_ARG_VAR(CC_FOR_BUILD,[build system C compiler])
AC_SUBST(CCLD_FOR_BUILD)
-
+
## libtool erroneously calls CC_FOR_BUILD HOST_CC;
## --HOST is the platform that PACKAGE is compiled for.
HOST_CC="$CC_FOR_BUILD"
AC_SUBST(HOST_CC)
GUILE_CHECK_GUILE_FOR_BUILD
-
+
## If we're using GCC, add flags to reduce strictness of undefined
## behavior, and ask for aggressive warnings.
GCC_CFLAGS=""
@@ -1524,8 +1524,7 @@ case "$GCC" in
## <http://lists.gnu.org/archive/html/guile-devel/2012-01/msg00487.html>.
POTENTIAL_GCC_CFLAGS="-Wall -Wmissing-prototypes \
- -Wdeclaration-after-statement -Wpointer-arith \
- -Wswitch-enum -fno-strict-aliasing -fwrapv"
+ -Wpointer-arith -Wswitch-enum -fno-strict-aliasing -fwrapv"
# Do this here so we don't screw up any of the tests above that might
# not be "warning free"
if test "${GUILE_ERROR_ON_WARNING}" = yes
--
2.7.3
[-- Attachment #3: 0002-Fix-compilation-of-rank-0-typed-array-literals.patch --]
[-- Type: application/octet-stream, Size: 1768 bytes --]
From dbac9aa4d3fa4a594f942ce523eaa027a635cc74 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Thu, 12 Feb 2015 13:02:24 +0100
Subject: [PATCH 02/13] Fix compilation of rank 0 typed array literals
* module/system/vm/assembler.scm (simple-uniform-vector?): array-length
fails for rank 0 arrays; fix the shape condition.
* test-suite/tests/arrays.test: Test reading of #0f64(x) in compilation
context.
---
module/system/vm/assembler.scm | 4 +++-
test-suite/tests/arrays.test | 8 +++++++-
2 files changed, 10 insertions(+), 2 deletions(-)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 20a652c..f6b3caa 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -995,7 +995,9 @@ immediate, and @code{#f} otherwise."
(define (simple-uniform-vector? obj)
(and (array? obj)
(symbol? (array-type obj))
- (equal? (array-shape obj) (list (list 0 (1- (array-length obj)))))))
+ (match (array-shape obj)
+ (((0 n)) #t)
+ (else #f))))
(define (statically-allocatable? x)
"Return @code{#t} if a non-immediate constant can be allocated
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index e76c699..20cb78b 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -204,7 +204,13 @@
(with-test-prefix/c&e "array-equal?"
(pass-if "#s16(...)"
- (array-equal? #s16(1 2 3) #s16(1 2 3))))
+ (array-equal? #s16(1 2 3) #s16(1 2 3)))
+
+ (pass-if "#0f64(...)"
+ (array-equal? #0f64(99) (make-typed-array 'f64 99)))
+
+ (pass-if "#0(...)"
+ (array-equal? #0(99) (make-array 99))))
;;;
;;; make-shared-array
--
2.7.3
[-- Attachment #4: 0003-Remove-scm_from_contiguous_array-array-contiguous-fl.patch --]
[-- Type: application/octet-stream, Size: 8747 bytes --]
From cf58e97a77c6269c1d7745404988784504e25dfe Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Mon, 9 Feb 2015 17:27:33 +0100
Subject: [PATCH 03/13] Remove scm_from_contiguous_array, array 'contiguous'
flag
scm_from_contiguous_array() is undocumented, unused within Guile, and
can be trivially replaced by make-array + array-copy without requiring
contiguity.
The related SCM_I_ARRAY_FLAG_CONTIGUOUS (arrays.h) was set by all
array-creating functions (make-typed-array, transpose-array,
make-shared-array) but it was only used by array-contents, which needed
to traverse the dimensions anyway.
* libguile/arrays.h (scm_from_contiguous_array): Remove declaration.
* libguile/arrays.c (scm_from_contiguous_array): Remove.
(scm_make_typed_array, scm_from_contiguous_typed_array): Don't set the
contiguous flag.
(scm_transpose_array, scm_make_shared_array): Don't call
scm_i_ra_set_contp.
(scm_array_contents): Inline scm_i_ra_set_contp() here. Adopt uniform
type check order. Remove redundant comments.
(scm_i_ra_set_contp): Remove.
* test-suite/tests/arrays.test: Test array-contents with rank 0 array.
---
libguile/arrays.c | 112 +++++++++++--------------------------------
libguile/arrays.h | 4 +-
test-suite/tests/arrays.test | 6 +++
3 files changed, 36 insertions(+), 86 deletions(-)
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 52fe90a..3cb547f 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -188,7 +188,6 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
SCM ra;
ra = scm_i_shap2ra (bounds);
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
s = SCM_I_ARRAY_DIMS (ra);
k = SCM_I_ARRAY_NDIM (ra);
@@ -225,7 +224,6 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
size_t sz;
ra = scm_i_shap2ra (bounds);
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
s = SCM_I_ARRAY_DIMS (ra);
k = SCM_I_ARRAY_NDIM (ra);
@@ -270,41 +268,6 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
}
#undef FUNC_NAME
-SCM
-scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len)
-#define FUNC_NAME "scm_from_contiguous_array"
-{
- size_t k, rlen = 1;
- scm_t_array_dim *s;
- SCM ra;
- scm_t_array_handle h;
-
- ra = scm_i_shap2ra (bounds);
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
- s = SCM_I_ARRAY_DIMS (ra);
- k = SCM_I_ARRAY_NDIM (ra);
-
- while (k--)
- {
- s[k].inc = rlen;
- SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
- rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
- }
- if (rlen != len)
- SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL);
-
- SCM_I_ARRAY_SET_V (ra, scm_c_make_vector (rlen, SCM_UNDEFINED));
- scm_array_get_handle (ra, &h);
- memcpy (h.writable_elements, elts, rlen * sizeof(SCM));
- scm_array_handle_release (&h);
-
- if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
- if (0 == s->lbnd)
- return SCM_I_ARRAY_V (ra);
- return ra;
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
(SCM fill, SCM bounds),
"Create and return an array.")
@@ -314,27 +277,6 @@ SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
}
#undef FUNC_NAME
-static void
-scm_i_ra_set_contp (SCM ra)
-{
- size_t k = SCM_I_ARRAY_NDIM (ra);
- if (k)
- {
- ssize_t inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc;
- while (k--)
- {
- if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc)
- {
- SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
- return;
- }
- inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
- - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
- }
- }
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
-}
-
SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
(SCM oldra, SCM mapfunc, SCM dims),
@@ -448,7 +390,6 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0,
SCM_UNDEFINED);
}
- scm_i_ra_set_contp (ra);
return ra;
}
#undef FUNC_NAME
@@ -547,16 +488,12 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
}
if (ndim > 0)
SCM_MISC_ERROR ("bad argument list", SCM_EOL);
- scm_i_ra_set_contp (res);
return res;
}
}
#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 true, return #f if returned array
- wouldn't have contiguous elements. */
+
SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
(SCM ra, SCM strict),
"If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n"
@@ -566,31 +503,38 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
"@code{make-array} and @code{make-uniform-array} may be unrolled,\n"
"some arrays made by @code{make-shared-array} may not be. If\n"
"the optional argument @var{strict} is provided, a shared array\n"
- "will be returned only if its elements are stored internally\n"
- "contiguous in memory.")
+ "will be returned only if its elements are stored contiguously\n"
+ "in memory.")
#define FUNC_NAME s_scm_array_contents
{
- if (!scm_is_array (ra))
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
- else if (SCM_I_ARRAYP (ra))
+ if (SCM_I_ARRAYP (ra))
{
SCM v;
- size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
- if (!SCM_I_ARRAY_CONTP (ra))
- return SCM_BOOL_F;
- for (k = 0; k < ndim; k++)
- len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
+ size_t ndim = SCM_I_ARRAY_NDIM (ra);
+ scm_t_array_dim *s = SCM_I_ARRAY_DIMS (ra);
+ size_t k = ndim;
+ size_t len = 1;
+
+ if (k)
+ {
+ ssize_t last_inc = s[k - 1].inc;
+ while (k--)
+ {
+ if (len*last_inc != s[k].inc)
+ return SCM_BOOL_F;
+ len *= (s[k].ubnd - s[k].lbnd + 1);
+ }
+ }
+
if (!SCM_UNBNDP (strict) && scm_is_true (strict))
{
- if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc))
+ if (ndim && (1 != s[ndim - 1].inc))
return SCM_BOOL_F;
- if (scm_is_bitvector (SCM_I_ARRAY_V (ra)))
- {
- if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
- SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
- len % SCM_LONG_BIT)
- return SCM_BOOL_F;
- }
+ if (scm_is_bitvector (SCM_I_ARRAY_V (ra))
+ && (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
+ SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
+ len % SCM_LONG_BIT))
+ return SCM_BOOL_F;
}
v = SCM_I_ARRAY_V (ra);
@@ -607,8 +551,10 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
return sra;
}
}
- else
+ else if (scm_is_array (ra))
return ra;
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
}
#undef FUNC_NAME
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 5f40597..4baa51e 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -37,8 +37,6 @@
/** Arrays */
SCM_API SCM scm_make_array (SCM fill, SCM bounds);
-SCM_API SCM scm_from_contiguous_array (SCM bounds, const SCM *elts,
- size_t len);
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,
@@ -54,7 +52,7 @@ SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);
/* internal. */
-#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0)
+#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0) /* currently unused */
#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc7_array, a)
#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x)>>17))
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 20cb78b..6f37196 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -294,6 +294,12 @@
(with-test-prefix/c&e "array-contents"
+ (pass-if "0-rank array"
+ (let ((a (make-vector 1 77)))
+ (and
+ (eq? a (array-contents (make-shared-array a (const '(0)))))
+ (eq? a (array-contents (make-shared-array a (const '(0))) #t)))))
+
(pass-if "simple vector"
(let* ((a (make-array 0 4)))
(eq? a (array-contents a))))
--
2.7.3
[-- Attachment #5: 0004-Avoid-unneeded-internal-use-of-array-handles.patch --]
[-- Type: application/octet-stream, Size: 12611 bytes --]
From 23e0dd92326bdcc9b67d770c9df4cf9c997015fd Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Mon, 9 Feb 2015 12:11:52 +0100
Subject: [PATCH 04/13] Avoid unneeded internal use of array handles
* libguile/arrays.c (scm_shared_array_root): Adopt uniform check order.
(scm_shared_array_offset, scm_shared_array_increments): Use the array
fields directly just as scm_shared_array_root does.
(scm_c_array_rank): Moved from libguile/generalized-arrays.c. Don't
use array handles, but follow the same type check sequence as the
other array functions (shared-array-root, etc).
(scm_array_rank): Moved from libguile/generalized-arrays.h.
* libguile/arrays.h: Move prototypes here.
* test-suite/tests/arrays.test: Tests for shared-array-offset,
shared-array-increments.
---
libguile/arrays.c | 65 +++++++++++++++++++++++-------------
libguile/arrays.h | 3 ++
libguile/generalized-arrays.c | 43 +++++++-----------------
libguile/generalized-arrays.h | 3 --
test-suite/tests/arrays.test | 76 +++++++++++++++++++++++++++++++++++--------
5 files changed, 120 insertions(+), 70 deletions(-)
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 3cb547f..fb522e1 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -64,6 +64,27 @@
(SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
+size_t
+scm_c_array_rank (SCM array)
+{
+ if (SCM_I_ARRAYP (array))
+ return SCM_I_ARRAY_NDIM (array);
+ else if (scm_is_array (array))
+ return 1;
+ else
+ scm_wrong_type_arg_msg ("array-rank", SCM_ARG1, array, "array");
+}
+
+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_shared_array_root, "shared-array-root", 1, 0, 0,
(SCM ra),
"Return the root vector of a shared array.")
@@ -71,10 +92,10 @@ SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
{
if (SCM_I_ARRAYP (ra))
return SCM_I_ARRAY_V (ra);
- else if (!scm_is_array (ra))
- scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
- else
+ else if (scm_is_array (ra))
return ra;
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME
@@ -84,13 +105,12 @@ SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
"Return the root vector index of the first element in the array.")
#define FUNC_NAME s_scm_shared_array_offset
{
- scm_t_array_handle handle;
- SCM res;
-
- scm_array_get_handle (ra, &handle);
- res = scm_from_size_t (handle.base);
- scm_array_handle_release (&handle);
- return res;
+ if (SCM_I_ARRAYP (ra))
+ return scm_from_size_t (SCM_I_ARRAY_BASE (ra));
+ else if (scm_is_array (ra))
+ return scm_from_size_t (0);
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME
@@ -100,18 +120,19 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
"For each dimension, return the distance between elements in the root vector.")
#define FUNC_NAME s_scm_shared_array_increments
{
- scm_t_array_handle handle;
- SCM res = SCM_EOL;
- size_t k;
- scm_t_array_dim *s;
-
- scm_array_get_handle (ra, &handle);
- k = scm_array_handle_rank (&handle);
- s = scm_array_handle_dims (&handle);
- while (k--)
- res = scm_cons (scm_from_ssize_t (s[k].inc), res);
- scm_array_handle_release (&handle);
- return res;
+ if (SCM_I_ARRAYP (ra))
+ {
+ size_t k = SCM_I_ARRAY_NDIM (ra);
+ SCM res = SCM_EOL;
+ scm_t_array_dim *dims = SCM_I_ARRAY_DIMS (ra);
+ while (k--)
+ res = scm_cons (scm_from_ssize_t (dims[k].inc), res);
+ return res;
+ }
+ else if (scm_is_array (ra))
+ return scm_list_1 (scm_from_ssize_t (1));
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 4baa51e..d3e409f 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -50,6 +50,9 @@ SCM_API SCM scm_array_contents (SCM ra, SCM strict);
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 size_t scm_c_array_rank (SCM ra);
+SCM_API SCM scm_array_rank (SCM ra);
+
/* internal. */
#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0) /* currently unused */
diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c
index 9a001eb..99125f2 100644
--- a/libguile/generalized-arrays.c
+++ b/libguile/generalized-arrays.c
@@ -1,5 +1,5 @@
/* 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
@@ -104,27 +104,6 @@ SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
}
#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)
@@ -144,7 +123,7 @@ scm_c_array_length (SCM array)
return res;
}
-SCM_DEFINE (scm_array_length, "array-length", 1, 0, 0,
+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.")
@@ -155,7 +134,7 @@ SCM_DEFINE (scm_array_length, "array-length", 1, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
+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"
@@ -168,7 +147,7 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
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);
@@ -186,7 +165,7 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
+SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
(SCM ra),
"")
#define FUNC_NAME s_scm_array_type
@@ -197,7 +176,7 @@ SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
scm_array_get_handle (ra, &h);
type = scm_array_handle_element_type (&h);
scm_array_handle_release (&h);
-
+
return type;
}
#undef FUNC_NAME
@@ -220,7 +199,7 @@ SCM_DEFINE (scm_array_type_code,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
+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}.")
@@ -376,7 +355,7 @@ SCM_DEFINE (scm_i_array_set_x, "array-set!", 2, 2, 1,
#undef FUNC_NAME
-static SCM
+static SCM
array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos)
{
if (dim == scm_array_handle_rank (h))
@@ -397,7 +376,7 @@ array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos)
}
}
-SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
+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"
@@ -410,8 +389,8 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
#define FUNC_NAME s_scm_array_to_list
{
scm_t_array_handle h;
- SCM res;
-
+ SCM res;
+
scm_array_get_handle (array, &h);
res = array_to_list (&h, 0, 0);
scm_array_handle_release (&h);
diff --git a/libguile/generalized-arrays.h b/libguile/generalized-arrays.h
index dfdb8bd..cfa6905 100644
--- a/libguile/generalized-arrays.h
+++ b/libguile/generalized-arrays.h
@@ -41,9 +41,6 @@ SCM_INTERNAL SCM scm_array_p_2 (SCM);
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 size_t scm_c_array_length (SCM ra);
SCM_API SCM scm_array_length (SCM ra);
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 6f37196..c40457b 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -23,9 +23,13 @@
#:use-module (srfi srfi-4)
#:use-module (srfi srfi-4 gnu))
-;;;
-;;; array?
-;;;
+(define (array-row a i)
+ (make-shared-array a (lambda (j) (list i j))
+ (cadr (array-dimensions a))))
+
+(define (array-col a j)
+ (make-shared-array a (lambda (i) (list i j))
+ (car (array-dimensions a))))
(define exception:wrong-num-indices
(cons 'misc-error "^wrong number of indices.*"))
@@ -33,6 +37,15 @@
(define exception:length-non-negative
(cons 'read-error ".*array length must be non-negative.*"))
+(define exception:wrong-type-arg
+ (cons #t "Wrong type"))
+
+(define exception:mapping-out-of-range
+ (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
+
+;;;
+;;; array?
+;;;
(with-test-prefix "array?"
@@ -216,9 +229,6 @@
;;; make-shared-array
;;;
-(define exception:mapping-out-of-range
- (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
-
(with-test-prefix/c&e "make-shared-array"
;; this failed in guile 1.8.0
@@ -404,13 +414,57 @@
(eq? (shared-array-root a) (shared-array-root b) (array-contents a)))))
;;;
+;;; shared-array-offset
+;;;
+
+(with-test-prefix/c&e "shared-array-offset"
+
+ (pass-if "plain vector"
+ (zero? (shared-array-offset (make-vector 4 0))))
+
+ (pass-if "plain array rank 2"
+ (zero? (shared-array-offset (make-array 0 4 4))))
+
+ (pass-if "row of rank-2 array, I"
+ (= 0 (shared-array-offset (array-row (make-array 0 5 3) 0))))
+
+ (pass-if "row of rank-2 array, II"
+ (= 4 (shared-array-offset (array-row (make-array 0 6 4) 1))))
+
+ (pass-if "col of rank-2 array, I"
+ (= 0 (shared-array-offset (array-col (make-array 0 5 3) 0))))
+
+ (pass-if "col of rank-2 array, II"
+ (= 1 (shared-array-offset (array-col (make-array 0 6 4) 1)))))
+
+
+;;;
+;;; shared-array-increments
+;;;
+
+(with-test-prefix/c&e "shared-array-increments"
+
+ (pass-if "plain vector"
+ (equal? '(1) (shared-array-increments (make-vector 4 0))))
+
+ (pass-if "plain array rank 2"
+ (equal? '(4 1) (shared-array-increments (make-array 0 3 4))))
+
+ (pass-if "plain array rank 3"
+ (equal? '(20 5 1) (shared-array-increments (make-array 0 3 4 5))))
+
+ (pass-if "row of rank-2 array"
+ (equal? '(1) (shared-array-increments (array-row (make-array 0 5 3) 0))))
+
+ (pass-if "col of rank-2 array"
+ (equal? '(3) (shared-array-increments (array-col (make-array 0 5 3) 0)))))
+
+
+;;;
;;; transpose-array
;;;
; see strings.test.
-(define exception:wrong-type-arg
- (cons #t "Wrong type"))
-
(with-test-prefix/c&e "transpose-array"
(pass-if-exception "non array argument" exception:wrong-type-arg
@@ -821,10 +875,6 @@
;;; slices as generalized vectors
;;;
-(define (array-row a i)
- (make-shared-array a (lambda (j) (list i j))
- (cadr (array-dimensions a))))
-
(with-test-prefix/c&e "generalized vector slices"
(pass-if (equal? (array-row #2u32((0 1) (2 3)) 1)
#u32(2 3)))
--
2.7.3
[-- Attachment #6: 0005-Reuse-SCM_BYTEVECTOR_TYPED_LENGTH-in-scm_array_get_h.patch --]
[-- Type: application/octet-stream, Size: 5223 bytes --]
From 3cd228a963d249da38ad3a0ac672ab8bbe5b1328 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 11 Feb 2015 12:58:01 +0100
Subject: [PATCH 05/13] Reuse SCM_BYTEVECTOR_TYPED_LENGTH in
scm_array_get_handle
* libguile/bytevectors.h (SCM_BYTEVECTOR_TYPE_SIZE,
SCM_BYTEVECTOR_TYPED_LENGTH): Moved from libguile/bytevectors.c.
* libguile/array-handle.c (scm_array_get_handle): Reuse
SCM_BYTEVECTOR_TYPED_LENGTH.
---
libguile/array-handle.c | 12 +++++-------
libguile/bytevectors.c | 13 ++++---------
libguile/bytevectors.h | 5 +++++
3 files changed, 14 insertions(+), 16 deletions(-)
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 2252ecc..17be456 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -1,6 +1,6 @@
/* 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
@@ -185,15 +185,13 @@ scm_array_get_handle (SCM array, scm_t_array_handle *h)
break;
case scm_tc7_bytevector:
{
- size_t byte_length, length, element_byte_size;
+ size_t length;
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;
+ length = SCM_BYTEVECTOR_TYPED_LENGTH (array);
switch (element_type)
{
@@ -248,7 +246,7 @@ 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);
@@ -340,7 +338,7 @@ 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);
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index e426ae3..8e9b5e6 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -192,11 +192,6 @@
#define SCM_BYTEVECTOR_SET_PARENT(_bv, _parent) \
SCM_SET_CELL_OBJECT_3 ((_bv), (_parent))
-#define SCM_BYTEVECTOR_TYPE_SIZE(var) \
- (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
-#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \
- (SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var))
-
/* The empty bytevector. */
SCM scm_null_bytevector = SCM_UNSPECIFIED;
@@ -414,7 +409,7 @@ scm_i_print_bytevector (SCM bv, SCM port, scm_print_state *pstate SCM_UNUSED)
{
ssize_t ubnd, inc, i;
scm_t_array_handle h;
-
+
scm_array_get_handle (bv, &h);
scm_putc ('#', port);
@@ -643,7 +638,7 @@ SCM_DEFINE (scm_uniform_array_to_bytevector, "uniform-array->bytevector",
size_t len, sz, byte_len;
scm_t_array_handle h;
const void *elts;
-
+
contents = scm_array_contents (array, SCM_BOOL_T);
if (scm_is_false (contents))
scm_wrong_type_arg_msg (FUNC_NAME, 0, array, "uniform contiguous array");
@@ -1940,7 +1935,7 @@ utf_encoding_name (char *name, size_t utf_width, SCM endianness)
memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, c_utf_len); \
scm_dynwind_end (); \
\
- return (utf);
+ return (utf);
@@ -2001,7 +1996,7 @@ SCM_DEFINE (scm_string_to_utf32, "string->utf32",
if (!scm_is_eq (SCM_UNBNDP (endianness) ? scm_endianness_big : endianness,
scm_i_native_endianness))
swap_u32 (wchars, wchar_len);
-
+
bv = make_bytevector (bytes_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
memcpy (SCM_BYTEVECTOR_CONTENTS (bv), wchars, bytes_len);
free (wchars);
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
index a5eeaea..af4ac1c 100644
--- a/libguile/bytevectors.h
+++ b/libguile/bytevectors.h
@@ -129,6 +129,11 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM);
#define SCM_BYTEVECTOR_CONTIGUOUS_P(_bv) \
(SCM_BYTEVECTOR_FLAGS (_bv) >> 8UL)
+#define SCM_BYTEVECTOR_TYPE_SIZE(var) \
+ (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
+#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \
+ (SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var))
+
/* Hint that is passed to `scm_gc_malloc ()' and friends. */
#define SCM_GC_BYTEVECTOR "bytevector"
--
2.7.3
[-- Attachment #7: 0006-New-functions-array-from-array-from-array-set-from.patch --]
[-- Type: application/octet-stream, Size: 18846 bytes --]
From 5e32b65e513561cd1994abc91b79ed965503e615 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 11 Feb 2015 16:44:21 +0100
Subject: [PATCH 06/13] New functions array-from, array-from*, array-set-from!
* libguile/arrays.h (scm_array_from, scm_array_from_s,
scm_array_amend_x): New declarations.
* libguile/arrays.c (scm_array_from, scm_array_from_s,
scm_array_amend_x): New functions, export as array-from, array-from*,
array-amend!.
* test-suite/tests/arrays.test: Tests for array-from, array-from*,
array-amend!.
* doc/ref/api-compound.texi: Document array-from, array-from*,
array-amend!.
---
doc/ref/api-compound.texi | 127 +++++++++++++++++++++++++++++++----
libguile/arrays.c | 153 +++++++++++++++++++++++++++++++++++++++++++
libguile/arrays.h | 6 ++
test-suite/tests/arrays.test | 109 ++++++++++++++++++++++++++++++
4 files changed, 384 insertions(+), 11 deletions(-)
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index b4ae79c..7f70374 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -30,7 +30,7 @@ values can be looked up within them.
* Structures:: Low-level record representation.
* Dictionary Types:: About dictionary types in general.
* Association Lists:: List-based dictionaries.
-* VHashes:: VList-based dictionaries.
+* VHashes:: VList-based dictionaries.
* Hash Tables:: Table-based dictionaries.
@end menu
@@ -241,7 +241,7 @@ or a pair which has a list in its cdr.
@c FIXME::martin: What is a proper, what an improper list?
@c What is a circular list?
-@c FIXME::martin: Maybe steal some graphics from the Elisp reference
+@c FIXME::martin: Maybe steal some graphics from the Elisp reference
@c manual?
@menu
@@ -1117,7 +1117,7 @@ bv
@end example
If @var{uvec} is a uniform vector of unsigned long integers, then
-they're indexes into @var{bitvector} which are set to @var{bool}.
+they're indexes into @var{bitvector} which are set to @var{bool}.
@example
(define bv #*01000010)
@@ -1200,10 +1200,10 @@ numeric vectors, bytevectors, bit vectors and ordinary vectors as one
dimensional arrays.
@menu
-* Array Syntax::
-* Array Procedures::
-* Shared Arrays::
-* Accessing Arrays from C::
+* Array Syntax::
+* Array Procedures::
+* Shared Arrays::
+* Accessing Arrays from C::
@end menu
@node Array Syntax
@@ -1247,7 +1247,7 @@ As a special case, an array of rank 0 is printed as
@code{#0<vectag>(<scalar>)}, where @code{<scalar>} is the result of
printing the single element of the array.
-Thus,
+Thus,
@table @code
@item #(1 2 3)
@@ -1709,6 +1709,111 @@ base and stride for new array indices in @var{oldarray} data. A few
sample points are enough because @var{mapfunc} is linear.
@end deffn
+
+@deffn {Scheme Procedure} array-ref array idx @dots{}
+@deffnx {C Function} scm_array_ref (array, idxlist)
+Return the element at @code{(idx @dots{})} in @var{array}.
+@end deffn
+
+@deffn {Scheme Procedure} array-from array idx @dots{}
+@deffnx {C Function} scm_array_from (array, idxlist)
+If the length of @var{idxlist} equals the rank @math{n} of
+@var{array}, return the element at @code{(idx @dots{})}, just like
+@code{(array-ref array idx @dots{})}. If, however, the length @math{k}
+of @var{idxlist} is shorter than @math{n}, then return the shared
+@math{(n-k)}-rank prefix cell of @var{array} given by @var{idxlist}.
+
+For example:
+
+@example
+@lisp
+(array-from #2((a b) (c d)) 0) @result{} #(a b)
+(array-from #2((a b) (c d)) 1) @result{} #(c d)
+(array-from #2((a b) (c d)) 1 1) @result{} d
+(array-from #2((a b) (c d))) @result{} #2((a b) (c d))
+@end lisp
+@end example
+
+@code{(apply array-from array indices)} is equivalent to
+
+@lisp
+(let ((len (length indices)))
+ (if (= (array-rank a) len)
+ (apply array-ref a indices)
+ (apply make-shared-array a
+ (lambda t (append indices t))
+ (drop (array-dimensions a) len))))
+@end lisp
+
+The name `from' comes from the J language.
+@end deffn
+
+@deffn {Scheme Procedure} array-from* array idx @dots{}
+@deffnx {C Function} scm_array_from_s (array, idxlist)
+Like @code{(array-from array idx @dots{})}, but return a 0-rank shared
+array if the length of @var{idxlist} matches the rank of
+@var{array}. This can be useful when using @var{ARRAY} as destination
+of copies.
+
+Compare:
+
+@example
+@lisp
+(array-from #2((a b) (c d)) 1 1) @result{} d
+(array-from* #2((a b) (c d)) 1) @result{} #0(d)
+(define a (make-array 'a 2 2))
+(array-fill! (array-from* a 1 1) 'b)
+a @result{} #2((a a) (a b)).
+(array-fill! (array-from a 1 1) 'b) @result{} error: not an array
+@end lisp
+@end example
+
+@code{(apply array-from* array indices)} is equivalent to
+
+@lisp
+(apply make-shared-array a
+ (lambda t (append indices t))
+ (drop (array-dimensions a) (length indices)))
+@end lisp
+@end deffn
+
+
+@deffn {Scheme Procedure} array-amend! array x idx @dots{}
+@deffnx {C Function} scm_array_amend_x (array, x, idxlist)
+If the length of @var{idxlist} equals the rank @math{n} of
+@var{array}, set the element at @code{(idx @dots{})} of @var{array} to
+@var{x}, just like @code{(array-set! array x idx @dots{})}. If,
+however, the length @math{k} of @var{idxlist} is shorter than
+@math{n}, then copy the @math{(n-k)}-rank array @var{x}
+into @math{(n-k)}-rank prefix cell of @var{array} given by
+@var{idxlist}. In this case, the last @math{(n-k)} dimensions of
+@var{array} and the dimensions of @var{x} must match exactly.
+
+This function returns the modified @var{array}.
+
+For example:
+
+@example
+@lisp
+(array-amend! (make-array 'a 2 2) b 1 1) @result{} #2((a a) (a b))
+(array-amend! (make-array 'a 2 2) #(x y) 1) @result{} #2((a a) (x y))
+@end lisp
+@end example
+
+@code{(apply array-amend! array x indices)} is equivalent to
+
+@lisp
+(let ((len (length indices)))
+ (if (= (array-rank array) len)
+ (apply array-set! array x indices)
+ (array-copy! x (apply array-from array indices)))
+ array)
+@end lisp
+
+The name `amend' comes from the J language.
+@end deffn
+
+
@deffn {Scheme Procedure} shared-array-increments array
@deffnx {C Function} scm_shared_array_increments (array)
For each dimension, return the distance between elements in the root vector.
@@ -2716,7 +2821,7 @@ Set field number @var{n} in @var{struct} to @var{value}. The first
field is number 0.
An error is thrown if @var{n} is out of range, or if the field cannot
-be written because it's @code{r} read-only or @code{o} opaque.
+be written because it's @code{r} read-only or @code{o} opaque.
@end deffn
@deffn {Scheme Procedure} struct-vtable struct
@@ -2864,7 +2969,7 @@ scheme@@(guile-user)> (struct-ref $3 vtable-index-layout)
$6 = pruhsruhpwphuhuhprprpw
scheme@@(guile-user)> (struct-ref $4 vtable-index-layout)
$7 = pruhsruhpwphuhuh
-scheme@@(guile-user)> standard-vtable-fields
+scheme@@(guile-user)> standard-vtable-fields
$8 = "pruhsruhpwphuhuh"
scheme@@(guile-user)> (struct-ref $2 vtable-offset-user)
$9 = module
@@ -2934,7 +3039,7 @@ class fields.
(let* ((fields (compute-fields parent fields))
(layout (compute-layout fields)))
(make-struct/no-tail <class>
- layout
+ layout
(lambda (x port)
(print-instance x port))
name
diff --git a/libguile/arrays.c b/libguile/arrays.c
index fb522e1..26c4543 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -416,6 +416,159 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
#undef FUNC_NAME
+#define ARRAY_FROM_POS(error_args) \
+ scm_t_array_handle handle; \
+ scm_array_get_handle (ra, &handle); \
+ scm_t_array_dim * s = scm_array_handle_dims (&handle); \
+ size_t ndim = scm_array_handle_rank (&handle); \
+ size_t k = ndim; \
+ ssize_t pos = 0; \
+ SCM i = indices; \
+ for (; k>0 && scm_is_pair (i); --k, ++s, i=scm_cdr (i)) \
+ { \
+ ssize_t ik = scm_to_ssize_t (scm_car (i)); \
+ if (ik<s->lbnd || ik>s->ubnd) \
+ { \
+ scm_array_handle_release (&handle); \
+ scm_misc_error (FUNC_NAME, "indices out of range", error_args); \
+ } \
+ pos += (ik-s->lbnd) * s->inc; \
+ }
+
+#define ARRAY_FROM_GET_O \
+ o = scm_i_make_array (k); \
+ SCM_I_ARRAY_SET_V (o, handle.vector); \
+ SCM_I_ARRAY_SET_BASE (o, pos + handle.base); \
+ scm_t_array_dim * os = SCM_I_ARRAY_DIMS (o); \
+ for (; k>0; --k, ++s, ++os) \
+ { \
+ os->ubnd = s->ubnd; \
+ os->lbnd = s->lbnd; \
+ os->inc = s->inc; \
+ }
+
+
+SCM_DEFINE (scm_array_from_s, "array-from*", 1, 0, 1,
+ (SCM ra, SCM indices),
+ "Return the array slice @var{ra}[@var{indices} ..., ...]\n"
+ "The rank of @var{ra} must equal to the number of indices or larger.\n\n"
+ "See also @code{array-ref}, @code{array-from}, @code{array-amend!}.\n\n"
+ "@code{array-from*} may return a rank-0 array. For example:\n"
+ "@lisp\n"
+ "(array-from* #2((1 2 3) (4 5 6)) 1 1) @result{} #0(5)\n"
+ "(array-from* #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n"
+ "(array-from* #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n"
+ "(array-from* #0(5) @result{} #0(5).\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_from_s
+{
+ ARRAY_FROM_POS(scm_list_2 (ra, indices))
+ SCM o;
+ if (k==ndim)
+ o = ra;
+ else if (scm_is_null (i))
+ { ARRAY_FROM_GET_O }
+ else
+ {
+ scm_array_handle_release (&handle);
+ scm_misc_error(FUNC_NAME, "too many indices", scm_list_2 (ra, indices));
+ }
+ scm_array_handle_release (&handle);
+ return o;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_array_from, "array-from", 1, 0, 1,
+ (SCM ra, SCM indices),
+ "Return the element at the @code{(@var{indices} ...)} position\n"
+ "in array @var{ra}, or the array slice @var{ra}[@var{indices} ..., ...]\n"
+ "if the rank of @var{ra} is larger than the number of indices.\n\n"
+ "See also @code{array-ref}, @code{array-from*}, @code{array-amend!}.\n\n"
+ "@code{array-from} never returns a rank 0 array. For example:\n"
+ "@lisp\n"
+ "(array-from #2((1 2 3) (4 5 6)) 1 1) @result{} 5\n"
+ "(array-from #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n"
+ "(array-from #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n"
+ "(array-from #0(5) @result{} 5.\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_from
+{
+ ARRAY_FROM_POS(scm_list_2 (ra, indices))
+ SCM o;
+ if (k>0)
+ {
+ if (k==ndim)
+ o = ra;
+ else
+ { ARRAY_FROM_GET_O }
+ }
+ else if (scm_is_null(i))
+ o = scm_array_handle_ref (&handle, pos);
+ else
+ {
+ scm_array_handle_release (&handle);
+ scm_misc_error(FUNC_NAME, "too many indices", scm_list_2 (ra, indices));
+ }
+ scm_array_handle_release (&handle);
+ return o;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
+ (SCM ra, SCM b, SCM indices),
+ "Set the array slice @var{ra}[@var{indices} ..., ...] to @var{b}\n."
+ "Equivalent to @code{(array-copy! @var{b} (apply array-from @var{ra} @var{indices}))}\n"
+ "if the number of indices is smaller than the rank of @var{ra}; otherwise\n"
+ "equivalent to @code{(apply array-set! @var{ra} @var{b} @var{indices})}.\n"
+ "This function returns the modified array @var{ra}.\n\n"
+ "See also @code{array-ref}, @code{array-from}, @code{array-from*}.\n\n"
+ "For example:\n"
+ "@lisp\n"
+ "(define A (list->array 2 '((1 2 3) (4 5 6))))\n"
+ "(array-amend! A #0(99) 1 1) @result{} #2((1 2 3) (4 #0(99) 6))\n"
+ "(array-amend! A 99 1 1) @result{} #2((1 2 3) (4 99 6))\n"
+ "(array-amend! A #(a b c) 0) @result{} #2((a b c) (4 99 6))\n"
+ "(array-amend! A #2((x y z) (9 8 7))) @result{} #2((x y z) (9 8 7))\n\n"
+ "(define B (make-array 0))\n"
+ "(array-amend! B 15) @result{} #0(15)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_amend_x
+{
+ ARRAY_FROM_POS(scm_list_3 (ra, b, indices))
+ SCM o;
+ if (k>0)
+ {
+ if (k==ndim)
+ o = ra;
+ else
+ { ARRAY_FROM_GET_O }
+ scm_array_handle_release(&handle);
+ /* an error is still possible here if o and b don't match. */
+ /* TODO copying like this wastes the handle, and the bounds matching
+ behavior of array-copy! is not strict. */
+ scm_array_copy_x(b, o);
+ }
+ else if (scm_is_null(i))
+ {
+ scm_array_handle_set (&handle, pos, b); /* ra may be non-ARRAYP */
+ scm_array_handle_release (&handle);
+ }
+ else
+ {
+ scm_array_handle_release (&handle);
+ scm_misc_error(FUNC_NAME, "too many indices", scm_list_3 (ra, b, indices));
+ }
+ return ra;
+}
+#undef FUNC_NAME
+
+
+#undef ARRAY_FROM_POS
+#undef ARRAY_FROM_GET_O
+
+
/* args are RA . DIMS */
SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
(SCM ra, SCM args),
diff --git a/libguile/arrays.h b/libguile/arrays.h
index d3e409f..9b7fd6c 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -41,12 +41,18 @@ 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_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_contents (SCM ra, SCM strict);
+SCM_API SCM scm_array_from_s (SCM ra, SCM indices);
+SCM_API SCM scm_array_from (SCM ra, SCM indices);
+SCM_API SCM scm_array_amend_x (SCM ra, SCM b, SCM indices);
+
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);
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index c40457b..9bd0676 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -296,6 +296,115 @@
(and (eqv? 5 (array-ref s2 1))
(eqv? 8 (array-ref s2 2))))))
+
+;;;
+;;; array-from*
+;;;
+
+(with-test-prefix/c&e "array-from*"
+
+ (pass-if "vector I"
+ (let ((v (vector 1 2 3)))
+ (array-fill! (array-from* v 1) 'a)
+ (array-equal? v #(1 a 3))))
+
+ (pass-if "vector II"
+ (let ((v (vector 1 2 3)))
+ (array-copy! #(a b c) (array-from* v))
+ (array-equal? v #(a b c))))
+
+ (pass-if "array I"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-fill! (array-from* a 1 1) 'a)
+ (array-equal? a #2((1 2 3) (4 a 6)))))
+
+ (pass-if "array II"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-copy! #(a b c) (array-from* a 1))
+ (array-equal? a #2((1 2 3) (a b c)))))
+
+ (pass-if "array III"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-copy! #2((a b c) (x y z)) (array-from* a))
+ (array-equal? a #2((a b c) (x y z)))))
+
+ (pass-if "rank 0 array"
+ (let ((a (make-array 77)))
+ (array-fill! (array-from* a) 'a)
+ (array-equal? a #0(a)))))
+
+
+;;;
+;;; array-from
+;;;
+
+(with-test-prefix/c&e "array-from"
+
+ (pass-if "vector I"
+ (let ((v (vector 1 2 3)))
+ (equal? 2 (array-from v 1))))
+
+ (pass-if "vector II"
+ (let ((v (vector 1 2 3)))
+ (array-copy! #(a b c) (array-from v))
+ (array-equal? v #(a b c))))
+
+ (pass-if "array I"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (equal? 5 (array-from a 1 1))))
+
+ (pass-if "array II"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-copy! #(a b c) (array-from a 1))
+ (array-equal? a #2((1 2 3) (a b c)))))
+
+ (pass-if "array III"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-copy! #2((a b c) (x y z)) (array-from a))
+ (array-equal? a #2((a b c) (x y z)))))
+
+ (pass-if "rank 0 array"
+ (let ((a (make-array 77)))
+ (equal? (array-from a) 77))))
+
+
+;;;
+;;; array-amend!
+;;;
+
+(with-test-prefix/c&e "array-amend!"
+
+ (pass-if "vector I"
+ (let ((v (vector 1 2 3)))
+ (and (eq? v (array-amend! v 'x 1))
+ (array-equal? v #(1 x 3)))))
+
+ (pass-if "vector II"
+ (let ((v (vector 1 2 3)))
+ (and (eq? v (array-amend! (array-from v) #(a b c)))
+ (array-equal? v #(a b c)))))
+
+ (pass-if "array I"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (and (eq? a (array-amend! a 'x 1 1))
+ (array-equal? a #2((1 2 3) (4 x 6))))))
+
+ (pass-if "array II"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (and (eq? a (array-amend! a #(a b c) 1))
+ (array-equal? a #2((1 2 3) (a b c))))))
+
+ (pass-if "array III"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (and (eq? a (array-amend! a #2((a b c) (x y z))))
+ (array-equal? a #2((a b c) (x y z))))))
+
+ (pass-if "rank 0 array"
+ (let ((a (make-array 77)))
+ (and (eq? a (array-amend! a 99))
+ (array-equal? a #0(99))))))
+
+
;;;
;;; array-contents
;;;
--
2.7.3
[-- Attachment #8: 0007-Remove-deprecated-array-functions.patch --]
[-- Type: application/octet-stream, Size: 11199 bytes --]
From 07b5e4d381d932d35f288a387e2b1fab57b4fd10 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Fri, 13 Feb 2015 16:45:21 +0100
Subject: [PATCH 07/13] Remove deprecated array functions
* libguile/array-map.c (scm_array_fill_int, scm_array_fill_int,
scm_ra_eqp, scm_ra_lessp scm_ra_leqp, scm_ra_grp, scm_ra_greqp,
scm_ra_sum, scm_ra_difference, scm_ra_product, scm_ra_divide,
scm_array_identity): Remove deprecated functions.
* libguile/array-map.h: Remove declaration of deprecated functions.
* libguile/generalized-vectors.h, libguile/generalized-vectors.c
(scm_is_generalized_vector, scm_c_generalized_vector_length,
scm_c_generalized_vector_ref, scm_c_generalized_vector_set_x): These
functions were deprecated in 2.0.9. Remove.
---
libguile/array-map.c | 261 -----------------------------------------
libguile/array-map.h | 16 ---
libguile/generalized-vectors.c | 35 +-----
libguile/generalized-vectors.h | 4 -
4 files changed, 2 insertions(+), 314 deletions(-)
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 938f0a7..587df02 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -307,267 +307,6 @@ SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
#undef FUNC_NAME
-#if SCM_ENABLE_DEPRECATED == 1
-
-/* to be used as cproc in scm_ramapc to fill an array dimension with
- "fill". */
-int
-scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
-{
- unsigned long i;
- unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
- long inc = SCM_I_ARRAY_DIMS (ra)->inc;
- unsigned long base = SCM_I_ARRAY_BASE (ra);
-
- ra = SCM_I_ARRAY_V (ra);
-
- for (i = base; n--; i += inc)
- ASET (ra, i, fill);
-
- return 1;
-}
-
-/* Functions callable by ARRAY-MAP! */
-
-int
-scm_ra_eqp (SCM ra0, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
- scm_t_array_handle ra0_handle;
- scm_t_array_dim *ra0_dims;
- size_t n;
- ssize_t inc0;
- size_t i0 = 0;
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- ra2 = SCM_I_ARRAY_V (ra2);
-
- scm_array_get_handle (ra0, &ra0_handle);
- ra0_dims = scm_array_handle_dims (&ra0_handle);
- n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
- inc0 = ra0_dims[0].inc;
-
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
- if (!scm_is_eq (AREF (ra1, i1), AREF (ra2, i2)))
- scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
- }
-
- scm_array_handle_release (&ra0_handle);
- return 1;
-}
-
-/* opt 0 means <, nonzero means >= */
-
-static int
-ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
-{
- scm_t_array_handle ra0_handle;
- scm_t_array_dim *ra0_dims;
- size_t n;
- ssize_t inc0;
- size_t i0 = 0;
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- ra2 = SCM_I_ARRAY_V (ra2);
-
- scm_array_get_handle (ra0, &ra0_handle);
- ra0_dims = scm_array_handle_dims (&ra0_handle);
- n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
- inc0 = ra0_dims[0].inc;
-
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
- if (opt ?
- scm_is_true (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))) :
- scm_is_false (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))))
- scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
- }
-
- scm_array_handle_release (&ra0_handle);
- return 1;
-}
-
-
-
-int
-scm_ra_lessp (SCM ra0, SCM ras)
-{
- return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
-}
-
-
-int
-scm_ra_leqp (SCM ra0, SCM ras)
-{
- return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
-}
-
-
-int
-scm_ra_grp (SCM ra0, SCM ras)
-{
- return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
-}
-
-
-int
-scm_ra_greqp (SCM ra0, SCM ras)
-{
- return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
-}
-
-
-int
-scm_ra_sum (SCM ra0, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (!scm_is_null(ras))
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- ASET (ra0, i0, scm_sum (AREF(ra0, i0), AREF(ra1, i1)));
- break;
- }
- }
- }
- return 1;
-}
-
-
-
-int
-scm_ra_difference (SCM ra0, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (scm_is_null (ras))
- {
- switch (SCM_TYP7 (ra0))
- {
- default:
- {
- for (; n-- > 0; i0 += inc0)
- ASET (ra0, i0, scm_difference (AREF(ra0, i0), SCM_UNDEFINED));
- break;
- }
- }
- }
- else
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- ASET (ra0, i0, scm_difference (AREF (ra0, i0), AREF (ra1, i1)));
- break;
- }
- }
- }
- return 1;
-}
-
-
-
-int
-scm_ra_product (SCM ra0, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (!scm_is_null (ras))
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- ASET (ra0, i0, scm_product (AREF (ra0, i0), AREF (ra1, i1)));
- }
- }
- }
- return 1;
-}
-
-
-int
-scm_ra_divide (SCM ra0, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (scm_is_null (ras))
- {
- switch (SCM_TYP7 (ra0))
- {
- default:
- {
- for (; n-- > 0; i0 += inc0)
- ASET (ra0, i0, scm_divide (AREF (ra0, i0), SCM_UNDEFINED));
- break;
- }
- }
- }
- else
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- {
- SCM res = scm_divide (AREF (ra0, i0), AREF (ra1, i1));
- ASET (ra0, i0, res);
- }
- break;
- }
- }
- }
- return 1;
-}
-
-
-int
-scm_array_identity (SCM dst, SCM src)
-{
- return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
-}
-
-#endif /* SCM_ENABLE_DEPRECATED */
-
static int
ramap (SCM ra0, SCM proc, SCM ras)
{
diff --git a/libguile/array-map.h b/libguile/array-map.h
index b0592d8..e7431b1 100644
--- a/libguile/array-map.h
+++ b/libguile/array-map.h
@@ -39,22 +39,6 @@ SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc);
SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1);
SCM_INTERNAL void scm_init_array_map (void);
-#if SCM_ENABLE_DEPRECATED == 1
-
-SCM_DEPRECATED int scm_array_fill_int (SCM ra, SCM fill, SCM ignore);
-SCM_DEPRECATED int scm_ra_eqp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_lessp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_leqp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_grp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_greqp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_sum (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_difference (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_product (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_divide (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_array_identity (SCM src, SCM dst);
-
-#endif /* SCM_ENABLE_DEPRECATED == 1 */
-
#endif /* SCM_ARRAY_MAP_H */
/*
diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c
index fc493bc..308cf6e 100644
--- a/libguile/generalized-vectors.c
+++ b/libguile/generalized-vectors.c
@@ -49,7 +49,7 @@ scm_i_register_vector_constructor (SCM type, SCM (*ctor)(SCM, SCM))
/* need to increase VECTOR_CTORS_N_STATIC_ALLOC, buster */
abort ();
else
- {
+ {
vector_ctors[num_vector_ctors_registered].tag = type;
vector_ctors[num_vector_ctors_registered].ctor = ctor;
num_vector_ctors_registered++;
@@ -69,23 +69,10 @@ SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0,
}
#undef FUNC_NAME
-int
-scm_is_generalized_vector (SCM obj)
-{
- int ret = 0;
- if (scm_is_array (obj))
- {
- scm_t_array_handle h;
- scm_array_get_handle (obj, &h);
- ret = scm_array_handle_rank (&h) == 1;
- scm_array_handle_release (&h);
- }
- return ret;
-}
#define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \
scm_generalized_vector_get_handle (val, handle)
-
+
void
scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h)
@@ -98,24 +85,6 @@ scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h)
}
}
-size_t
-scm_c_generalized_vector_length (SCM v)
-{
- return scm_c_array_length (v);
-}
-
-SCM
-scm_c_generalized_vector_ref (SCM v, ssize_t idx)
-{
- return scm_c_array_ref_1 (v, idx);
-}
-
-void
-scm_c_generalized_vector_set_x (SCM v, ssize_t idx, SCM val)
-{
- scm_c_array_set_1_x (v, val, idx);
-}
-
void
scm_init_generalized_vectors ()
{
diff --git a/libguile/generalized-vectors.h b/libguile/generalized-vectors.h
index 876537a..77d6272 100644
--- a/libguile/generalized-vectors.h
+++ b/libguile/generalized-vectors.h
@@ -30,10 +30,6 @@
/* Generalized vectors */
-SCM_API int scm_is_generalized_vector (SCM obj);
-SCM_API size_t scm_c_generalized_vector_length (SCM v);
-SCM_API SCM scm_c_generalized_vector_ref (SCM v, ssize_t idx);
-SCM_API void scm_c_generalized_vector_set_x (SCM v, ssize_t idx, SCM val);
SCM_API void scm_generalized_vector_get_handle (SCM vec,
scm_t_array_handle *h);
--
2.7.3
[-- Attachment #9: 0008-Do-not-use-array-handles-in-scm_vector.patch --]
[-- Type: application/octet-stream, Size: 8345 bytes --]
From 8ff58c50c9e2e4fe65fa667eed7b3b3abda9cbd3 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 25 Feb 2015 09:47:40 +0100
Subject: [PATCH 08/13] Do not use array handles in scm_vector
* libguile/vectors.c (scm_vector): Use SCM_I_VECTOR_WELTS on new vector
instead of generic scm_vector_elements; cf. scm_vector_copy().
(scm_vector_elements): Forward to scm_vector_writable_elements().
(scm_vector_writable_elements): Remove special error message for weak
vector arg.
* libguile/generalized-vectors.c (SCM_VALIDATE_VECTOR_WITH_HANDLE):
Remove unused macro.
* libguile/array-handle.c (scm_array_handle_elements): Forward to
scm_array_handle_writable_elements().
---
libguile/array-handle.c | 4 +---
libguile/generalized-vectors.c | 4 ----
libguile/vectors.c | 52 +++++++++++++++---------------------------
3 files changed, 19 insertions(+), 41 deletions(-)
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 17be456..5da4871 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -320,9 +320,7 @@ scm_array_handle_release (scm_t_array_handle *h)
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;
+ return scm_array_handle_writable_elements (h);
}
SCM *
diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c
index 308cf6e..5a89332 100644
--- a/libguile/generalized-vectors.c
+++ b/libguile/generalized-vectors.c
@@ -70,10 +70,6 @@ SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0,
#undef FUNC_NAME
-#define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \
- scm_generalized_vector_get_handle (val, handle)
-
-
void
scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h)
{
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 5dab545..0149dca 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -59,26 +59,13 @@ const SCM *
scm_vector_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
- if (SCM_I_WVECTP (vec))
- scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
-
- scm_generalized_vector_get_handle (vec, h);
- if (lenp)
- {
- scm_t_array_dim *dim = scm_array_handle_dims (h);
- *lenp = dim->ubnd - dim->lbnd + 1;
- *incp = dim->inc;
- }
- return scm_array_handle_elements (h);
+ return scm_vector_writable_elements (vec, h, lenp, incp);
}
SCM *
scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
- if (SCM_I_WVECTP (vec))
- scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
-
scm_generalized_vector_get_handle (vec, h);
if (lenp)
{
@@ -89,7 +76,7 @@ scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
return scm_array_handle_writable_elements (h);
}
-SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0,
+SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a vector, otherwise return\n"
"@code{#f}.")
@@ -99,7 +86,7 @@ SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vector_length, "vector-length", 1, 0, 0,
+SCM_DEFINE (scm_vector_length, "vector-length", 1, 0, 0,
(SCM v),
"Returns the number of elements in @var{vector} as an exact integer.")
#define FUNC_NAME s_scm_vector_length
@@ -127,7 +114,7 @@ SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector);
"(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
"@end lisp")
*/
-SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
+SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
(SCM l),
"@deffnx {Scheme Procedure} list->vector l\n"
"Return a newly allocated vector composed of the\n"
@@ -141,27 +128,24 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
SCM res;
SCM *data;
long i, len;
- scm_t_array_handle handle;
SCM_VALIDATE_LIST_COPYLEN (1, l, len);
res = scm_c_make_vector (len, SCM_UNSPECIFIED);
- data = scm_vector_writable_elements (res, &handle, NULL, NULL);
+ data = SCM_I_VECTOR_WELTS (res);
i = 0;
- while (scm_is_pair (l) && i < len)
+ while (scm_is_pair (l) && i < len)
{
data[i] = SCM_CAR (l);
l = SCM_CDR (l);
i += 1;
}
- scm_array_handle_release (&handle);
-
return res;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vector_ref, "vector-ref", 2, 0, 0,
+SCM_DEFINE (scm_vector_ref, "vector-ref", 2, 0, 0,
(SCM vector, SCM k),
"@var{k} must be a valid index of @var{vector}.\n"
"@samp{Vector-ref} returns the contents of element @var{k} of\n"
@@ -193,7 +177,7 @@ scm_c_vector_ref (SCM v, size_t k)
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vector_set_x, "vector-set!", 3, 0, 0,
+SCM_DEFINE (scm_vector_set_x, "vector-set!", 3, 0, 0,
(SCM vector, SCM k, SCM obj),
"@var{k} must be a valid index of @var{vector}.\n"
"@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n"
@@ -218,7 +202,7 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj)
SCM_VALIDATE_VECTOR (1, v);
if (k >= SCM_I_VECTOR_LENGTH (v))
- scm_out_of_range (NULL, scm_from_size_t (k));
+ scm_out_of_range (NULL, scm_from_size_t (k));
SCM_SIMPLE_VECTOR_SET (v, k, obj);
}
@@ -236,7 +220,7 @@ SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0,
if (SCM_UNBNDP (fill))
fill = SCM_UNSPECIFIED;
-
+
return scm_c_make_vector (l, fill);
}
#undef FUNC_NAME
@@ -285,7 +269,7 @@ SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0,
#undef FUNC_NAME
\f
-SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0,
+SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0,
(SCM v),
"Return a newly allocated list composed of the elements of @var{v}.\n"
"\n"
@@ -345,7 +329,7 @@ scm_i_vector_equal_p (SCM x, SCM y)
}
-SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0,
+SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0,
(SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
"Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
"to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
@@ -362,7 +346,7 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0,
size_t len1, len2;
ssize_t inc1, inc2;
size_t i, j, e;
-
+
elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);
@@ -371,7 +355,7 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0,
SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) <= len2);
j = scm_to_unsigned_integer (start2, 0, len2);
SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i));
-
+
i *= inc1;
e *= inc1;
j *= inc2;
@@ -385,7 +369,7 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
+SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
(SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
"Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
"to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
@@ -402,7 +386,7 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
size_t len1, len2;
ssize_t inc1, inc2;
size_t i, j, e;
-
+
elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);
@@ -411,9 +395,9 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) <= len2);
j = scm_to_unsigned_integer (start2, 0, len2);
SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i));
-
+
j += (e - i);
-
+
i *= inc1;
e *= inc1;
j *= inc2;
--
2.7.3
[-- Attachment #10: 0009-Speed-up-for-multi-arg-cases-of-scm_ramap-functions.patch --]
[-- Type: application/octet-stream, Size: 12932 bytes --]
From 84361ff68ecd09274e0709e269c75363b0c13407 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Fri, 13 Feb 2015 18:42:27 +0100
Subject: [PATCH 09/13] Speed up for multi-arg cases of scm_ramap functions
This patch results in a 20%-40% speedup in the > 1 argument cases of
the following microbenchmarks:
(define A (make-shared-array #0(1) (const '()) #e1e7))
; 1, 2, 3 arguments.
(define a 0) ,time (array-for-each (lambda (b) (set! a (+ a b))) A)
(define a 0) ,time (array-for-each (lambda (b c) (set! a (+ a b c))) A A)
(define a 0) ,time (array-for-each (lambda (b c d) (set! a (+ a b c d))) A A A)
(define A (make-shared-array (make-array 1) (const '()) #e1e7))
(define B (make-shared-array #0(1) (const '()) #e1e7))
; 1, 2, 3 arguments.
,time (array-map! A + B)
,time (array-map! A + B B)
,time (array-map! A + B B B)
* libguile/array-map.c (scm_ramap): Note on cproc arguments.
(rafill): Assume that dst's lbnd is 0.
(racp): Assume that src's lbnd is 0.
(ramap): Assume that ra0's lbnd is 0. When there're more than two
arguments, compute the array handles before the loop. Allocate the arg
list once and reuse it in the loop.
(rafe): Do as in ramap(), when there's more than one argument.
(AREF, ASET): Remove.
---
libguile/array-map.c | 151 +++++++++++++++++++++++---------------------
libguile/array-map.h | 2 +-
test-suite/tests/ramap.test | 10 +--
3 files changed, 86 insertions(+), 77 deletions(-)
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 587df02..058b6fe 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
- * 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+ * 2010, 2011, 2012, 2013, 2014, 2015 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
@@ -48,18 +48,6 @@
static const char vi_gc_hint[] = "array-indices";
static SCM
-AREF (SCM v, size_t pos)
-{
- return scm_c_array_ref_1 (v, pos);
-}
-
-static void
-ASET (SCM v, size_t pos, SCM val)
-{
- scm_c_array_set_1_x (v, val, pos);
-}
-
-static SCM
make1array (SCM v, ssize_t inc)
{
SCM a = scm_i_make_array (1);
@@ -99,6 +87,10 @@ cindk (SCM ra, ssize_t *ve, int kend)
#define LBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].lbnd
#define UBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].ubnd
+
+/* scm_ramapc() always calls cproc with rank-1 arrays created by
+ make1array. cproc (rafe, ramap, rafill, racp) can assume that the
+ dims[0].lbnd of these arrays is always 0. */
int
scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
{
@@ -167,7 +159,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
va1 = make1array (ra1, 1);
- if (LBND (ra0, 0) < LBND (va1, 0) || UBND (ra0, 0) > UBND (va1, 0))
+ if (LBND (ra0, 0) < 0 /* LBND (va1, 0) */ || UBND (ra0, 0) > UBND (va1, 0))
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
}
*plva = scm_cons (va1, SCM_EOL);
@@ -224,14 +216,12 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
static int
rafill (SCM dst, SCM fill)
{
- scm_t_array_handle h;
- size_t n, i;
- ssize_t inc;
- scm_array_get_handle (SCM_I_ARRAY_V (dst), &h);
- i = SCM_I_ARRAY_BASE (dst);
- inc = SCM_I_ARRAY_DIMS (dst)->inc;
- n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1);
+ size_t n = SCM_I_ARRAY_DIMS (dst)->ubnd + 1;
+ size_t i = SCM_I_ARRAY_BASE (dst);
+ ssize_t inc = SCM_I_ARRAY_DIMS (dst)->inc;
dst = SCM_I_ARRAY_V (dst);
+ scm_t_array_handle h;
+ scm_array_get_handle (dst, &h);
for (; n-- > 0; i += inc)
h.vset (h.vector, i, fill);
@@ -255,19 +245,15 @@ SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
static int
racp (SCM src, SCM dst)
{
- scm_t_array_handle h_s, h_d;
- size_t n, i_s, i_d;
- ssize_t inc_s, inc_d;
-
dst = SCM_CAR (dst);
- i_s = SCM_I_ARRAY_BASE (src);
- i_d = SCM_I_ARRAY_BASE (dst);
- inc_s = SCM_I_ARRAY_DIMS (src)->inc;
- inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
- n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
+ size_t i_s = SCM_I_ARRAY_BASE (src);
+ size_t i_d = SCM_I_ARRAY_BASE (dst);
+ size_t n = (SCM_I_ARRAY_DIMS (src)->ubnd + 1);
+ ssize_t inc_s = SCM_I_ARRAY_DIMS (src)->inc;
+ ssize_t inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
src = SCM_I_ARRAY_V (src);
dst = SCM_I_ARRAY_V (dst);
-
+ scm_t_array_handle h_s, h_d;
scm_array_get_handle (src, &h_s);
scm_array_get_handle (dst, &h_d);
@@ -310,44 +296,56 @@ SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
static int
ramap (SCM ra0, SCM proc, SCM ras)
{
- scm_t_array_handle h0;
- size_t n, i0;
- ssize_t i, inc0;
- i0 = SCM_I_ARRAY_BASE (ra0);
- inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
- n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
+ size_t i0 = SCM_I_ARRAY_BASE (ra0);
+ ssize_t inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd + 1;
ra0 = SCM_I_ARRAY_V (ra0);
+ scm_t_array_handle h0;
scm_array_get_handle (ra0, &h0);
+
if (scm_is_null (ras))
for (; n--; i0 += inc0)
h0.vset (h0.vector, i0, scm_call_0 (proc));
else
{
SCM ra1 = SCM_CAR (ras);
- scm_t_array_handle h1;
- size_t i1;
- ssize_t inc1;
- i1 = SCM_I_ARRAY_BASE (ra1);
- inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
ras = SCM_CDR (ras);
+ size_t i1 = SCM_I_ARRAY_BASE (ra1);
+ ssize_t inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
ra1 = SCM_I_ARRAY_V (ra1);
+ scm_t_array_handle h1;
scm_array_get_handle (ra1, &h1);
if (scm_is_null (ras))
for (; n--; i0 += inc0, i1 += inc1)
h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1)));
else
{
- ras = scm_vector (ras);
- for (; n--; i0 += inc0, i1 += inc1, ++i)
+ size_t restn = scm_ilength (ras);
+
+ SCM args = SCM_EOL;
+ SCM *p = &args;
+ SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k)
+ {
+ *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
+ sa[k] = SCM_CARLOC (*p);
+ p = SCM_CDRLOC (*p);
+ }
+
+ scm_t_array_handle *hs = scm_gc_malloc
+ (sizeof(scm_t_array_handle) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k, ras = scm_cdr (ras))
+ scm_array_get_handle (scm_car (ras), hs+k);
+
+ for (ssize_t i = 0; n--; i0 += inc0, i1 += inc1, ++i)
{
- SCM args = SCM_EOL;
- unsigned long k;
- for (k = scm_c_vector_length (ras); k--;)
- args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
- h0.vset (h0.vector, i0,
- scm_apply_1 (proc, h1.vref (h1.vector, i1), args));
+ for (size_t k = 0; k < restn; ++k)
+ *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc);
+ h0.vset (h0.vector, i0, scm_apply_1 (proc, h1.vref (h1.vector, i1), args));
}
+
+ for (size_t k = 0; k < restn; ++k)
+ scm_array_handle_release (hs+k);
}
scm_array_handle_release (&h1);
}
@@ -384,30 +382,44 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
static int
rafe (SCM ra0, SCM proc, SCM ras)
{
- ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
- size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
-
- scm_t_array_handle h0;
- size_t i0;
- ssize_t inc0;
- i0 = SCM_I_ARRAY_BASE (ra0);
- inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ size_t i0 = SCM_I_ARRAY_BASE (ra0);
+ ssize_t inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd + 1;
ra0 = SCM_I_ARRAY_V (ra0);
+ scm_t_array_handle h0;
scm_array_get_handle (ra0, &h0);
+
if (scm_is_null (ras))
for (; n--; i0 += inc0)
scm_call_1 (proc, h0.vref (h0.vector, i0));
else
{
- ras = scm_vector (ras);
- for (; n--; i0 += inc0, ++i)
+ size_t restn = scm_ilength (ras);
+
+ SCM args = SCM_EOL;
+ SCM *p = &args;
+ SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k)
{
- SCM args = SCM_EOL;
- unsigned long k;
- for (k = scm_c_vector_length (ras); k--;)
- args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
+ *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
+ sa[k] = SCM_CARLOC (*p);
+ p = SCM_CDRLOC (*p);
+ }
+
+ scm_t_array_handle *hs = scm_gc_malloc
+ (sizeof(scm_t_array_handle) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k, ras = scm_cdr (ras))
+ scm_array_get_handle (scm_car (ras), hs+k);
+
+ for (ssize_t i = 0; n--; i0 += inc0, ++i)
+ {
+ for (size_t k = 0; k < restn; ++k)
+ *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc);
scm_apply_1 (proc, h0.vref (h0.vector, i0), args);
}
+
+ for (size_t k = 0; k < restn; ++k)
+ scm_array_handle_release (hs+k);
}
scm_array_handle_release (&h0);
return 1;
@@ -445,15 +457,12 @@ static void
array_index_map_n (SCM ra, SCM proc)
{
scm_t_array_handle h;
- size_t i;
int k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
- ssize_t *vi;
- SCM **si;
SCM args = SCM_EOL;
SCM *p = &args;
- vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * (kmax + 1), vi_gc_hint);
- si = scm_gc_malloc_pointerless (sizeof(SCM *) * (kmax + 1), vi_gc_hint);
+ ssize_t *vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * (kmax + 1), vi_gc_hint);
+ SCM **si = scm_gc_malloc_pointerless (sizeof(SCM *) * (kmax + 1), vi_gc_hint);
for (k = 0; k <= kmax; k++)
{
@@ -472,7 +481,7 @@ array_index_map_n (SCM ra, SCM proc)
if (k == kmax)
{
vi[kmax] = SCM_I_ARRAY_DIMS (ra)[kmax].lbnd;
- i = cindk (ra, vi, kmax+1);
+ size_t i = cindk (ra, vi, kmax+1);
for (; vi[kmax] <= SCM_I_ARRAY_DIMS (ra)[kmax].ubnd; ++vi[kmax])
{
*(si[kmax]) = scm_from_ssize_t (vi[kmax]);
diff --git a/libguile/array-map.h b/libguile/array-map.h
index e7431b1..cb18a62 100644
--- a/libguile/array-map.h
+++ b/libguile/array-map.h
@@ -4,7 +4,7 @@
#define SCM_ARRAY_MAP_H
/* Copyright (C) 1995, 1996, 1997, 2000, 2006, 2008, 2009, 2010,
- * 2011, 2013 Free Software Foundation, Inc.
+ * 2011, 2013, 2015 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
diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
index c8eaf96..d8241ef 100644
--- a/test-suite/tests/ramap.test
+++ b/test-suite/tests/ramap.test
@@ -1,17 +1,17 @@
;;;; ramap.test --- test array mapping functions -*- scheme -*-
-;;;;
+;;;;
;;;; Copyright (C) 2004, 2005, 2006, 2009, 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
@@ -453,11 +453,11 @@
(with-test-prefix "3 sources"
(pass-if-equal "noncompact arrays 1"
- '((3 3 3) (2 2 2))
+ '((3 1 3) (2 0 2))
(let* ((a #2((0 1) (2 3)))
(l '())
(rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-row a 1) (array-row a 1) (array-row a 1))
+ (array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1))
l))
(pass-if-equal "noncompact arrays 2"
--
2.7.3
[-- Attachment #11: 0010-Special-case-for-array-map-with-three-arguments.patch --]
[-- Type: application/octet-stream, Size: 4021 bytes --]
From b3727a29c74fb351627bc8166b293ef34e72c11e Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 9 Dec 2015 13:10:48 +0100
Subject: [PATCH 10/13] Special case for array-map! with three arguments
Benchmark:
(define type #t)
(define A (make-typed-array 's32 0 10000 1000))
(define B (make-typed-array 's32 0 10000 1000))
(define C (make-typed-array 's32 0 10000 1000))
before:
scheme@(guile-user)> ,time (array-map! C + A B)
;; 0.792653s real time, 0.790970s run time. 0.000000s spent in GC.
after:
scheme@(guile-user)> ,time (array-map! C + A B)
;; 0.598513s real time, 0.597146s run time. 0.000000s spent in GC.
* libguile/array-map.c (ramap): Add special case with 3 arguments.
---
libguile/array-map.c | 56 ++++++++++++++++++++++++++++++++--------------------
1 file changed, 35 insertions(+), 21 deletions(-)
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 058b6fe..f07fd00 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -320,32 +320,46 @@ ramap (SCM ra0, SCM proc, SCM ras)
h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1)));
else
{
- size_t restn = scm_ilength (ras);
-
- SCM args = SCM_EOL;
- SCM *p = &args;
- SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint);
- for (size_t k = 0; k < restn; ++k)
+ SCM ra2 = SCM_CAR (ras);
+ ras = SCM_CDR (ras);
+ size_t i2 = SCM_I_ARRAY_BASE (ra2);
+ ssize_t inc2 = SCM_I_ARRAY_DIMS (ra2)->inc;
+ ra2 = SCM_I_ARRAY_V (ra2);
+ scm_t_array_handle h2;
+ scm_array_get_handle (ra2, &h2);
+ if (scm_is_null (ras))
+ for (; n--; i0 += inc0, i1 += inc1, i2 += inc2)
+ h0.vset (h0.vector, i0, scm_call_2 (proc, h1.vref (h1.vector, i1), h2.vref (h2.vector, i2)));
+ else
{
- *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
- sa[k] = SCM_CARLOC (*p);
- p = SCM_CDRLOC (*p);
- }
+ size_t restn = scm_ilength (ras);
- scm_t_array_handle *hs = scm_gc_malloc
- (sizeof(scm_t_array_handle) * restn, vi_gc_hint);
- for (size_t k = 0; k < restn; ++k, ras = scm_cdr (ras))
- scm_array_get_handle (scm_car (ras), hs+k);
+ SCM args = SCM_EOL;
+ SCM *p = &args;
+ SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k)
+ {
+ *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
+ sa[k] = SCM_CARLOC (*p);
+ p = SCM_CDRLOC (*p);
+ }
+
+ scm_t_array_handle *hs = scm_gc_malloc
+ (sizeof(scm_t_array_handle) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k, ras = scm_cdr (ras))
+ scm_array_get_handle (scm_car (ras), hs+k);
+
+ for (ssize_t i = 0; n--; i0 += inc0, i1 += inc1, i2 += inc2, ++i)
+ {
+ for (size_t k = 0; k < restn; ++k)
+ *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc);
+ h0.vset (h0.vector, i0, scm_apply_2 (proc, h1.vref (h1.vector, i1), h2.vref (h2.vector, i2), args));
+ }
- for (ssize_t i = 0; n--; i0 += inc0, i1 += inc1, ++i)
- {
for (size_t k = 0; k < restn; ++k)
- *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc);
- h0.vset (h0.vector, i0, scm_apply_1 (proc, h1.vref (h1.vector, i1), args));
+ scm_array_handle_release (hs+k);
}
-
- for (size_t k = 0; k < restn; ++k)
- scm_array_handle_release (hs+k);
+ scm_array_handle_release (&h2);
}
scm_array_handle_release (&h1);
}
--
2.7.3
[-- Attachment #12: 0011-New-functions-array-for-each-cell-array-for-each-cel.patch --]
[-- Type: application/octet-stream, Size: 59355 bytes --]
From bdd3402674704f53ac8a5a0b59454cb77d625655 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Tue, 8 Sep 2015 16:57:30 +0200
Subject: [PATCH 11/13] New functions (array-for-each-cell,
array-for-each-cell-in-order)
* libguile/array-map.c (scm_i_array_rebase, scm_array_for_each_cell):
New functions. Export scm_array_for_each_cell() as
(array-for-each-cell).
(array-for-each-cell-in-order): Define additional export.
* libguile/array-map.h (scm_i_array_rebase, scm_array_for_each_cell):
Add prototypes.
* doc/ref/api-compound.texi: New section 'Arrays as arrays of
arrays'. Move the documentation for (array-from), (array-from*) and
(array-amend!) in here. Add documentation for (array-for-each-cell).
* test-suite/tests/array-map.test: Renamed from
test-suite/tests/ramap.test, fix module name. Add tests for
(array-for-each-cell).
* test-suite/Makefile.am: Apply rename array-map.test -> ramap.test.
* doc/ref/api-compound.texi: Minor documentation fixes.
---
doc/ref/api-compound.texi | 169 +++++++++----
libguile/array-map.c | 265 +++++++++++++++++++-
libguile/array-map.h | 4 +
libguile/arrays.c | 5 +-
test-suite/Makefile.am | 2 +-
test-suite/tests/array-map.test | 540 ++++++++++++++++++++++++++++++++++++++++
test-suite/tests/ramap.test | 509 -------------------------------------
7 files changed, 929 insertions(+), 565 deletions(-)
create mode 100644 test-suite/tests/array-map.test
delete mode 100644 test-suite/tests/ramap.test
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index 7f70374..ef4869c 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1203,6 +1203,7 @@ dimensional arrays.
* Array Syntax::
* Array Procedures::
* Shared Arrays::
+* Arrays as arrays of arrays::
* Accessing Arrays from C::
@end menu
@@ -1715,24 +1716,91 @@ sample points are enough because @var{mapfunc} is linear.
Return the element at @code{(idx @dots{})} in @var{array}.
@end deffn
+
+@deffn {Scheme Procedure} shared-array-increments array
+@deffnx {C Function} scm_shared_array_increments (array)
+For each dimension, return the distance between elements in the root vector.
+@end deffn
+
+@deffn {Scheme Procedure} shared-array-offset array
+@deffnx {C Function} scm_shared_array_offset (array)
+Return the root vector index of the first element in the array.
+@end deffn
+
+@deffn {Scheme Procedure} shared-array-root array
+@deffnx {C Function} scm_shared_array_root (array)
+Return the root vector of a shared array.
+@end deffn
+
+@deffn {Scheme Procedure} array-contents array [strict]
+@deffnx {C Function} scm_array_contents (array, strict)
+If @var{array} may be @dfn{unrolled} into a one dimensional shared array
+without changing their order (last subscript changing fastest), then
+@code{array-contents} returns that shared array, otherwise it returns
+@code{#f}. All arrays made by @code{make-array} and
+@code{make-typed-array} may be unrolled, some arrays made by
+@code{make-shared-array} may not be.
+
+If the optional argument @var{strict} is provided, a shared array will
+be returned only if its elements are stored internally contiguous in
+memory.
+@end deffn
+
+@deffn {Scheme Procedure} transpose-array array dim1 dim2 @dots{}
+@deffnx {C Function} scm_transpose_array (array, dimlist)
+Return an array sharing contents with @var{array}, but with
+dimensions arranged in a different order. There must be one
+@var{dim} argument for each dimension of @var{array}.
+@var{dim1}, @var{dim2}, @dots{} should be integers between 0
+and the rank of the array to be returned. Each integer in that
+range must appear at least once in the argument list.
+
+The values of @var{dim1}, @var{dim2}, @dots{} correspond to
+dimensions in the array to be returned, and their positions in the
+argument list to dimensions of @var{array}. Several @var{dim}s
+may have the same value, in which case the returned array will
+have smaller rank than @var{array}.
+
+@lisp
+(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))
+(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)
+(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}
+ #2((a 4) (b 5) (c 6))
+@end lisp
+@end deffn
+
+@node Arrays as arrays of arrays
+@subsubsection Arrays as arrays of arrays
+
+The functions in this section allow you to treat an array of rank
+@math{n} as an array of lower rank @math{n-k} where the elements are
+themselves arrays (`cells') of rank @math{k}. This replicates some of
+the functionality of `enclosed arrays', a feature of old Guile that was
+removed before @w{version 2.0}. However, these functions do not require
+a special type and operate on any array.
+
+When we operate on an array in this way, we speak of the first @math{k}
+dimensions of the array as the @math{k}-`frame' of the array, while the
+last @math{n-k} dimensions are the dimensions of the
+@math{n-k}-`cell'. For example, a 2D-array (a matrix) can be seen as a
+1D array of rows. In this case, the rows are the 1-cells of the array.
+
@deffn {Scheme Procedure} array-from array idx @dots{}
@deffnx {C Function} scm_array_from (array, idxlist)
If the length of @var{idxlist} equals the rank @math{n} of
@var{array}, return the element at @code{(idx @dots{})}, just like
@code{(array-ref array idx @dots{})}. If, however, the length @math{k}
of @var{idxlist} is shorter than @math{n}, then return the shared
-@math{(n-k)}-rank prefix cell of @var{array} given by @var{idxlist}.
+@math{(n-k)}-rank cell of @var{array} given by @var{idxlist}.
For example:
-@example
@lisp
(array-from #2((a b) (c d)) 0) @result{} #(a b)
(array-from #2((a b) (c d)) 1) @result{} #(c d)
(array-from #2((a b) (c d)) 1 1) @result{} d
(array-from #2((a b) (c d))) @result{} #2((a b) (c d))
@end lisp
-@end example
@code{(apply array-from array indices)} is equivalent to
@@ -1752,12 +1820,11 @@ The name `from' comes from the J language.
@deffnx {C Function} scm_array_from_s (array, idxlist)
Like @code{(array-from array idx @dots{})}, but return a 0-rank shared
array if the length of @var{idxlist} matches the rank of
-@var{array}. This can be useful when using @var{ARRAY} as destination
-of copies.
+@var{array}. This can be useful when using @var{ARRAY} as a place to
+write into.
Compare:
-@example
@lisp
(array-from #2((a b) (c d)) 1 1) @result{} d
(array-from* #2((a b) (c d)) 1) @result{} #0(d)
@@ -1766,7 +1833,6 @@ Compare:
a @result{} #2((a a) (a b)).
(array-fill! (array-from a 1 1) 'b) @result{} error: not an array
@end lisp
-@end example
@code{(apply array-from* array indices)} is equivalent to
@@ -1785,7 +1851,7 @@ If the length of @var{idxlist} equals the rank @math{n} of
@var{x}, just like @code{(array-set! array x idx @dots{})}. If,
however, the length @math{k} of @var{idxlist} is shorter than
@math{n}, then copy the @math{(n-k)}-rank array @var{x}
-into @math{(n-k)}-rank prefix cell of @var{array} given by
+into the @math{(n-k)}-cell of @var{array} given by
@var{idxlist}. In this case, the last @math{(n-k)} dimensions of
@var{array} and the dimensions of @var{x} must match exactly.
@@ -1793,12 +1859,19 @@ This function returns the modified @var{array}.
For example:
-@example
@lisp
(array-amend! (make-array 'a 2 2) b 1 1) @result{} #2((a a) (a b))
(array-amend! (make-array 'a 2 2) #(x y) 1) @result{} #2((a a) (x y))
@end lisp
-@end example
+
+Note that @code{array-amend!} will expect elements, not arrays, when the
+destination has rank 0. One can work around this using
+@code{array-from*} instead.
+
+@lisp
+(array-amend! (make-array 'a 2 2) #0(b) 1 1) @result{} #2((a a) (a #0(b)))
+(let ((a (make-array 'a 2 2))) (array-copy! #0(b) (array-from* a 1 1)) a) @result{} #2((a a) (a b))
+@end lisp
@code{(apply array-amend! array x indices)} is equivalent to
@@ -1814,58 +1887,52 @@ The name `amend' comes from the J language.
@end deffn
-@deffn {Scheme Procedure} shared-array-increments array
-@deffnx {C Function} scm_shared_array_increments (array)
-For each dimension, return the distance between elements in the root vector.
-@end deffn
+@deffn {Scheme Procedure} array-for-each-cell frame-rank op x @dots{}
+@deffnx {C Function} scm_array_for_each_cell (array, frame_rank, op, xlist)
+Each @var{x} must be an array of rank ≥ @var{frame-rank}, and
+the first @var{frame-rank} dimensions of each @var{x} must all be the
+same. @var{array-for-each-cell} calls @var{op} with each set of
+(rank(@var{x}) - @var{frame-rank})-cells from @var{x}, in unspecified order.
-@deffn {Scheme Procedure} shared-array-offset array
-@deffnx {C Function} scm_shared_array_offset (array)
-Return the root vector index of the first element in the array.
-@end deffn
+@var{array-for-each-cell} allows you to loop over cells of any rank
+without having to carry an index list or construct slices manually. The
+cells passed to @var{op} are shared arrays of @var{X} so it is possible
+to write to them.
-@deffn {Scheme Procedure} shared-array-root array
-@deffnx {C Function} scm_shared_array_root (array)
-Return the root vector of a shared array.
-@end deffn
+This function returns an unspecified value.
-@deffn {Scheme Procedure} array-contents array [strict]
-@deffnx {C Function} scm_array_contents (array, strict)
-If @var{array} may be @dfn{unrolled} into a one dimensional shared array
-without changing their order (last subscript changing fastest), then
-@code{array-contents} returns that shared array, otherwise it returns
-@code{#f}. All arrays made by @code{make-array} and
-@code{make-typed-array} may be unrolled, some arrays made by
-@code{make-shared-array} may not be.
+For example, to sort the rows of rank-2 array @code{a}:
-If the optional argument @var{strict} is provided, a shared array will
-be returned only if its elements are stored internally contiguous in
-memory.
-@end deffn
+@lisp
+(array-for-each-cell 1 (lambda (x) (sort! x <)) a)
+@end lisp
-@deffn {Scheme Procedure} transpose-array array dim1 dim2 @dots{}
-@deffnx {C Function} scm_transpose_array (array, dimlist)
-Return an array sharing contents with @var{array}, but with
-dimensions arranged in a different order. There must be one
-@var{dim} argument for each dimension of @var{array}.
-@var{dim1}, @var{dim2}, @dots{} should be integers between 0
-and the rank of the array to be returned. Each integer in that
-range must appear at least once in the argument list.
+As another example, let @code{a} be a rank-2 array where each row is a 2-vector @math{(x,y)}.
+Let's compute the arguments of these vectors and store them in rank-1 array @code{b}.
+@lisp
+(array-for-each-cell 1
+ (lambda (a b)
+ (array-set! b (atan (array-ref a 1) (array-ref a 0))))
+ a b)
+@end lisp
-The values of @var{dim1}, @var{dim2}, @dots{} correspond to
-dimensions in the array to be returned, and their positions in the
-argument list to dimensions of @var{array}. Several @var{dim}s
-may have the same value, in which case the returned array will
-have smaller rank than @var{array}.
+@code{(apply array-for-each-cell frame-rank op x)} is functionally
+equivalent to
@lisp
-(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))
-(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)
-(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}
- #2((a 4) (b 5) (c 6))
+(let ((frame (take (array-dimensions (car x)) frank)))
+ (unless (every (lambda (x)
+ (equal? frame (take (array-dimensions x) frank)))
+ (cdr x))
+ (error))
+ (array-index-map!
+ (apply make-shared-array (make-array #t) (const '()) frame)
+ (lambda i (apply op (map (lambda (x) (apply array-from* x i)) x)))))
@end lisp
+
@end deffn
+
@node Accessing Arrays from C
@subsubsection Accessing Arrays from C
diff --git a/libguile/array-map.c b/libguile/array-map.c
index f07fd00..6c3772e 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -42,6 +42,8 @@
#include "libguile/validate.h"
#include "libguile/array-map.h"
+
+#include <assert.h>
\f
/* The WHAT argument for `scm_gc_malloc ()' et al. */
@@ -624,7 +626,8 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
return SCM_BOOL_T;
while (!scm_is_null (rest))
- { if (scm_is_false (scm_array_equal_p (ra0, ra1)))
+ {
+ if (scm_is_false (scm_array_equal_p (ra0, ra1)))
return SCM_BOOL_F;
ra0 = ra1;
ra1 = scm_car (rest);
@@ -635,6 +638,265 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
#undef FUNC_NAME
+// Copy array descriptor with different base.
+SCM
+scm_i_array_rebase (SCM a, size_t base)
+{
+ size_t ndim = SCM_I_ARRAY_NDIM (a);
+ SCM b = scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3);
+ SCM_I_ARRAY_SET_V (b, SCM_I_ARRAY_V (a));
+// FIXME do check base
+ SCM_I_ARRAY_SET_BASE (b, base);
+ memcpy (SCM_I_ARRAY_DIMS (b), SCM_I_ARRAY_DIMS (a), sizeof (scm_t_array_dim)*ndim);
+ return b;
+}
+
+static inline size_t padtoptr(size_t d) { return (d + (sizeof (void *) - 1)) & ~(sizeof (void *) - 1); }
+
+SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1,
+ (SCM frame_rank, SCM op, SCM args),
+ "Apply @var{op} to each of the cells of rank rank(@var{arg})-@var{frame_rank}\n"
+ "of the arrays @var{args}, in unspecified order. The first\n"
+ "@var{frame_rank} dimensions of each @var{arg} must match.\n"
+ "Rank-0 cells are passed as rank-0 arrays.\n\n"
+ "The value returned is unspecified.\n\n"
+ "For example:\n"
+ "@lisp\n"
+ ";; Sort the rows of rank-2 array A.\n\n"
+ "(array-for-each-cell 1 (lambda (x) (sort! x <)) a)\n"
+ "\n"
+ ";; Compute the arguments of the (x y) vectors in the rows of rank-2\n"
+ ";; array XYS and store them in rank-1 array ANGLES. Inside OP,\n"
+ ";; XY is a rank-1 (2-1) array, and ANGLE is a rank-0 (1-1) array.\n\n"
+ "(array-for-each-cell 1 \n"
+ " (lambda (xy angle)\n"
+ " (array-set! angle (atan (array-ref xy 1) (array-ref xy 0))))\n"
+ " xys angles)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_for_each_cell
+{
+ int const N = scm_ilength (args);
+ int const frank = scm_to_int (frame_rank);
+ SCM dargs_ = SCM_EOL;
+
+ size_t stack_size = 0;
+ stack_size += padtoptr(N*sizeof (scm_t_array_handle));
+ stack_size += padtoptr(N*sizeof (SCM));
+ stack_size += padtoptr(N*sizeof (scm_t_array_dim *));
+ stack_size += padtoptr(N*sizeof (int));
+
+ stack_size += padtoptr(frank*sizeof (ssize_t));
+ stack_size += padtoptr(N*sizeof (SCM));
+ stack_size += padtoptr(N*sizeof (SCM *));
+ stack_size += padtoptr(frank*sizeof (ssize_t));
+
+ stack_size += padtoptr(frank*sizeof (int));
+ stack_size += padtoptr(N*sizeof (size_t));
+ char * stack = scm_gc_malloc (stack_size, "stack");
+
+#define AFIC_ALLOC_ADVANCE(stack, count, type, name) \
+ type * name = (void *)stack; \
+ stack += padtoptr(count*sizeof (type));
+
+ char * stack0 = stack;
+ AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_handle, ah);
+ AFIC_ALLOC_ADVANCE (stack, N, SCM, args_);
+ AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_dim *, as);
+ AFIC_ALLOC_ADVANCE (stack, N, int, rank);
+
+ AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, s);
+ AFIC_ALLOC_ADVANCE (stack, N, SCM, ai);
+ AFIC_ALLOC_ADVANCE (stack, N, SCM *, dargs);
+ AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, i);
+
+ AFIC_ALLOC_ADVANCE (stack, frank, int, order);
+ AFIC_ALLOC_ADVANCE (stack, N, size_t, base);
+ assert((stack0+stack_size==stack) && "internal error");
+#undef AFIC_ALLOC_ADVANCE
+
+ for (int n=0; scm_is_pair(args); args=scm_cdr(args), ++n)
+ {
+ args_[n] = scm_car(args);
+ scm_array_get_handle(args_[n], ah+n);
+ as[n] = scm_array_handle_dims(ah+n);
+ rank[n] = scm_array_handle_rank(ah+n);
+ }
+ // checks.
+ char const * msg = NULL;
+ if (frank<0)
+ {
+ msg = "bad frame rank";
+ }
+ else
+ {
+ for (int n=0; n!=N; ++n)
+ {
+ if (rank[n]<frank)
+ {
+ msg = "frame too large for arguments";
+ goto check_msg;
+ }
+ for (int k=0; k!=frank; ++k)
+ {
+ if (as[n][k].lbnd!=0)
+ {
+ msg = "non-zero base index is not supported";
+ goto check_msg;
+ }
+ if (as[0][k].ubnd!=as[n][k].ubnd)
+ {
+ msg = "mismatched frames";
+ goto check_msg;
+ }
+ s[k] = as[n][k].ubnd + 1;
+
+ // this check is needed if the array cannot be entirely
+ // unrolled, because the unrolled subloop will be run before
+ // checking the dimensions of the frame.
+ if (s[k]==0)
+ {
+ goto end;
+ }
+ }
+ }
+ }
+ check_msg: ;
+ if (msg!=NULL)
+ {
+ for (int n=0; n!=N; ++n)
+ {
+ scm_array_handle_release(ah+n);
+ }
+ scm_misc_error("array-for-each-cell", msg, scm_cons_star(frame_rank, args));
+ }
+ // prepare moving cells.
+ for (int n=0; n!=N; ++n)
+ {
+ ai[n] = scm_i_make_array(rank[n]-frank);
+ SCM_I_ARRAY_SET_V (ai[n], scm_shared_array_root(args_[n]));
+ // FIXME scm_array_handle_base (ah+n) should be in Guile
+ SCM_I_ARRAY_SET_BASE (ai[n], ah[n].base);
+ scm_t_array_dim * ais = SCM_I_ARRAY_DIMS(ai[n]);
+ for (int k=frank; k!=rank[n]; ++k)
+ {
+ ais[k-frank] = as[n][k];
+ }
+ }
+ // prepare rest list for callee.
+ {
+ SCM *p = &dargs_;
+ for (int n=0; n<N; ++n)
+ {
+ *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
+ dargs[n] = SCM_CARLOC (*p);
+ p = SCM_CDRLOC (*p);
+ }
+ }
+ // special case for rank 0.
+ if (frank==0)
+ {
+ for (int n=0; n<N; ++n)
+ {
+ *dargs[n] = ai[n];
+ }
+ scm_apply_0(op, dargs_);
+ for (int n=0; n<N; ++n)
+ {
+ scm_array_handle_release(ah+n);
+ }
+ return SCM_UNSPECIFIED;
+ }
+ // FIXME determine best looping order.
+ for (int k=0; k!=frank; ++k)
+ {
+ i[k] = 0;
+ order[k] = frank-1-k;
+ }
+ // find outermost compact dim.
+ ssize_t step = s[order[0]];
+ int ocd = 1;
+ for (; ocd<frank; step *= s[order[ocd]], ++ocd)
+ {
+ for (int n=0; n!=N; ++n)
+ {
+ if (step*as[n][order[0]].inc!=as[n][order[ocd]].inc)
+ {
+ goto ocd_reached;
+ }
+ }
+ }
+ ocd_reached: ;
+ // rank loop.
+ for (int n=0; n!=N; ++n)
+ {
+ base[n] = SCM_I_ARRAY_BASE(ai[n]);
+ }
+ for (;;)
+ {
+ // unrolled loop.
+ for (ssize_t z=0; z!=step; ++z)
+ {
+ // we are forced to create fresh array descriptors for each
+ // call since we don't know whether the callee will keep them,
+ // and Guile offers no way to copy the descriptor (since
+ // descriptors are immutable). Yet another reason why this
+ // should be in Scheme.
+ for (int n=0; n<N; ++n)
+ {
+ *dargs[n] = scm_i_array_rebase(ai[n], base[n]);
+ base[n] += as[n][order[0]].inc;
+ }
+ scm_apply_0(op, dargs_);
+ }
+ for (int n=0; n<N; ++n)
+ {
+ base[n] -= step*as[n][order[0]].inc;
+ }
+ for (int k=ocd; ; ++k)
+ {
+ if (k==frank)
+ {
+ goto end;
+ }
+ else if (i[order[k]]<s[order[k]]-1)
+ {
+ ++i[order[k]];
+ for (int n=0; n<N; ++n)
+ {
+ base[n] += as[n][order[k]].inc;
+ }
+ break;
+ }
+ else
+ {
+ i[order[k]] = 0;
+ for (int n=0; n<N; ++n)
+ {
+ base[n] += as[n][order[k]].inc*(1-s[order[k]]);
+ }
+ }
+ }
+ }
+ end:;
+ for (int n=0; n<N; ++n)
+ {
+ scm_array_handle_release(ah+n);
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_array_for_each_cell_in_order, "array-for-each-cell-in-order", 2, 0, 1,
+ (SCM frank, SCM op, SCM a),
+ "Same as array-for-each-cell, but visit the cells sequentially\n"
+ "and in row-major order.\n")
+#define FUNC_NAME s_scm_array_for_each_cell_in_order
+{
+ return scm_array_for_each_cell (frank, op, a);
+}
+#undef FUNC_NAME
+
+
void
scm_init_array_map (void)
{
@@ -642,6 +904,7 @@ scm_init_array_map (void)
scm_add_feature (s_scm_array_for_each);
}
+
/*
Local Variables:
c-file-style: "gnu"
diff --git a/libguile/array-map.h b/libguile/array-map.h
index cb18a62..acfdd5e 100644
--- a/libguile/array-map.h
+++ b/libguile/array-map.h
@@ -37,6 +37,10 @@ SCM_API SCM scm_array_map_x (SCM ra0, SCM proc, SCM lra);
SCM_API SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra);
SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc);
SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1);
+SCM_API SCM scm_array_for_each_cell (SCM frank, SCM op, SCM args);
+SCM_API SCM scm_array_for_each_cell_in_order (SCM frank, SCM op, SCM args);
+
+SCM_INTERNAL SCM scm_i_array_rebase (SCM a, size_t base);
SCM_INTERNAL void scm_init_array_map (void);
#endif /* SCM_ARRAY_MAP_H */
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 26c4543..d360cda 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -28,7 +28,6 @@
#include <stdio.h>
#include <errno.h>
#include <string.h>
-#include <assert.h>
#include "verify.h"
@@ -546,7 +545,7 @@ SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
{ ARRAY_FROM_GET_O }
scm_array_handle_release(&handle);
/* an error is still possible here if o and b don't match. */
- /* TODO copying like this wastes the handle, and the bounds matching
+ /* FIXME copying like this wastes the handle, and the bounds matching
behavior of array-copy! is not strict. */
scm_array_copy_x(b, o);
}
@@ -564,7 +563,6 @@ SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
}
#undef FUNC_NAME
-
#undef ARRAY_FROM_POS
#undef ARRAY_FROM_GET_O
@@ -943,6 +941,7 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
}
+
void
scm_init_arrays ()
{
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 473501e..49584b9 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -115,7 +115,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/r6rs-records-syntactic.test \
tests/r6rs-unicode.test \
tests/rnrs-libraries.test \
- tests/ramap.test \
+ tests/array-map.test \
tests/random.test \
tests/rdelim.test \
tests/reader.test \
diff --git a/test-suite/tests/array-map.test b/test-suite/tests/array-map.test
new file mode 100644
index 0000000..cefe7b7
--- /dev/null
+++ b/test-suite/tests/array-map.test
@@ -0,0 +1,540 @@
+;;;; array-map.test --- test array mapping functions -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2004, 2005, 2006, 2009, 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
+
+(define-module (test-suite test-array-map)
+ #:use-module (test-suite lib))
+
+(define exception:shape-mismatch
+ (cons 'misc-error ".*shape mismatch.*"))
+
+(define (array-row a i)
+ (make-shared-array a (lambda (j) (list i j))
+ (cadr (array-dimensions a))))
+
+(define (array-col a j)
+ (make-shared-array a (lambda (i) (list i j))
+ (car (array-dimensions a))))
+
+;;;
+;;; array-index-map!
+;;;
+
+(with-test-prefix "array-index-map!"
+
+ (pass-if "basic test"
+ (let ((nlst '()))
+ (array-index-map! (make-array #f '(1 1))
+ (lambda (n)
+ (set! nlst (cons n nlst))))
+ (equal? nlst '(1))))
+
+ (with-test-prefix "empty arrays"
+
+ (pass-if "all axes empty"
+ (array-index-map! (make-typed-array 'f64 0 0 0) (const 0))
+ (array-index-map! (make-typed-array 'b #t 0 0) (const #t))
+ (array-index-map! (make-typed-array #t 0 0 0) (const 0))
+ #t)
+
+ (pass-if "last axis empty"
+ (array-index-map! (make-typed-array 'f64 0 2 0) (const 0))
+ (array-index-map! (make-typed-array 'b #t 2 0) (const #t))
+ (array-index-map! (make-typed-array #t 0 2 0) (const 0))
+ #t)
+
+ ; the 'f64 cases fail in 2.0.9 with out-of-range.
+ (pass-if "axis empty, other than last"
+ (array-index-map! (make-typed-array 'f64 0 0 2) (const 0))
+ (array-index-map! (make-typed-array 'b #t 0 2) (const #t))
+ (array-index-map! (make-typed-array #t 0 0 2) (const 0))
+ #t))
+
+ (pass-if "rank 2"
+ (let ((a (make-array 0 2 2))
+ (b (make-array 0 2 2)))
+ (array-index-map! a (lambda (i j) i))
+ (array-index-map! b (lambda (i j) j))
+ (and (array-equal? a #2((0 0) (1 1)))
+ (array-equal? b #2((0 1) (0 1)))))))
+
+;;;
+;;; array-copy!
+;;;
+
+(with-test-prefix "array-copy!"
+
+ (with-test-prefix "empty arrays"
+
+ (pass-if "empty other than last, #t"
+ (let* ((b (make-array 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-copy! #2:0:2() c)
+ (array-equal? #2:0:2() c)))
+
+ (pass-if "empty other than last, 'f64"
+ (let* ((b (make-typed-array 'f64 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-copy! #2:0:2() c)
+ (array-equal? #2f64:0:2() c)))
+
+ ;; FIXME add empty, type 'b cases.
+
+ )
+
+ ;; note that it is the opposite of array-map!. This is, unfortunately,
+ ;; documented in the manual.
+
+ (pass-if "matching behavior I"
+ (let ((a #(1 2))
+ (b (make-array 0 3)))
+ (array-copy! a b)
+ (equal? b #(1 2 0))))
+
+ (pass-if-exception "matching behavior II" exception:shape-mismatch
+ (let ((a #(1 2 3))
+ (b (make-array 0 2)))
+ (array-copy! a b)
+ (equal? b #(1 2))))
+
+ ;; here both a & b are are unrollable down to the first axis, but the
+ ;; size mismatch limits unrolling to the last axis only.
+
+ (pass-if "matching behavior III"
+ (let ((a #3(((1 2) (3 4)) ((5 6) (7 8))))
+ (b (make-array 0 2 3 2)))
+ (array-copy! a b)
+ (array-equal? b #3(((1 2) (3 4) (0 0)) ((5 6) (7 8) (0 0))))))
+
+ (pass-if "rank 0"
+ (let ((a #0(99))
+ (b (make-array 0)))
+ (array-copy! a b)
+ (equal? b #0(99))))
+
+ (pass-if "rank 1"
+ (let* ((a #2((1 2) (3 4)))
+ (b (make-shared-array a (lambda (j) (list 1 j)) 2))
+ (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
+ (d (make-array 0 2))
+ (e (make-array 0 2)))
+ (array-copy! b d)
+ (array-copy! c e)
+ (and (equal? d #(3 4))
+ (equal? e #(4 2)))))
+
+ (pass-if "rank 2"
+ (let ((a #2((1 2) (3 4)))
+ (b (make-array 0 2 2))
+ (c (make-array 0 2 2))
+ (d (make-array 0 2 2))
+ (e (make-array 0 2 2)))
+ (array-copy! a b)
+ (array-copy! a (transpose-array c 1 0))
+ (array-copy! (transpose-array a 1 0) d)
+ (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
+ (and (equal? a #2((1 2) (3 4)))
+ (equal? b #2((1 2) (3 4)))
+ (equal? c #2((1 3) (2 4)))
+ (equal? d #2((1 3) (2 4)))
+ (equal? e #2((1 2) (3 4))))))
+
+ (pass-if "rank 2, discontinuous"
+ (let ((A #2((0 1) (2 3) (4 5)))
+ (B #2((10 11) (12 13) (14 15)))
+ (C #2((20) (21) (22)))
+ (X (make-array 0 3 5))
+ (piece (lambda (X w s)
+ (make-shared-array
+ X (lambda (i j) (list i (+ j s))) 3 w))))
+ (array-copy! A (piece X 2 0))
+ (array-copy! B (piece X 2 2))
+ (array-copy! C (piece X 1 4))
+ (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
+
+ (pass-if "null increments, not empty"
+ (let ((a (make-array 0 2 2)))
+ (array-copy! (make-shared-array #0(1) (lambda x '()) 2 2) a)
+ (array-equal? #2((1 1) (1 1))))))
+
+;;;
+;;; array-map!
+;;;
+
+(with-test-prefix "array-map!"
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (array-map!))
+
+ (pass-if-exception "one arg" exception:wrong-num-args
+ (array-map! (make-array #f 5)))
+
+ (with-test-prefix "no sources"
+
+ (pass-if "closure 0"
+ (array-map! (make-array #f 5) (lambda () #f))
+ #t)
+
+ (pass-if-exception "closure 1" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x) #f)))
+
+ (pass-if-exception "closure 2" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x y) #f)))
+
+ (pass-if-exception "subr_1" exception:wrong-num-args
+ (array-map! (make-array #f 5) length))
+
+ (pass-if-exception "subr_2" exception:wrong-num-args
+ (array-map! (make-array #f 5) logtest))
+
+ (pass-if-exception "subr_2o" exception:wrong-num-args
+ (array-map! (make-array #f 5) number->string))
+
+ (pass-if-exception "dsubr" exception:wrong-num-args
+ (array-map! (make-array #f 5) sqrt))
+
+ (pass-if "rpsubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a =)
+ (equal? a (make-array #t 5))))
+
+ (pass-if "asubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a +)
+ (equal? a (make-array 0 5))))
+
+ ;; in Guile 1.6.4 and earlier this resulted in a segv
+ (pass-if "noop"
+ (array-map! (make-array #f 5) noop)
+ #t))
+
+ (with-test-prefix "one source"
+
+ (pass-if-exception "closure 0" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda () #f)
+ (make-array #f 5)))
+
+ (pass-if "closure 1"
+ (let ((a (make-array #f 5)))
+ (array-map! a (lambda (x) 'foo) (make-array #f 5))
+ (equal? a (make-array 'foo 5))))
+
+ (pass-if-exception "closure 2" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x y) #f)
+ (make-array #f 5)))
+
+ (pass-if "subr_1"
+ (let ((a (make-array #f 5)))
+ (array-map! a length (make-array '(x y z) 5))
+ (equal? a (make-array 3 5))))
+
+ (pass-if-exception "subr_2" exception:wrong-num-args
+ (array-map! (make-array #f 5) logtest
+ (make-array 999 5)))
+
+ (pass-if "subr_2o"
+ (let ((a (make-array #f 5)))
+ (array-map! a number->string (make-array 99 5))
+ (equal? a (make-array "99" 5))))
+
+ (pass-if "dsubr"
+ (let ((a (make-array #f 5)))
+ (array-map! a sqrt (make-array 16.0 5))
+ (equal? a (make-array 4.0 5))))
+
+ (pass-if "rpsubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a = (make-array 0 5))
+ (equal? a (make-array #t 5))))
+
+ (pass-if "asubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a - (make-array 99 5))
+ (equal? a (make-array -99 5))))
+
+ ;; in Guile 1.6.5 and 1.6.6 this was an error
+ (pass-if "1+"
+ (let ((a (make-array #f 5)))
+ (array-map! a 1+ (make-array 123 5))
+ (equal? a (make-array 124 5))))
+
+ (pass-if "rank 0"
+ (let ((a #0(99))
+ (b (make-array 0)))
+ (array-map! b values a)
+ (equal? b #0(99))))
+
+ (pass-if "rank 2, discontinuous"
+ (let ((A #2((0 1) (2 3) (4 5)))
+ (B #2((10 11) (12 13) (14 15)))
+ (C #2((20) (21) (22)))
+ (X (make-array 0 3 5))
+ (piece (lambda (X w s)
+ (make-shared-array
+ X (lambda (i j) (list i (+ j s))) 3 w))))
+ (array-map! (piece X 2 0) values A)
+ (array-map! (piece X 2 2) values B)
+ (array-map! (piece X 1 4) values C)
+ (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
+
+ (pass-if "null increments, not empty"
+ (let ((a (make-array 0 2 2)))
+ (array-map! a values (make-shared-array #0(1) (lambda x '()) 2 2))
+ (array-equal? a #2((1 1) (1 1))))))
+
+ (with-test-prefix "two sources"
+
+ (pass-if-exception "closure 0" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda () #f)
+ (make-array #f 5) (make-array #f 5)))
+
+ (pass-if-exception "closure 1" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x) #f)
+ (make-array #f 5) (make-array #f 5)))
+
+ (pass-if "closure 2"
+ (let ((a (make-array #f 5)))
+ (array-map! a (lambda (x y) 'foo)
+ (make-array #f 5) (make-array #f 5))
+ (equal? a (make-array 'foo 5))))
+
+ (pass-if-exception "subr_1" exception:wrong-num-args
+ (array-map! (make-array #f 5) length
+ (make-array #f 5) (make-array #f 5)))
+
+ (pass-if "subr_2"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a logtest
+ (make-array 999 5) (make-array 999 5))
+ (equal? a (make-array #t 5))))
+
+ (pass-if "subr_2o"
+ (let ((a (make-array #f 5)))
+ (array-map! a number->string
+ (make-array 32 5) (make-array 16 5))
+ (equal? a (make-array "20" 5))))
+
+ (pass-if-exception "dsubr" exception:wrong-num-args
+ (let ((a (make-array #f 5)))
+ (array-map! a sqrt
+ (make-array 16.0 5) (make-array 16.0 5))
+ (equal? a (make-array 4.0 5))))
+
+ (pass-if "rpsubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a = (make-array 99 5) (make-array 77 5))
+ (equal? a (make-array #f 5))))
+
+ (pass-if "asubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a - (make-array 99 5) (make-array 11 5))
+ (equal? a (make-array 88 5))))
+
+ (pass-if "+"
+ (let ((a (make-array #f 4)))
+ (array-map! a + #(1 2 3 4) #(5 6 7 8))
+ (equal? a #(6 8 10 12))))
+
+ (pass-if "noncompact arrays 1"
+ (let ((a #2((0 1) (2 3)))
+ (c (make-array 0 2)))
+ (begin
+ (array-map! c + (array-row a 1) (array-row a 1))
+ (array-equal? c #(4 6)))))
+
+ (pass-if "noncompact arrays 2"
+ (let ((a #2((0 1) (2 3)))
+ (c (make-array 0 2)))
+ (begin
+ (array-map! c + (array-col a 1) (array-col a 1))
+ (array-equal? c #(2 6)))))
+
+ (pass-if "noncompact arrays 3"
+ (let ((a #2((0 1) (2 3)))
+ (c (make-array 0 2)))
+ (begin
+ (array-map! c + (array-col a 1) (array-row a 1))
+ (array-equal? c #(3 6)))))
+
+ (pass-if "noncompact arrays 4"
+ (let ((a #2((0 1) (2 3)))
+ (c (make-array 0 2)))
+ (begin
+ (array-map! c + (array-col a 1) (array-row a 1))
+ (array-equal? c #(3 6)))))
+
+ (pass-if "offset arrays 1"
+ (let ((a #2@1@-3((0 1) (2 3)))
+ (c (make-array 0 '(1 2) '(-3 -2))))
+ (begin
+ (array-map! c + a a)
+ (array-equal? c #2@1@-3((0 2) (4 6)))))))
+
+ ;; note that array-copy! has the opposite behavior.
+
+ (pass-if-exception "matching behavior I" exception:shape-mismatch
+ (let ((a #(1 2))
+ (b (make-array 0 3)))
+ (array-map! b values a)
+ (equal? b #(1 2 0))))
+
+ (pass-if "matching behavior II"
+ (let ((a #(1 2 3))
+ (b (make-array 0 2)))
+ (array-map! b values a)
+ (equal? b #(1 2))))
+
+ ;; here both a & b are are unrollable down to the first axis, but the
+ ;; size mismatch limits unrolling to the last axis only.
+
+ (pass-if "matching behavior III"
+ (let ((a #3(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12))))
+ (b (make-array 0 2 2 2)))
+ (array-map! b values a)
+ (array-equal? b #3(((1 2) (3 4)) ((7 8) (9 10)))))))
+
+;;;
+;;; array-for-each
+;;;
+
+(with-test-prefix "array-for-each"
+
+ (with-test-prefix "1 source"
+ (pass-if-equal "rank 0"
+ '(99)
+ (let* ((a #0(99))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
+ (pass-if-equal "noncompact array"
+ '(3 2 1 0)
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
+ (pass-if-equal "vector"
+ '(3 2 1 0)
+ (let* ((a #(0 1 2 3))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
+ (pass-if-equal "shared array"
+ '(3 2 1 0)
+ (let* ((a #2((0 1) (2 3)))
+ (a' (make-shared-array a
+ (lambda (x)
+ (list (quotient x 4)
+ (modulo x 4)))
+ 4))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a')
+ l)))
+
+ (with-test-prefix "3 sources"
+ (pass-if-equal "noncompact arrays 1"
+ '((3 1 3) (2 0 2))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1))
+ l))
+
+ (pass-if-equal "noncompact arrays 2"
+ '((3 3 3) (2 2 1))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
+ l))
+
+ (pass-if-equal "noncompact arrays 3"
+ '((3 3 3) (2 1 1))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
+ l))
+
+ (pass-if-equal "noncompact arrays 4"
+ '((3 2 3) (1 0 2))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
+ l)))
+
+ (with-test-prefix "empty arrays"
+
+ (pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
+ (let* ((a (list))
+ (b (make-array 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-for-each (lambda (c) (set! a (cons c a))) c)
+ (equal? a '())))
+
+ (pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
+ (let* ((a (list))
+ (b (make-typed-array 'f64 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-for-each (lambda (c) (set! a (cons c a))) c)
+ (equal? a '())))
+
+ ;; FIXME add type 'b cases.
+
+ (pass-if-exception "empty arrays shape check" exception:shape-mismatch
+ (let* ((a (list))
+ (b (make-typed-array 'f64 0 0 2))
+ (c (make-typed-array 'f64 0 2 0)))
+ (array-for-each (lambda (b c) (set! a (cons* b c a))) b c)))))
+
+;;;
+;;; array-for-each-cell
+;;;
+
+(with-test-prefix "array-for-each-cell"
+
+ (pass-if-equal "1 argument frame rank 1"
+ #2((1 3 9) (2 7 8))
+ (let* ((a (list->array 2 '((9 1 3) (7 8 2)))))
+ (array-for-each-cell 1 (lambda (a) (sort! a <)) a)
+ a))
+
+ (pass-if-equal "2 arguments frame rank 1"
+ #f64(8 -1)
+ (let* ((x (list->typed-array 'f64 2 '((9 1) (7 8))))
+ (y (f64vector 99 99)))
+ (array-for-each-cell 1 (lambda (y x) (array-set! y (- (array-ref x 0) (array-ref x 1)))) y x)
+ y))
+
+ (pass-if-equal "regression: zero-sized frame loop without unrolling"
+ 99
+ (let* ((x 99)
+ (o (make-array 0. 0 3 2)))
+ (array-for-each-cell 2
+ (lambda (o a0 a1)
+ (set! x 0))
+ o
+ (make-shared-array (make-array 1. 0 1) (const '(0 0)) 0 3)
+ (make-array 2. 0 3))
+ x)))
diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
deleted file mode 100644
index d8241ef..0000000
--- a/test-suite/tests/ramap.test
+++ /dev/null
@@ -1,509 +0,0 @@
-;;;; ramap.test --- test array mapping functions -*- scheme -*-
-;;;;
-;;;; Copyright (C) 2004, 2005, 2006, 2009, 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
-
-(define-module (test-suite test-ramap)
- #:use-module (test-suite lib))
-
-(define exception:shape-mismatch
- (cons 'misc-error ".*shape mismatch.*"))
-
-(define (array-row a i)
- (make-shared-array a (lambda (j) (list i j))
- (cadr (array-dimensions a))))
-
-(define (array-col a j)
- (make-shared-array a (lambda (i) (list i j))
- (car (array-dimensions a))))
-
-;;;
-;;; array-index-map!
-;;;
-
-(with-test-prefix "array-index-map!"
-
- (pass-if "basic test"
- (let ((nlst '()))
- (array-index-map! (make-array #f '(1 1))
- (lambda (n)
- (set! nlst (cons n nlst))))
- (equal? nlst '(1))))
-
- (with-test-prefix "empty arrays"
-
- (pass-if "all axes empty"
- (array-index-map! (make-typed-array 'f64 0 0 0) (const 0))
- (array-index-map! (make-typed-array 'b #t 0 0) (const #t))
- (array-index-map! (make-typed-array #t 0 0 0) (const 0))
- #t)
-
- (pass-if "last axis empty"
- (array-index-map! (make-typed-array 'f64 0 2 0) (const 0))
- (array-index-map! (make-typed-array 'b #t 2 0) (const #t))
- (array-index-map! (make-typed-array #t 0 2 0) (const 0))
- #t)
-
- ; the 'f64 cases fail in 2.0.9 with out-of-range.
- (pass-if "axis empty, other than last"
- (array-index-map! (make-typed-array 'f64 0 0 2) (const 0))
- (array-index-map! (make-typed-array 'b #t 0 2) (const #t))
- (array-index-map! (make-typed-array #t 0 0 2) (const 0))
- #t))
-
- (pass-if "rank 2"
- (let ((a (make-array 0 2 2))
- (b (make-array 0 2 2)))
- (array-index-map! a (lambda (i j) i))
- (array-index-map! b (lambda (i j) j))
- (and (array-equal? a #2((0 0) (1 1)))
- (array-equal? b #2((0 1) (0 1)))))))
-
-;;;
-;;; array-copy!
-;;;
-
-(with-test-prefix "array-copy!"
-
- (with-test-prefix "empty arrays"
-
- (pass-if "empty other than last, #t"
- (let* ((b (make-array 0 2 2))
- (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
- (array-copy! #2:0:2() c)
- (array-equal? #2:0:2() c)))
-
- (pass-if "empty other than last, 'f64"
- (let* ((b (make-typed-array 'f64 0 2 2))
- (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
- (array-copy! #2:0:2() c)
- (array-equal? #2f64:0:2() c)))
-
- ;; FIXME add empty, type 'b cases.
-
- )
-
- ;; note that it is the opposite of array-map!. This is, unfortunately,
- ;; documented in the manual.
-
- (pass-if "matching behavior I"
- (let ((a #(1 2))
- (b (make-array 0 3)))
- (array-copy! a b)
- (equal? b #(1 2 0))))
-
- (pass-if-exception "matching behavior II" exception:shape-mismatch
- (let ((a #(1 2 3))
- (b (make-array 0 2)))
- (array-copy! a b)
- (equal? b #(1 2))))
-
- ;; here both a & b are are unrollable down to the first axis, but the
- ;; size mismatch limits unrolling to the last axis only.
-
- (pass-if "matching behavior III"
- (let ((a #3(((1 2) (3 4)) ((5 6) (7 8))))
- (b (make-array 0 2 3 2)))
- (array-copy! a b)
- (array-equal? b #3(((1 2) (3 4) (0 0)) ((5 6) (7 8) (0 0))))))
-
- (pass-if "rank 0"
- (let ((a #0(99))
- (b (make-array 0)))
- (array-copy! a b)
- (equal? b #0(99))))
-
- (pass-if "rank 1"
- (let* ((a #2((1 2) (3 4)))
- (b (make-shared-array a (lambda (j) (list 1 j)) 2))
- (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
- (d (make-array 0 2))
- (e (make-array 0 2)))
- (array-copy! b d)
- (array-copy! c e)
- (and (equal? d #(3 4))
- (equal? e #(4 2)))))
-
- (pass-if "rank 2"
- (let ((a #2((1 2) (3 4)))
- (b (make-array 0 2 2))
- (c (make-array 0 2 2))
- (d (make-array 0 2 2))
- (e (make-array 0 2 2)))
- (array-copy! a b)
- (array-copy! a (transpose-array c 1 0))
- (array-copy! (transpose-array a 1 0) d)
- (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
- (and (equal? a #2((1 2) (3 4)))
- (equal? b #2((1 2) (3 4)))
- (equal? c #2((1 3) (2 4)))
- (equal? d #2((1 3) (2 4)))
- (equal? e #2((1 2) (3 4))))))
-
- (pass-if "rank 2, discontinuous"
- (let ((A #2((0 1) (2 3) (4 5)))
- (B #2((10 11) (12 13) (14 15)))
- (C #2((20) (21) (22)))
- (X (make-array 0 3 5))
- (piece (lambda (X w s)
- (make-shared-array
- X (lambda (i j) (list i (+ j s))) 3 w))))
- (array-copy! A (piece X 2 0))
- (array-copy! B (piece X 2 2))
- (array-copy! C (piece X 1 4))
- (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
-
- (pass-if "null increments, not empty"
- (let ((a (make-array 0 2 2)))
- (array-copy! (make-shared-array #0(1) (lambda x '()) 2 2) a)
- (array-equal? #2((1 1) (1 1))))))
-
-;;;
-;;; array-map!
-;;;
-
-(with-test-prefix "array-map!"
-
- (pass-if-exception "no args" exception:wrong-num-args
- (array-map!))
-
- (pass-if-exception "one arg" exception:wrong-num-args
- (array-map! (make-array #f 5)))
-
- (with-test-prefix "no sources"
-
- (pass-if "closure 0"
- (array-map! (make-array #f 5) (lambda () #f))
- #t)
-
- (pass-if-exception "closure 1" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda (x) #f)))
-
- (pass-if-exception "closure 2" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda (x y) #f)))
-
- (pass-if-exception "subr_1" exception:wrong-num-args
- (array-map! (make-array #f 5) length))
-
- (pass-if-exception "subr_2" exception:wrong-num-args
- (array-map! (make-array #f 5) logtest))
-
- (pass-if-exception "subr_2o" exception:wrong-num-args
- (array-map! (make-array #f 5) number->string))
-
- (pass-if-exception "dsubr" exception:wrong-num-args
- (array-map! (make-array #f 5) sqrt))
-
- (pass-if "rpsubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a =)
- (equal? a (make-array #t 5))))
-
- (pass-if "asubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a +)
- (equal? a (make-array 0 5))))
-
- ;; in Guile 1.6.4 and earlier this resulted in a segv
- (pass-if "noop"
- (array-map! (make-array #f 5) noop)
- #t))
-
- (with-test-prefix "one source"
-
- (pass-if-exception "closure 0" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda () #f)
- (make-array #f 5)))
-
- (pass-if "closure 1"
- (let ((a (make-array #f 5)))
- (array-map! a (lambda (x) 'foo) (make-array #f 5))
- (equal? a (make-array 'foo 5))))
-
- (pass-if-exception "closure 2" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda (x y) #f)
- (make-array #f 5)))
-
- (pass-if "subr_1"
- (let ((a (make-array #f 5)))
- (array-map! a length (make-array '(x y z) 5))
- (equal? a (make-array 3 5))))
-
- (pass-if-exception "subr_2" exception:wrong-num-args
- (array-map! (make-array #f 5) logtest
- (make-array 999 5)))
-
- (pass-if "subr_2o"
- (let ((a (make-array #f 5)))
- (array-map! a number->string (make-array 99 5))
- (equal? a (make-array "99" 5))))
-
- (pass-if "dsubr"
- (let ((a (make-array #f 5)))
- (array-map! a sqrt (make-array 16.0 5))
- (equal? a (make-array 4.0 5))))
-
- (pass-if "rpsubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a = (make-array 0 5))
- (equal? a (make-array #t 5))))
-
- (pass-if "asubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a - (make-array 99 5))
- (equal? a (make-array -99 5))))
-
- ;; in Guile 1.6.5 and 1.6.6 this was an error
- (pass-if "1+"
- (let ((a (make-array #f 5)))
- (array-map! a 1+ (make-array 123 5))
- (equal? a (make-array 124 5))))
-
- (pass-if "rank 0"
- (let ((a #0(99))
- (b (make-array 0)))
- (array-map! b values a)
- (equal? b #0(99))))
-
- (pass-if "rank 2, discontinuous"
- (let ((A #2((0 1) (2 3) (4 5)))
- (B #2((10 11) (12 13) (14 15)))
- (C #2((20) (21) (22)))
- (X (make-array 0 3 5))
- (piece (lambda (X w s)
- (make-shared-array
- X (lambda (i j) (list i (+ j s))) 3 w))))
- (array-map! (piece X 2 0) values A)
- (array-map! (piece X 2 2) values B)
- (array-map! (piece X 1 4) values C)
- (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
-
- (pass-if "null increments, not empty"
- (let ((a (make-array 0 2 2)))
- (array-map! a values (make-shared-array #0(1) (lambda x '()) 2 2))
- (array-equal? a #2((1 1) (1 1))))))
-
- (with-test-prefix "two sources"
-
- (pass-if-exception "closure 0" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda () #f)
- (make-array #f 5) (make-array #f 5)))
-
- (pass-if-exception "closure 1" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda (x) #f)
- (make-array #f 5) (make-array #f 5)))
-
- (pass-if "closure 2"
- (let ((a (make-array #f 5)))
- (array-map! a (lambda (x y) 'foo)
- (make-array #f 5) (make-array #f 5))
- (equal? a (make-array 'foo 5))))
-
- (pass-if-exception "subr_1" exception:wrong-num-args
- (array-map! (make-array #f 5) length
- (make-array #f 5) (make-array #f 5)))
-
- (pass-if "subr_2"
- (let ((a (make-array 'foo 5)))
- (array-map! a logtest
- (make-array 999 5) (make-array 999 5))
- (equal? a (make-array #t 5))))
-
- (pass-if "subr_2o"
- (let ((a (make-array #f 5)))
- (array-map! a number->string
- (make-array 32 5) (make-array 16 5))
- (equal? a (make-array "20" 5))))
-
- (pass-if-exception "dsubr" exception:wrong-num-args
- (let ((a (make-array #f 5)))
- (array-map! a sqrt
- (make-array 16.0 5) (make-array 16.0 5))
- (equal? a (make-array 4.0 5))))
-
- (pass-if "rpsubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a = (make-array 99 5) (make-array 77 5))
- (equal? a (make-array #f 5))))
-
- (pass-if "asubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a - (make-array 99 5) (make-array 11 5))
- (equal? a (make-array 88 5))))
-
- (pass-if "+"
- (let ((a (make-array #f 4)))
- (array-map! a + #(1 2 3 4) #(5 6 7 8))
- (equal? a #(6 8 10 12))))
-
- (pass-if "noncompact arrays 1"
- (let ((a #2((0 1) (2 3)))
- (c (make-array 0 2)))
- (begin
- (array-map! c + (array-row a 1) (array-row a 1))
- (array-equal? c #(4 6)))))
-
- (pass-if "noncompact arrays 2"
- (let ((a #2((0 1) (2 3)))
- (c (make-array 0 2)))
- (begin
- (array-map! c + (array-col a 1) (array-col a 1))
- (array-equal? c #(2 6)))))
-
- (pass-if "noncompact arrays 3"
- (let ((a #2((0 1) (2 3)))
- (c (make-array 0 2)))
- (begin
- (array-map! c + (array-col a 1) (array-row a 1))
- (array-equal? c #(3 6)))))
-
- (pass-if "noncompact arrays 4"
- (let ((a #2((0 1) (2 3)))
- (c (make-array 0 2)))
- (begin
- (array-map! c + (array-col a 1) (array-row a 1))
- (array-equal? c #(3 6)))))
-
- (pass-if "offset arrays 1"
- (let ((a #2@1@-3((0 1) (2 3)))
- (c (make-array 0 '(1 2) '(-3 -2))))
- (begin
- (array-map! c + a a)
- (array-equal? c #2@1@-3((0 2) (4 6)))))))
-
- ;; note that array-copy! has the opposite behavior.
-
- (pass-if-exception "matching behavior I" exception:shape-mismatch
- (let ((a #(1 2))
- (b (make-array 0 3)))
- (array-map! b values a)
- (equal? b #(1 2 0))))
-
- (pass-if "matching behavior II"
- (let ((a #(1 2 3))
- (b (make-array 0 2)))
- (array-map! b values a)
- (equal? b #(1 2))))
-
- ;; here both a & b are are unrollable down to the first axis, but the
- ;; size mismatch limits unrolling to the last axis only.
-
- (pass-if "matching behavior III"
- (let ((a #3(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12))))
- (b (make-array 0 2 2 2)))
- (array-map! b values a)
- (array-equal? b #3(((1 2) (3 4)) ((7 8) (9 10)))))))
-
-;;;
-;;; array-for-each
-;;;
-
-(with-test-prefix "array-for-each"
-
- (with-test-prefix "1 source"
- (pass-if-equal "rank 0"
- '(99)
- (let* ((a #0(99))
- (l '())
- (p (lambda (x) (set! l (cons x l)))))
- (array-for-each p a)
- l))
-
- (pass-if-equal "noncompact array"
- '(3 2 1 0)
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (p (lambda (x) (set! l (cons x l)))))
- (array-for-each p a)
- l))
-
- (pass-if-equal "vector"
- '(3 2 1 0)
- (let* ((a #(0 1 2 3))
- (l '())
- (p (lambda (x) (set! l (cons x l)))))
- (array-for-each p a)
- l))
-
- (pass-if-equal "shared array"
- '(3 2 1 0)
- (let* ((a #2((0 1) (2 3)))
- (a' (make-shared-array a
- (lambda (x)
- (list (quotient x 4)
- (modulo x 4)))
- 4))
- (l '())
- (p (lambda (x) (set! l (cons x l)))))
- (array-for-each p a')
- l)))
-
- (with-test-prefix "3 sources"
- (pass-if-equal "noncompact arrays 1"
- '((3 1 3) (2 0 2))
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1))
- l))
-
- (pass-if-equal "noncompact arrays 2"
- '((3 3 3) (2 2 1))
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
- l))
-
- (pass-if-equal "noncompact arrays 3"
- '((3 3 3) (2 1 1))
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
- l))
-
- (pass-if-equal "noncompact arrays 4"
- '((3 2 3) (1 0 2))
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
- l)))
-
- (with-test-prefix "empty arrays"
-
- (pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
- (let* ((a (list))
- (b (make-array 0 2 2))
- (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
- (array-for-each (lambda (c) (set! a (cons c a))) c)
- (equal? a '())))
-
- (pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
- (let* ((a (list))
- (b (make-typed-array 'f64 0 2 2))
- (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
- (array-for-each (lambda (c) (set! a (cons c a))) c)
- (equal? a '())))
-
- ;; FIXME add type 'b cases.
-
- (pass-if-exception "empty arrays shape check" exception:shape-mismatch
- (let* ((a (list))
- (b (make-typed-array 'f64 0 0 2))
- (c (make-typed-array 'f64 0 2 0)))
- (array-for-each (lambda (b c) (set! a (cons* b c a))) b c)))))
--
2.7.3
[-- Attachment #13: 0012-Remove-uniform-array-read-uniform-array-write-from-t.patch --]
[-- Type: application/octet-stream, Size: 2167 bytes --]
From e3c2ea7e9d6ba65b6c64833e6b58e5adf2a81829 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Thu, 23 Jun 2016 12:15:31 +0200
Subject: [PATCH 12/13] Remove uniform-array-read!, uniform-array-write from
the manual
These procedures where removed in
fc7bd367ab4b5027a7f80686b1e229c62e43c90b (2011-05-12).
* doc/ref/api-compound.texi: Ditto.
---
doc/ref/api-compound.texi | 33 ---------------------------------
1 file changed, 33 deletions(-)
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index ef4869c..dde814c 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1569,39 +1569,6 @@ $\left(\matrix{%
@end example
@end deffn
-@deffn {Scheme Procedure} uniform-array-read! ra [port_or_fd [start [end]]]
-@deffnx {C Function} scm_uniform_array_read_x (ra, port_or_fd, start, end)
-Attempt to read all elements of array @var{ra}, in lexicographic order, as
-binary objects from @var{port_or_fd}.
-If an end of file is encountered,
-the objects up to that point are put into @var{ra}
-(starting at the beginning) and the remainder of the array is
-unchanged.
-
-The optional arguments @var{start} and @var{end} allow
-a specified region of a vector (or linearized array) to be read,
-leaving the remainder of the vector unchanged.
-
-@code{uniform-array-read!} returns the number of objects read.
-@var{port_or_fd} may be omitted, in which case it defaults to the value
-returned by @code{(current-input-port)}.
-@end deffn
-
-@deffn {Scheme Procedure} uniform-array-write ra [port_or_fd [start [end]]]
-@deffnx {C Function} scm_uniform_array_write (ra, port_or_fd, start, end)
-Writes all elements of @var{ra} as binary objects to
-@var{port_or_fd}.
-
-The optional arguments @var{start}
-and @var{end} allow
-a specified region of a vector (or linearized array) to be written.
-
-The number of objects actually written is returned.
-@var{port_or_fd} may be
-omitted, in which case it defaults to the value returned by
-@code{(current-output-port)}.
-@end deffn
-
@node Shared Arrays
@subsubsection Shared Arrays
--
2.7.3
[-- Attachment #14: 0013-Support-typed-arrays-in-some-sort-functions.patch --]
[-- Type: application/octet-stream, Size: 18119 bytes --]
From 9e06cd733d02e40d3a6bee508051ef737009e552 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Tue, 5 Jul 2016 17:20:47 +0200
Subject: [PATCH 13/13] Support typed arrays in some sort functions
* libguile/sort.c (sort!, sort, restricted-vector-sort!, sorted?):
Support arrays of rank 1, whatever the type.
* libguile/quicksort.i.c: Fix accessors to handle typed arrays.
* test-suite/tests/sort.test: Test also with typed arrays.
---
libguile/quicksort.i.c | 47 +++++++-------
libguile/sort.c | 150 +++++++++++++++++++++++++++++----------------
test-suite/tests/sort.test | 38 ++++++++++--
3 files changed, 152 insertions(+), 83 deletions(-)
diff --git a/libguile/quicksort.i.c b/libguile/quicksort.i.c
index 4e39f82..d3a0f93 100644
--- a/libguile/quicksort.i.c
+++ b/libguile/quicksort.i.c
@@ -11,7 +11,7 @@
version but doesn't consume extra memory.
*/
-#define SWAP(a, b) do { const SCM _tmp = a; a = b; b = _tmp; } while (0)
+#define SWAP(a, b) do { const SCM _tmp = GET(a); SET(a, GET(b)); SET(b, _tmp); } while (0)
/* Order using quicksort. This implementation incorporates four
@@ -54,8 +54,7 @@
#define STACK_NOT_EMPTY (stack < top)
static void
-NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
- SCM less)
+NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
{
/* Stack node declarations used to store unfulfilled partition obligations. */
typedef struct {
@@ -65,8 +64,6 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
static const char s_buggy_less[] = "buggy less predicate used when sorting";
-#define ELT(i) base_ptr[(i)*INC]
-
if (nr_elems == 0)
/* Avoid lossage with unsigned arithmetic below. */
return;
@@ -92,18 +89,18 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
skips a comparison for both the left and right. */
SCM_TICK;
-
- if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo))))
- SWAP (ELT(mid), ELT(lo));
- if (scm_is_true (scm_call_2 (less, ELT(hi), ELT(mid))))
- SWAP (ELT(mid), ELT(hi));
+
+ if (scm_is_true (scm_call_2 (less, GET(mid), GET(lo))))
+ SWAP (mid, lo);
+ if (scm_is_true (scm_call_2 (less, GET(hi), GET(mid))))
+ SWAP (mid, hi);
else
goto jump_over;
- if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo))))
- SWAP (ELT(mid), ELT(lo));
+ if (scm_is_true (scm_call_2 (less, GET(mid), GET(lo))))
+ SWAP (mid, lo);
jump_over:;
- pivot = ELT(mid);
+ pivot = GET(mid);
left = lo + 1;
right = hi - 1;
@@ -112,7 +109,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
that this algorithm runs much faster than others. */
do
{
- while (scm_is_true (scm_call_2 (less, ELT(left), pivot)))
+ while (scm_is_true (scm_call_2 (less, GET(left), pivot)))
{
left += 1;
/* The comparison predicate may be buggy */
@@ -120,7 +117,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
scm_misc_error (NULL, s_buggy_less, SCM_EOL);
}
- while (scm_is_true (scm_call_2 (less, pivot, ELT(right))))
+ while (scm_is_true (scm_call_2 (less, pivot, GET(right))))
{
right -= 1;
/* The comparison predicate may be buggy */
@@ -130,7 +127,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
if (left < right)
{
- SWAP (ELT(left), ELT(right));
+ SWAP (left, right);
left += 1;
right -= 1;
}
@@ -192,11 +189,11 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
and the operation speeds up insertion sort's inner loop. */
for (run = tmp + 1; run <= thresh; run += 1)
- if (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp))))
+ if (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
tmp = run;
if (tmp != 0)
- SWAP (ELT(tmp), ELT(0));
+ SWAP (tmp, 0);
/* Insertion sort, running from left-hand-side up to right-hand-side. */
@@ -206,7 +203,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
SCM_TICK;
tmp = run - 1;
- while (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp))))
+ while (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
{
/* The comparison predicate may be buggy */
if (tmp == 0)
@@ -218,12 +215,12 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
tmp += 1;
if (tmp != run)
{
- SCM to_insert = ELT(run);
+ SCM to_insert = GET(run);
size_t hi, lo;
for (hi = lo = run; --lo >= tmp; hi = lo)
- ELT(hi) = ELT(lo);
- ELT(hi) = to_insert;
+ SET(hi, GET(lo));
+ SET(hi, to_insert);
}
}
}
@@ -235,9 +232,9 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
#undef PUSH
#undef POP
#undef STACK_NOT_EMPTY
-#undef ELT
+#undef GET
+#undef SET
#undef NAME
#undef INC_PARAM
-#undef INC
-
+#undef VEC_PARAM
diff --git a/libguile/sort.c b/libguile/sort.c
index 9373fb8..9a65362 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -51,23 +51,25 @@
#include "libguile/validate.h"
#include "libguile/sort.h"
-/* We have two quicksort variants: one for contigous vectors and one
- for vectors with arbitrary increments between elements. Note that
- increments can be negative.
+/* We have two quicksort variants: one for SCM (#t) arrays and one for
+ typed arrays.
*/
-#define NAME quicksort1
-#define INC_PARAM /* empty */
-#define INC 1
-#include "libguile/quicksort.i.c"
-
#define NAME quicksort
#define INC_PARAM ssize_t inc,
-#define INC inc
+#define VEC_PARAM SCM * ra,
+#define GET(i) ra[(i)*inc]
+#define SET(i, val) ra[(i)*inc] = val
#include "libguile/quicksort.i.c"
+#define NAME quicksorta
+#define INC_PARAM
+#define VEC_PARAM scm_t_array_handle * const ra,
+#define GET(i) scm_array_handle_ref (ra, scm_array_handle_pos_1 (ra, i))
+#define SET(i, val) scm_array_handle_set (ra, scm_array_handle_pos_1 (ra, i), val)
+#include "libguile/quicksort.i.c"
-SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
+SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
(SCM vec, SCM less, SCM startpos, SCM endpos),
"Sort the vector @var{vec}, using @var{less} for comparing\n"
"the vector elements. @var{startpos} (inclusively) and\n"
@@ -76,22 +78,38 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
"is not specified.")
#define FUNC_NAME s_scm_restricted_vector_sort_x
{
- size_t vlen, spos, len;
- ssize_t vinc;
+ ssize_t spos = scm_to_ssize_t (startpos);
+ size_t epos = scm_to_ssize_t (endpos);
+
scm_t_array_handle handle;
- SCM *velts;
+ scm_array_get_handle (vec, &handle);
+ scm_t_array_dim const * dims = scm_array_handle_dims (&handle);
- velts = scm_vector_writable_elements (vec, &handle, &vlen, &vinc);
- spos = scm_to_unsigned_integer (startpos, 0, vlen);
- len = scm_to_unsigned_integer (endpos, spos, vlen) - spos;
+ if (scm_array_handle_rank(&handle) != 1)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", vec, SCM_EOL);
+ }
+ if (spos < dims[0].lbnd)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_out_of_range_key, FUNC_NAME, "startpos out of range",
+ vec, scm_list_1(startpos));
+ }
+ if (epos > dims[0].ubnd+1)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_out_of_range_key, FUNC_NAME, "endpos out of range",
+ vec, scm_list_1(endpos));
+ }
- if (vinc == 1)
- quicksort1 (velts + spos*vinc, len, less);
+ if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
+ quicksort (scm_array_handle_writable_elements (&handle) + (spos-dims[0].lbnd) * dims[0].inc,
+ epos-spos, dims[0].inc, less);
else
- quicksort (velts + spos*vinc, len, vinc, less);
+ quicksorta (&handle, epos-spos, less);
scm_array_handle_release (&handle);
-
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -140,29 +158,48 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
}
else
{
- scm_t_array_handle handle;
- size_t i, len;
- ssize_t inc;
- const SCM *elts;
SCM result = SCM_BOOL_T;
- elts = scm_vector_elements (items, &handle, &len, &inc);
-
- for (i = 1; i < len; i++, elts += inc)
- {
- if (scm_is_true (scm_call_2 (less, elts[inc], elts[0])))
- {
- result = SCM_BOOL_F;
- break;
- }
- }
+ scm_t_array_handle handle;
+ scm_array_get_handle (items, &handle);
+ scm_t_array_dim const * dims = scm_array_handle_dims (&handle);
+
+ if (scm_array_handle_rank(&handle) != 1)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items, SCM_EOL);
+ }
+
+ if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
+ {
+ ssize_t inc = dims[0].inc;
+ const SCM *elts = scm_array_handle_elements (&handle);
+ for (ssize_t i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i, elts += inc)
+ {
+ if (scm_is_true (scm_call_2 (less, elts[inc], elts[0])))
+ {
+ result = SCM_BOOL_F;
+ break;
+ }
+ }
+ }
+ else
+ {
+ for (ssize_t i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i)
+ {
+ if (scm_is_true (scm_call_2 (less,
+ scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i)),
+ scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i-1)))))
+ {
+ result = SCM_BOOL_F;
+ break;
+ }
+ }
+ }
scm_array_handle_release (&handle);
-
return result;
}
-
- return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -172,7 +209,7 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
and returns a new list in which the elements of a and b have been stably
interleaved so that (sorted? (merge a b less?) less?).
Note: this does _not_ accept vectors. */
-SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
+SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
(SCM alist, SCM blist, SCM less),
"Merge two already sorted lists into one.\n"
"Given two lists @var{alist} and @var{blist}, such that\n"
@@ -236,7 +273,7 @@ SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
#undef FUNC_NAME
-static SCM
+static SCM
scm_merge_list_x (SCM alist, SCM blist,
long alen, long blen,
SCM less)
@@ -288,7 +325,7 @@ scm_merge_list_x (SCM alist, SCM blist,
} /* scm_merge_list_x */
-SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0,
+SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0,
(SCM alist, SCM blist, SCM less),
"Takes two lists @var{alist} and @var{blist} such that\n"
"@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n"
@@ -319,7 +356,7 @@ SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0,
scsh's merge-sort but that algorithm showed to not be stable, even
though it claimed to be.
*/
-static SCM
+static SCM
scm_merge_list_step (SCM * seq, SCM less, long n)
{
SCM a, b;
@@ -359,7 +396,7 @@ scm_merge_list_step (SCM * seq, SCM less, long n)
} /* scm_merge_list_step */
-SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
+SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
(SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n"
"vector. @var{less} is used for comparing the sequence\n"
@@ -391,7 +428,7 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
+SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
(SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n"
"vector. @var{less} is used for comparing the sequence\n"
@@ -404,7 +441,13 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
if (scm_is_pair (items))
return scm_sort_x (scm_list_copy (items), less);
else if (scm_is_array (items) && scm_c_array_rank (items) == 1)
- return scm_sort_x (scm_vector_copy (items), less);
+ {
+ if (scm_c_array_rank (items) != 1)
+ scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items, SCM_EOL);
+ SCM copy = scm_make_typed_array (scm_array_type (items), SCM_UNSPECIFIED, scm_array_dimensions (items));
+ scm_array_copy_x (items, copy);
+ return scm_sort_x (copy, less);
+ }
else
SCM_WRONG_TYPE_ARG (1, items);
}
@@ -470,7 +513,7 @@ scm_merge_vector_step (SCM *vec,
} /* scm_merge_vector_step */
-SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
+SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
(SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n"
"vector. @var{less} is used for comparing the sequence elements.\n"
@@ -495,14 +538,15 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
SCM temp, *temp_elts, *vec_elts;
size_t len;
ssize_t inc;
-
+
vec_elts = scm_vector_writable_elements (items, &vec_handle,
&len, &inc);
- if (len == 0) {
- scm_array_handle_release (&vec_handle);
- return items;
- }
-
+ if (len == 0)
+ {
+ scm_array_handle_release (&vec_handle);
+ return items;
+ }
+
temp = scm_c_make_vector (len, SCM_UNDEFINED);
temp_elts = scm_vector_writable_elements (temp, &temp_handle,
NULL, NULL);
@@ -520,7 +564,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
+SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
(SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n"
"vector. @var{less} is used for comparing the sequence elements.\n"
@@ -554,7 +598,7 @@ SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0,
+SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0,
(SCM items, SCM less),
"Sort the list @var{items}, using @var{less} for comparing the\n"
"list elements. This is a stable sort.")
diff --git a/test-suite/tests/sort.test b/test-suite/tests/sort.test
index 9209b53..f37dbbf 100644
--- a/test-suite/tests/sort.test
+++ b/test-suite/tests/sort.test
@@ -1,16 +1,16 @@
;;;; sort.test --- tests Guile's sort functions -*- scheme -*-
;;;; Copyright (C) 2003, 2006, 2007, 2009, 2011 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
@@ -31,22 +31,51 @@
exception:wrong-num-args
(sort '(1 2) (lambda (x y z) z)))
- (pass-if "sort!"
+ (pass-if "sort of vector"
+ (let* ((v (randomize-vector! (make-vector 1000) 1000))
+ (w (vector-copy v)))
+ (and (sorted? (sort v <) <)
+ (equal? w v))))
+
+ (pass-if "sort of typed array"
+ (let* ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99))
+ (w (make-typed-array 'f64 *unspecified* 99)))
+ (array-copy! v w)
+ (and (sorted? (sort v <) <)
+ (equal? w v))))
+
+ (pass-if "sort! of vector"
(let ((v (randomize-vector! (make-vector 1000) 1000)))
(sorted? (sort! v <) <)))
+ (pass-if "sort! of typed array"
+ (let ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99)))
+ (sorted? (sort! v <) <)))
+
(pass-if "sort! of non-contigous vector"
(let* ((a (make-array 0 1000 3))
(v (make-shared-array a (lambda (i) (list i 0)) 1000)))
(randomize-vector! v 1000)
(sorted? (sort! v <) <)))
+ (pass-if "sort! of non-contigous typed array"
+ (let* ((a (make-typed-array 'f64 0 99 3))
+ (v (make-shared-array a (lambda (i) (list i 0)) 99)))
+ (randomize-vector! v 99)
+ (sorted? (sort! v <) <)))
+
(pass-if "sort! of negative-increment vector"
(let* ((a (make-array 0 1000 3))
(v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000)))
(randomize-vector! v 1000)
(sorted? (sort! v <) <)))
+ (pass-if "sort! of negative-increment typed array"
+ (let* ((a (make-typed-array 'f64 0 99 3))
+ (v (make-shared-array a (lambda (i) (list (- 98 i) 0)) 99)))
+ (randomize-vector! v 99)
+ (sorted? (sort! v <) <)))
+
(pass-if "stable-sort!"
(let ((v (randomize-vector! (make-vector 1000) 1000)))
(sorted? (stable-sort! v <) <)))
@@ -79,4 +108,3 @@
;; behavior (integer underflow) leading to crashes.
(pass-if "empty vector"
(equal? '#() (stable-sort '#() <))))
-
--
2.7.3
^ permalink raw reply related [flat|nested] 16+ messages in thread
* Re: Patchset related to array functions
2016-07-12 7:48 Patchset related to array functions Daniel Llorens
@ 2016-07-12 14:11 ` Andy Wingo
2016-07-12 17:16 ` Daniel Llorens
0 siblings, 1 reply; 16+ messages in thread
From: Andy Wingo @ 2016-07-12 14:11 UTC (permalink / raw)
To: Daniel Llorens; +Cc: guile-devel
On Tue 12 Jul 2016 09:48, Daniel Llorens <daniel.llorens@bluewin.ch> writes:
> @@ -175,19 +175,19 @@ dnl investigation of problems with "64" system and library calls on
> dnl Darwin (MacOS X). The libguile code (_scm.h) assumes that if a
> dnl system has stat64, it will have all the other 64 APIs too; but on
> dnl Darwin, stat64 is there but other APIs are missing.
> -dnl
> +dnl
> dnl It also appears, from the Darwin docs, that most system call APIs
> dnl there (i.e. the traditional ones _without_ "64" in their names) have
> dnl been 64-bit-capable for a long time now, so it isn't necessary to
> dnl use "64" versions anyway. For example, Darwin's off_t is 64-bit.
Can you please fix your editor to not strip whitespace in unrelated
parts of patches, and revisit this patch set to remove unrelated
whitespace changes?
Thanks. I know it's irritating to you but it's also irritating to me :)
Andy
^ permalink raw reply [flat|nested] 16+ messages in thread
* Re: Patchset related to array functions
2016-07-12 14:11 ` Andy Wingo
@ 2016-07-12 17:16 ` Daniel Llorens
2016-07-14 9:46 ` Andy Wingo
0 siblings, 1 reply; 16+ messages in thread
From: Daniel Llorens @ 2016-07-12 17:16 UTC (permalink / raw)
To: Andy Wingo; +Cc: guile-devel
[-- Attachment #1: Type: text/plain, Size: 1145 bytes --]
On 12 Jul 2016, at 16:11, Andy Wingo <wingo@pobox.com> wrote:
> On Tue 12 Jul 2016 09:48, Daniel Llorens <daniel.llorens@bluewin.ch> writes:
>
>> @@ -175,19 +175,19 @@ dnl investigation of problems with "64" system and library calls on
>> dnl Darwin (MacOS X). The libguile code (_scm.h) assumes that if a
>> dnl system has stat64, it will have all the other 64 APIs too; but on
>> dnl Darwin, stat64 is there but other APIs are missing.
>> -dnl
>> +dnl
>> dnl It also appears, from the Darwin docs, that most system call APIs
>> dnl there (i.e. the traditional ones _without_ "64" in their names) have
>> dnl been 64-bit-capable for a long time now, so it isn't necessary to
>> dnl use "64" versions anyway. For example, Darwin's off_t is 64-bit.
>
> Can you please fix your editor to not strip whitespace in unrelated
> parts of patches, and revisit this patch set to remove unrelated
> whitespace changes?
>
> Thanks. I know it's irritating to you but it's also irritating to me :)
>
> Andy
Sorry about this. Fixed patchset attached. I've also pushed to lloda-squash0.
Regards,
Daniel
[-- Attachment #2: 0001-Compile-in-C99-mode.patch --]
[-- Type: application/octet-stream, Size: 1148 bytes --]
From 2ccb648420e4667e7da8d38b10e1f6a41642774a Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 11 Feb 2015 14:05:08 +0100
Subject: [PATCH 01/12] Compile in C99 mode
* configure.ac: Require C99 flags. Remove -Wdeclaration-after-statement.
---
configure.ac | 5 ++---
1 file changed, 2 insertions(+), 3 deletions(-)
diff --git a/configure.ac b/configure.ac
index 1735c56..8fdaa73 100644
--- a/configure.ac
+++ b/configure.ac
@@ -65,7 +65,7 @@ AC_CANONICAL_HOST
AC_LIBTOOL_WIN32_DLL
AC_PROG_INSTALL
-AC_PROG_CC
+AC_PROG_CC_C99
gl_EARLY
AC_PROG_CPP
AC_PROG_SED
@@ -1524,8 +1524,7 @@ case "$GCC" in
## <http://lists.gnu.org/archive/html/guile-devel/2012-01/msg00487.html>.
POTENTIAL_GCC_CFLAGS="-Wall -Wmissing-prototypes \
- -Wdeclaration-after-statement -Wpointer-arith \
- -Wswitch-enum -fno-strict-aliasing -fwrapv"
+ -Wpointer-arith -Wswitch-enum -fno-strict-aliasing -fwrapv"
# Do this here so we don't screw up any of the tests above that might
# not be "warning free"
if test "${GUILE_ERROR_ON_WARNING}" = yes
--
2.7.3
[-- Attachment #3: 0002-Fix-compilation-of-rank-0-typed-array-literals.patch --]
[-- Type: application/octet-stream, Size: 1768 bytes --]
From 9876c7d9a22be565f67fb2213303dda698ce3b08 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Thu, 12 Feb 2015 13:02:24 +0100
Subject: [PATCH 02/12] Fix compilation of rank 0 typed array literals
* module/system/vm/assembler.scm (simple-uniform-vector?): array-length
fails for rank 0 arrays; fix the shape condition.
* test-suite/tests/arrays.test: Test reading of #0f64(x) in compilation
context.
---
module/system/vm/assembler.scm | 4 +++-
test-suite/tests/arrays.test | 8 +++++++-
2 files changed, 10 insertions(+), 2 deletions(-)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 20a652c..f6b3caa 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -995,7 +995,9 @@ immediate, and @code{#f} otherwise."
(define (simple-uniform-vector? obj)
(and (array? obj)
(symbol? (array-type obj))
- (equal? (array-shape obj) (list (list 0 (1- (array-length obj)))))))
+ (match (array-shape obj)
+ (((0 n)) #t)
+ (else #f))))
(define (statically-allocatable? x)
"Return @code{#t} if a non-immediate constant can be allocated
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index e76c699..20cb78b 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -204,7 +204,13 @@
(with-test-prefix/c&e "array-equal?"
(pass-if "#s16(...)"
- (array-equal? #s16(1 2 3) #s16(1 2 3))))
+ (array-equal? #s16(1 2 3) #s16(1 2 3)))
+
+ (pass-if "#0f64(...)"
+ (array-equal? #0f64(99) (make-typed-array 'f64 99)))
+
+ (pass-if "#0(...)"
+ (array-equal? #0(99) (make-array 99))))
;;;
;;; make-shared-array
--
2.7.3
[-- Attachment #4: 0003-Remove-scm_from_contiguous_array-array-contiguous-fl.patch --]
[-- Type: application/octet-stream, Size: 8747 bytes --]
From 653463a873afb30f882323414b177c361131da4d Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Mon, 9 Feb 2015 17:27:33 +0100
Subject: [PATCH 03/12] Remove scm_from_contiguous_array, array 'contiguous'
flag
scm_from_contiguous_array() is undocumented, unused within Guile, and
can be trivially replaced by make-array + array-copy without requiring
contiguity.
The related SCM_I_ARRAY_FLAG_CONTIGUOUS (arrays.h) was set by all
array-creating functions (make-typed-array, transpose-array,
make-shared-array) but it was only used by array-contents, which needed
to traverse the dimensions anyway.
* libguile/arrays.h (scm_from_contiguous_array): Remove declaration.
* libguile/arrays.c (scm_from_contiguous_array): Remove.
(scm_make_typed_array, scm_from_contiguous_typed_array): Don't set the
contiguous flag.
(scm_transpose_array, scm_make_shared_array): Don't call
scm_i_ra_set_contp.
(scm_array_contents): Inline scm_i_ra_set_contp() here. Adopt uniform
type check order. Remove redundant comments.
(scm_i_ra_set_contp): Remove.
* test-suite/tests/arrays.test: Test array-contents with rank 0 array.
---
libguile/arrays.c | 112 +++++++++++--------------------------------
libguile/arrays.h | 4 +-
test-suite/tests/arrays.test | 6 +++
3 files changed, 36 insertions(+), 86 deletions(-)
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 52fe90a..3cb547f 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -188,7 +188,6 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
SCM ra;
ra = scm_i_shap2ra (bounds);
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
s = SCM_I_ARRAY_DIMS (ra);
k = SCM_I_ARRAY_NDIM (ra);
@@ -225,7 +224,6 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
size_t sz;
ra = scm_i_shap2ra (bounds);
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
s = SCM_I_ARRAY_DIMS (ra);
k = SCM_I_ARRAY_NDIM (ra);
@@ -270,41 +268,6 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
}
#undef FUNC_NAME
-SCM
-scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len)
-#define FUNC_NAME "scm_from_contiguous_array"
-{
- size_t k, rlen = 1;
- scm_t_array_dim *s;
- SCM ra;
- scm_t_array_handle h;
-
- ra = scm_i_shap2ra (bounds);
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
- s = SCM_I_ARRAY_DIMS (ra);
- k = SCM_I_ARRAY_NDIM (ra);
-
- while (k--)
- {
- s[k].inc = rlen;
- SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
- rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
- }
- if (rlen != len)
- SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL);
-
- SCM_I_ARRAY_SET_V (ra, scm_c_make_vector (rlen, SCM_UNDEFINED));
- scm_array_get_handle (ra, &h);
- memcpy (h.writable_elements, elts, rlen * sizeof(SCM));
- scm_array_handle_release (&h);
-
- if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
- if (0 == s->lbnd)
- return SCM_I_ARRAY_V (ra);
- return ra;
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
(SCM fill, SCM bounds),
"Create and return an array.")
@@ -314,27 +277,6 @@ SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
}
#undef FUNC_NAME
-static void
-scm_i_ra_set_contp (SCM ra)
-{
- size_t k = SCM_I_ARRAY_NDIM (ra);
- if (k)
- {
- ssize_t inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc;
- while (k--)
- {
- if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc)
- {
- SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
- return;
- }
- inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
- - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
- }
- }
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
-}
-
SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
(SCM oldra, SCM mapfunc, SCM dims),
@@ -448,7 +390,6 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0,
SCM_UNDEFINED);
}
- scm_i_ra_set_contp (ra);
return ra;
}
#undef FUNC_NAME
@@ -547,16 +488,12 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
}
if (ndim > 0)
SCM_MISC_ERROR ("bad argument list", SCM_EOL);
- scm_i_ra_set_contp (res);
return res;
}
}
#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 true, return #f if returned array
- wouldn't have contiguous elements. */
+
SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
(SCM ra, SCM strict),
"If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n"
@@ -566,31 +503,38 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
"@code{make-array} and @code{make-uniform-array} may be unrolled,\n"
"some arrays made by @code{make-shared-array} may not be. If\n"
"the optional argument @var{strict} is provided, a shared array\n"
- "will be returned only if its elements are stored internally\n"
- "contiguous in memory.")
+ "will be returned only if its elements are stored contiguously\n"
+ "in memory.")
#define FUNC_NAME s_scm_array_contents
{
- if (!scm_is_array (ra))
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
- else if (SCM_I_ARRAYP (ra))
+ if (SCM_I_ARRAYP (ra))
{
SCM v;
- size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
- if (!SCM_I_ARRAY_CONTP (ra))
- return SCM_BOOL_F;
- for (k = 0; k < ndim; k++)
- len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
+ size_t ndim = SCM_I_ARRAY_NDIM (ra);
+ scm_t_array_dim *s = SCM_I_ARRAY_DIMS (ra);
+ size_t k = ndim;
+ size_t len = 1;
+
+ if (k)
+ {
+ ssize_t last_inc = s[k - 1].inc;
+ while (k--)
+ {
+ if (len*last_inc != s[k].inc)
+ return SCM_BOOL_F;
+ len *= (s[k].ubnd - s[k].lbnd + 1);
+ }
+ }
+
if (!SCM_UNBNDP (strict) && scm_is_true (strict))
{
- if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc))
+ if (ndim && (1 != s[ndim - 1].inc))
return SCM_BOOL_F;
- if (scm_is_bitvector (SCM_I_ARRAY_V (ra)))
- {
- if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
- SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
- len % SCM_LONG_BIT)
- return SCM_BOOL_F;
- }
+ if (scm_is_bitvector (SCM_I_ARRAY_V (ra))
+ && (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
+ SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
+ len % SCM_LONG_BIT))
+ return SCM_BOOL_F;
}
v = SCM_I_ARRAY_V (ra);
@@ -607,8 +551,10 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
return sra;
}
}
- else
+ else if (scm_is_array (ra))
return ra;
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
}
#undef FUNC_NAME
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 5f40597..4baa51e 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -37,8 +37,6 @@
/** Arrays */
SCM_API SCM scm_make_array (SCM fill, SCM bounds);
-SCM_API SCM scm_from_contiguous_array (SCM bounds, const SCM *elts,
- size_t len);
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,
@@ -54,7 +52,7 @@ SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);
/* internal. */
-#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0)
+#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0) /* currently unused */
#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc7_array, a)
#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x)>>17))
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 20cb78b..6f37196 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -294,6 +294,12 @@
(with-test-prefix/c&e "array-contents"
+ (pass-if "0-rank array"
+ (let ((a (make-vector 1 77)))
+ (and
+ (eq? a (array-contents (make-shared-array a (const '(0)))))
+ (eq? a (array-contents (make-shared-array a (const '(0))) #t)))))
+
(pass-if "simple vector"
(let* ((a (make-array 0 4)))
(eq? a (array-contents a))))
--
2.7.3
[-- Attachment #5: 0004-Avoid-unneeded-internal-use-of-array-handles.patch --]
[-- Type: application/octet-stream, Size: 9393 bytes --]
From 55619d0e1953542449c5fc57b5f4889dfa99310f Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Mon, 9 Feb 2015 12:11:52 +0100
Subject: [PATCH 04/12] Avoid unneeded internal use of array handles
* libguile/arrays.c (scm_shared_array_root): Adopt uniform check order.
(scm_shared_array_offset, scm_shared_array_increments): Use the array
fields directly just as scm_shared_array_root does.
(scm_c_array_rank): Moved from libguile/generalized-arrays.c. Don't
use array handles, but follow the same type check sequence as the
other array functions (shared-array-root, etc).
(scm_array_rank): Moved from libguile/generalized-arrays.h.
* libguile/arrays.h: Move prototypes here.
* test-suite/tests/arrays.test: Tests for shared-array-offset,
shared-array-increments.
---
libguile/arrays.c | 65 +++++++++++++++++++++++-------------
libguile/arrays.h | 3 ++
libguile/generalized-arrays.c | 21 ------------
libguile/generalized-arrays.h | 3 --
test-suite/tests/arrays.test | 76 +++++++++++++++++++++++++++++++++++--------
5 files changed, 109 insertions(+), 59 deletions(-)
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 3cb547f..fb522e1 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -64,6 +64,27 @@
(SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
+size_t
+scm_c_array_rank (SCM array)
+{
+ if (SCM_I_ARRAYP (array))
+ return SCM_I_ARRAY_NDIM (array);
+ else if (scm_is_array (array))
+ return 1;
+ else
+ scm_wrong_type_arg_msg ("array-rank", SCM_ARG1, array, "array");
+}
+
+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_shared_array_root, "shared-array-root", 1, 0, 0,
(SCM ra),
"Return the root vector of a shared array.")
@@ -71,10 +92,10 @@ SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
{
if (SCM_I_ARRAYP (ra))
return SCM_I_ARRAY_V (ra);
- else if (!scm_is_array (ra))
- scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
- else
+ else if (scm_is_array (ra))
return ra;
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME
@@ -84,13 +105,12 @@ SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
"Return the root vector index of the first element in the array.")
#define FUNC_NAME s_scm_shared_array_offset
{
- scm_t_array_handle handle;
- SCM res;
-
- scm_array_get_handle (ra, &handle);
- res = scm_from_size_t (handle.base);
- scm_array_handle_release (&handle);
- return res;
+ if (SCM_I_ARRAYP (ra))
+ return scm_from_size_t (SCM_I_ARRAY_BASE (ra));
+ else if (scm_is_array (ra))
+ return scm_from_size_t (0);
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME
@@ -100,18 +120,19 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
"For each dimension, return the distance between elements in the root vector.")
#define FUNC_NAME s_scm_shared_array_increments
{
- scm_t_array_handle handle;
- SCM res = SCM_EOL;
- size_t k;
- scm_t_array_dim *s;
-
- scm_array_get_handle (ra, &handle);
- k = scm_array_handle_rank (&handle);
- s = scm_array_handle_dims (&handle);
- while (k--)
- res = scm_cons (scm_from_ssize_t (s[k].inc), res);
- scm_array_handle_release (&handle);
- return res;
+ if (SCM_I_ARRAYP (ra))
+ {
+ size_t k = SCM_I_ARRAY_NDIM (ra);
+ SCM res = SCM_EOL;
+ scm_t_array_dim *dims = SCM_I_ARRAY_DIMS (ra);
+ while (k--)
+ res = scm_cons (scm_from_ssize_t (dims[k].inc), res);
+ return res;
+ }
+ else if (scm_is_array (ra))
+ return scm_list_1 (scm_from_ssize_t (1));
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 4baa51e..d3e409f 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -50,6 +50,9 @@ SCM_API SCM scm_array_contents (SCM ra, SCM strict);
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 size_t scm_c_array_rank (SCM ra);
+SCM_API SCM scm_array_rank (SCM ra);
+
/* internal. */
#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0) /* currently unused */
diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c
index 9a001eb..fdbdb4a 100644
--- a/libguile/generalized-arrays.c
+++ b/libguile/generalized-arrays.c
@@ -104,27 +104,6 @@ SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
}
#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)
diff --git a/libguile/generalized-arrays.h b/libguile/generalized-arrays.h
index dfdb8bd..cfa6905 100644
--- a/libguile/generalized-arrays.h
+++ b/libguile/generalized-arrays.h
@@ -41,9 +41,6 @@ SCM_INTERNAL SCM scm_array_p_2 (SCM);
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 size_t scm_c_array_length (SCM ra);
SCM_API SCM scm_array_length (SCM ra);
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 6f37196..c40457b 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -23,9 +23,13 @@
#:use-module (srfi srfi-4)
#:use-module (srfi srfi-4 gnu))
-;;;
-;;; array?
-;;;
+(define (array-row a i)
+ (make-shared-array a (lambda (j) (list i j))
+ (cadr (array-dimensions a))))
+
+(define (array-col a j)
+ (make-shared-array a (lambda (i) (list i j))
+ (car (array-dimensions a))))
(define exception:wrong-num-indices
(cons 'misc-error "^wrong number of indices.*"))
@@ -33,6 +37,15 @@
(define exception:length-non-negative
(cons 'read-error ".*array length must be non-negative.*"))
+(define exception:wrong-type-arg
+ (cons #t "Wrong type"))
+
+(define exception:mapping-out-of-range
+ (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
+
+;;;
+;;; array?
+;;;
(with-test-prefix "array?"
@@ -216,9 +229,6 @@
;;; make-shared-array
;;;
-(define exception:mapping-out-of-range
- (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
-
(with-test-prefix/c&e "make-shared-array"
;; this failed in guile 1.8.0
@@ -404,13 +414,57 @@
(eq? (shared-array-root a) (shared-array-root b) (array-contents a)))))
;;;
+;;; shared-array-offset
+;;;
+
+(with-test-prefix/c&e "shared-array-offset"
+
+ (pass-if "plain vector"
+ (zero? (shared-array-offset (make-vector 4 0))))
+
+ (pass-if "plain array rank 2"
+ (zero? (shared-array-offset (make-array 0 4 4))))
+
+ (pass-if "row of rank-2 array, I"
+ (= 0 (shared-array-offset (array-row (make-array 0 5 3) 0))))
+
+ (pass-if "row of rank-2 array, II"
+ (= 4 (shared-array-offset (array-row (make-array 0 6 4) 1))))
+
+ (pass-if "col of rank-2 array, I"
+ (= 0 (shared-array-offset (array-col (make-array 0 5 3) 0))))
+
+ (pass-if "col of rank-2 array, II"
+ (= 1 (shared-array-offset (array-col (make-array 0 6 4) 1)))))
+
+
+;;;
+;;; shared-array-increments
+;;;
+
+(with-test-prefix/c&e "shared-array-increments"
+
+ (pass-if "plain vector"
+ (equal? '(1) (shared-array-increments (make-vector 4 0))))
+
+ (pass-if "plain array rank 2"
+ (equal? '(4 1) (shared-array-increments (make-array 0 3 4))))
+
+ (pass-if "plain array rank 3"
+ (equal? '(20 5 1) (shared-array-increments (make-array 0 3 4 5))))
+
+ (pass-if "row of rank-2 array"
+ (equal? '(1) (shared-array-increments (array-row (make-array 0 5 3) 0))))
+
+ (pass-if "col of rank-2 array"
+ (equal? '(3) (shared-array-increments (array-col (make-array 0 5 3) 0)))))
+
+
+;;;
;;; transpose-array
;;;
; see strings.test.
-(define exception:wrong-type-arg
- (cons #t "Wrong type"))
-
(with-test-prefix/c&e "transpose-array"
(pass-if-exception "non array argument" exception:wrong-type-arg
@@ -821,10 +875,6 @@
;;; slices as generalized vectors
;;;
-(define (array-row a i)
- (make-shared-array a (lambda (j) (list i j))
- (cadr (array-dimensions a))))
-
(with-test-prefix/c&e "generalized vector slices"
(pass-if (equal? (array-row #2u32((0 1) (2 3)) 1)
#u32(2 3)))
--
2.7.3
[-- Attachment #6: 0005-Reuse-SCM_BYTEVECTOR_TYPED_LENGTH-in-scm_array_get_h.patch --]
[-- Type: application/octet-stream, Size: 2817 bytes --]
From 59500529bdf6f754f65092f020574b83f238b287 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 11 Feb 2015 12:58:01 +0100
Subject: [PATCH 05/12] Reuse SCM_BYTEVECTOR_TYPED_LENGTH in
scm_array_get_handle
* libguile/bytevectors.h (SCM_BYTEVECTOR_TYPE_SIZE,
SCM_BYTEVECTOR_TYPED_LENGTH): Moved from libguile/bytevectors.c.
* libguile/array-handle.c (scm_array_get_handle): Reuse
SCM_BYTEVECTOR_TYPED_LENGTH.
---
libguile/array-handle.c | 6 ++----
libguile/bytevectors.c | 5 -----
libguile/bytevectors.h | 5 +++++
3 files changed, 7 insertions(+), 9 deletions(-)
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 2252ecc..3595266 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -185,15 +185,13 @@ scm_array_get_handle (SCM array, scm_t_array_handle *h)
break;
case scm_tc7_bytevector:
{
- size_t byte_length, length, element_byte_size;
+ size_t length;
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;
+ length = SCM_BYTEVECTOR_TYPED_LENGTH (array);
switch (element_type)
{
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index e426ae3..cf247dc 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -192,11 +192,6 @@
#define SCM_BYTEVECTOR_SET_PARENT(_bv, _parent) \
SCM_SET_CELL_OBJECT_3 ((_bv), (_parent))
-#define SCM_BYTEVECTOR_TYPE_SIZE(var) \
- (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
-#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \
- (SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var))
-
/* The empty bytevector. */
SCM scm_null_bytevector = SCM_UNSPECIFIED;
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
index a5eeaea..af4ac1c 100644
--- a/libguile/bytevectors.h
+++ b/libguile/bytevectors.h
@@ -129,6 +129,11 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM);
#define SCM_BYTEVECTOR_CONTIGUOUS_P(_bv) \
(SCM_BYTEVECTOR_FLAGS (_bv) >> 8UL)
+#define SCM_BYTEVECTOR_TYPE_SIZE(var) \
+ (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
+#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \
+ (SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var))
+
/* Hint that is passed to `scm_gc_malloc ()' and friends. */
#define SCM_GC_BYTEVECTOR "bytevector"
--
2.7.3
[-- Attachment #7: 0006-New-functions-array-from-array-from-array-amend.patch --]
[-- Type: application/octet-stream, Size: 16076 bytes --]
From 1d15eaae496b7e4a9a72d1b16353d4b11b3c33dd Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 11 Feb 2015 16:44:21 +0100
Subject: [PATCH 06/12] New functions array-from, array-from*, array-amend!
* libguile/arrays.h (scm_array_from, scm_array_from_s,
scm_array_amend_x): New declarations.
* libguile/arrays.c (scm_array_from, scm_array_from_s,
scm_array_amend_x): New functions, export as array-from, array-from*,
array-amend!.
* test-suite/tests/arrays.test: Tests for array-from, array-from*,
array-amend!.
* doc/ref/api-compound.texi: Document array-from, array-from*,
array-amend!.
---
doc/ref/api-compound.texi | 105 +++++++++++++++++++++++++++++
libguile/arrays.c | 153 +++++++++++++++++++++++++++++++++++++++++++
libguile/arrays.h | 6 ++
test-suite/tests/arrays.test | 109 ++++++++++++++++++++++++++++++
4 files changed, 373 insertions(+)
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index b4ae79c..ccafa7a 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1709,6 +1709,111 @@ base and stride for new array indices in @var{oldarray} data. A few
sample points are enough because @var{mapfunc} is linear.
@end deffn
+
+@deffn {Scheme Procedure} array-ref array idx @dots{}
+@deffnx {C Function} scm_array_ref (array, idxlist)
+Return the element at @code{(idx @dots{})} in @var{array}.
+@end deffn
+
+@deffn {Scheme Procedure} array-from array idx @dots{}
+@deffnx {C Function} scm_array_from (array, idxlist)
+If the length of @var{idxlist} equals the rank @math{n} of
+@var{array}, return the element at @code{(idx @dots{})}, just like
+@code{(array-ref array idx @dots{})}. If, however, the length @math{k}
+of @var{idxlist} is shorter than @math{n}, then return the shared
+@math{(n-k)}-rank prefix cell of @var{array} given by @var{idxlist}.
+
+For example:
+
+@example
+@lisp
+(array-from #2((a b) (c d)) 0) @result{} #(a b)
+(array-from #2((a b) (c d)) 1) @result{} #(c d)
+(array-from #2((a b) (c d)) 1 1) @result{} d
+(array-from #2((a b) (c d))) @result{} #2((a b) (c d))
+@end lisp
+@end example
+
+@code{(apply array-from array indices)} is equivalent to
+
+@lisp
+(let ((len (length indices)))
+ (if (= (array-rank a) len)
+ (apply array-ref a indices)
+ (apply make-shared-array a
+ (lambda t (append indices t))
+ (drop (array-dimensions a) len))))
+@end lisp
+
+The name `from' comes from the J language.
+@end deffn
+
+@deffn {Scheme Procedure} array-from* array idx @dots{}
+@deffnx {C Function} scm_array_from_s (array, idxlist)
+Like @code{(array-from array idx @dots{})}, but return a 0-rank shared
+array if the length of @var{idxlist} matches the rank of
+@var{array}. This can be useful when using @var{ARRAY} as destination
+of copies.
+
+Compare:
+
+@example
+@lisp
+(array-from #2((a b) (c d)) 1 1) @result{} d
+(array-from* #2((a b) (c d)) 1) @result{} #0(d)
+(define a (make-array 'a 2 2))
+(array-fill! (array-from* a 1 1) 'b)
+a @result{} #2((a a) (a b)).
+(array-fill! (array-from a 1 1) 'b) @result{} error: not an array
+@end lisp
+@end example
+
+@code{(apply array-from* array indices)} is equivalent to
+
+@lisp
+(apply make-shared-array a
+ (lambda t (append indices t))
+ (drop (array-dimensions a) (length indices)))
+@end lisp
+@end deffn
+
+
+@deffn {Scheme Procedure} array-amend! array x idx @dots{}
+@deffnx {C Function} scm_array_amend_x (array, x, idxlist)
+If the length of @var{idxlist} equals the rank @math{n} of
+@var{array}, set the element at @code{(idx @dots{})} of @var{array} to
+@var{x}, just like @code{(array-set! array x idx @dots{})}. If,
+however, the length @math{k} of @var{idxlist} is shorter than
+@math{n}, then copy the @math{(n-k)}-rank array @var{x}
+into @math{(n-k)}-rank prefix cell of @var{array} given by
+@var{idxlist}. In this case, the last @math{(n-k)} dimensions of
+@var{array} and the dimensions of @var{x} must match exactly.
+
+This function returns the modified @var{array}.
+
+For example:
+
+@example
+@lisp
+(array-amend! (make-array 'a 2 2) b 1 1) @result{} #2((a a) (a b))
+(array-amend! (make-array 'a 2 2) #(x y) 1) @result{} #2((a a) (x y))
+@end lisp
+@end example
+
+@code{(apply array-amend! array x indices)} is equivalent to
+
+@lisp
+(let ((len (length indices)))
+ (if (= (array-rank array) len)
+ (apply array-set! array x indices)
+ (array-copy! x (apply array-from array indices)))
+ array)
+@end lisp
+
+The name `amend' comes from the J language.
+@end deffn
+
+
@deffn {Scheme Procedure} shared-array-increments array
@deffnx {C Function} scm_shared_array_increments (array)
For each dimension, return the distance between elements in the root vector.
diff --git a/libguile/arrays.c b/libguile/arrays.c
index fb522e1..26c4543 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -416,6 +416,159 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
#undef FUNC_NAME
+#define ARRAY_FROM_POS(error_args) \
+ scm_t_array_handle handle; \
+ scm_array_get_handle (ra, &handle); \
+ scm_t_array_dim * s = scm_array_handle_dims (&handle); \
+ size_t ndim = scm_array_handle_rank (&handle); \
+ size_t k = ndim; \
+ ssize_t pos = 0; \
+ SCM i = indices; \
+ for (; k>0 && scm_is_pair (i); --k, ++s, i=scm_cdr (i)) \
+ { \
+ ssize_t ik = scm_to_ssize_t (scm_car (i)); \
+ if (ik<s->lbnd || ik>s->ubnd) \
+ { \
+ scm_array_handle_release (&handle); \
+ scm_misc_error (FUNC_NAME, "indices out of range", error_args); \
+ } \
+ pos += (ik-s->lbnd) * s->inc; \
+ }
+
+#define ARRAY_FROM_GET_O \
+ o = scm_i_make_array (k); \
+ SCM_I_ARRAY_SET_V (o, handle.vector); \
+ SCM_I_ARRAY_SET_BASE (o, pos + handle.base); \
+ scm_t_array_dim * os = SCM_I_ARRAY_DIMS (o); \
+ for (; k>0; --k, ++s, ++os) \
+ { \
+ os->ubnd = s->ubnd; \
+ os->lbnd = s->lbnd; \
+ os->inc = s->inc; \
+ }
+
+
+SCM_DEFINE (scm_array_from_s, "array-from*", 1, 0, 1,
+ (SCM ra, SCM indices),
+ "Return the array slice @var{ra}[@var{indices} ..., ...]\n"
+ "The rank of @var{ra} must equal to the number of indices or larger.\n\n"
+ "See also @code{array-ref}, @code{array-from}, @code{array-amend!}.\n\n"
+ "@code{array-from*} may return a rank-0 array. For example:\n"
+ "@lisp\n"
+ "(array-from* #2((1 2 3) (4 5 6)) 1 1) @result{} #0(5)\n"
+ "(array-from* #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n"
+ "(array-from* #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n"
+ "(array-from* #0(5) @result{} #0(5).\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_from_s
+{
+ ARRAY_FROM_POS(scm_list_2 (ra, indices))
+ SCM o;
+ if (k==ndim)
+ o = ra;
+ else if (scm_is_null (i))
+ { ARRAY_FROM_GET_O }
+ else
+ {
+ scm_array_handle_release (&handle);
+ scm_misc_error(FUNC_NAME, "too many indices", scm_list_2 (ra, indices));
+ }
+ scm_array_handle_release (&handle);
+ return o;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_array_from, "array-from", 1, 0, 1,
+ (SCM ra, SCM indices),
+ "Return the element at the @code{(@var{indices} ...)} position\n"
+ "in array @var{ra}, or the array slice @var{ra}[@var{indices} ..., ...]\n"
+ "if the rank of @var{ra} is larger than the number of indices.\n\n"
+ "See also @code{array-ref}, @code{array-from*}, @code{array-amend!}.\n\n"
+ "@code{array-from} never returns a rank 0 array. For example:\n"
+ "@lisp\n"
+ "(array-from #2((1 2 3) (4 5 6)) 1 1) @result{} 5\n"
+ "(array-from #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n"
+ "(array-from #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n"
+ "(array-from #0(5) @result{} 5.\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_from
+{
+ ARRAY_FROM_POS(scm_list_2 (ra, indices))
+ SCM o;
+ if (k>0)
+ {
+ if (k==ndim)
+ o = ra;
+ else
+ { ARRAY_FROM_GET_O }
+ }
+ else if (scm_is_null(i))
+ o = scm_array_handle_ref (&handle, pos);
+ else
+ {
+ scm_array_handle_release (&handle);
+ scm_misc_error(FUNC_NAME, "too many indices", scm_list_2 (ra, indices));
+ }
+ scm_array_handle_release (&handle);
+ return o;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
+ (SCM ra, SCM b, SCM indices),
+ "Set the array slice @var{ra}[@var{indices} ..., ...] to @var{b}\n."
+ "Equivalent to @code{(array-copy! @var{b} (apply array-from @var{ra} @var{indices}))}\n"
+ "if the number of indices is smaller than the rank of @var{ra}; otherwise\n"
+ "equivalent to @code{(apply array-set! @var{ra} @var{b} @var{indices})}.\n"
+ "This function returns the modified array @var{ra}.\n\n"
+ "See also @code{array-ref}, @code{array-from}, @code{array-from*}.\n\n"
+ "For example:\n"
+ "@lisp\n"
+ "(define A (list->array 2 '((1 2 3) (4 5 6))))\n"
+ "(array-amend! A #0(99) 1 1) @result{} #2((1 2 3) (4 #0(99) 6))\n"
+ "(array-amend! A 99 1 1) @result{} #2((1 2 3) (4 99 6))\n"
+ "(array-amend! A #(a b c) 0) @result{} #2((a b c) (4 99 6))\n"
+ "(array-amend! A #2((x y z) (9 8 7))) @result{} #2((x y z) (9 8 7))\n\n"
+ "(define B (make-array 0))\n"
+ "(array-amend! B 15) @result{} #0(15)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_amend_x
+{
+ ARRAY_FROM_POS(scm_list_3 (ra, b, indices))
+ SCM o;
+ if (k>0)
+ {
+ if (k==ndim)
+ o = ra;
+ else
+ { ARRAY_FROM_GET_O }
+ scm_array_handle_release(&handle);
+ /* an error is still possible here if o and b don't match. */
+ /* TODO copying like this wastes the handle, and the bounds matching
+ behavior of array-copy! is not strict. */
+ scm_array_copy_x(b, o);
+ }
+ else if (scm_is_null(i))
+ {
+ scm_array_handle_set (&handle, pos, b); /* ra may be non-ARRAYP */
+ scm_array_handle_release (&handle);
+ }
+ else
+ {
+ scm_array_handle_release (&handle);
+ scm_misc_error(FUNC_NAME, "too many indices", scm_list_3 (ra, b, indices));
+ }
+ return ra;
+}
+#undef FUNC_NAME
+
+
+#undef ARRAY_FROM_POS
+#undef ARRAY_FROM_GET_O
+
+
/* args are RA . DIMS */
SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
(SCM ra, SCM args),
diff --git a/libguile/arrays.h b/libguile/arrays.h
index d3e409f..9b7fd6c 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -41,12 +41,18 @@ 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_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_contents (SCM ra, SCM strict);
+SCM_API SCM scm_array_from_s (SCM ra, SCM indices);
+SCM_API SCM scm_array_from (SCM ra, SCM indices);
+SCM_API SCM scm_array_amend_x (SCM ra, SCM b, SCM indices);
+
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);
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index c40457b..9bd0676 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -296,6 +296,115 @@
(and (eqv? 5 (array-ref s2 1))
(eqv? 8 (array-ref s2 2))))))
+
+;;;
+;;; array-from*
+;;;
+
+(with-test-prefix/c&e "array-from*"
+
+ (pass-if "vector I"
+ (let ((v (vector 1 2 3)))
+ (array-fill! (array-from* v 1) 'a)
+ (array-equal? v #(1 a 3))))
+
+ (pass-if "vector II"
+ (let ((v (vector 1 2 3)))
+ (array-copy! #(a b c) (array-from* v))
+ (array-equal? v #(a b c))))
+
+ (pass-if "array I"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-fill! (array-from* a 1 1) 'a)
+ (array-equal? a #2((1 2 3) (4 a 6)))))
+
+ (pass-if "array II"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-copy! #(a b c) (array-from* a 1))
+ (array-equal? a #2((1 2 3) (a b c)))))
+
+ (pass-if "array III"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-copy! #2((a b c) (x y z)) (array-from* a))
+ (array-equal? a #2((a b c) (x y z)))))
+
+ (pass-if "rank 0 array"
+ (let ((a (make-array 77)))
+ (array-fill! (array-from* a) 'a)
+ (array-equal? a #0(a)))))
+
+
+;;;
+;;; array-from
+;;;
+
+(with-test-prefix/c&e "array-from"
+
+ (pass-if "vector I"
+ (let ((v (vector 1 2 3)))
+ (equal? 2 (array-from v 1))))
+
+ (pass-if "vector II"
+ (let ((v (vector 1 2 3)))
+ (array-copy! #(a b c) (array-from v))
+ (array-equal? v #(a b c))))
+
+ (pass-if "array I"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (equal? 5 (array-from a 1 1))))
+
+ (pass-if "array II"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-copy! #(a b c) (array-from a 1))
+ (array-equal? a #2((1 2 3) (a b c)))))
+
+ (pass-if "array III"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-copy! #2((a b c) (x y z)) (array-from a))
+ (array-equal? a #2((a b c) (x y z)))))
+
+ (pass-if "rank 0 array"
+ (let ((a (make-array 77)))
+ (equal? (array-from a) 77))))
+
+
+;;;
+;;; array-amend!
+;;;
+
+(with-test-prefix/c&e "array-amend!"
+
+ (pass-if "vector I"
+ (let ((v (vector 1 2 3)))
+ (and (eq? v (array-amend! v 'x 1))
+ (array-equal? v #(1 x 3)))))
+
+ (pass-if "vector II"
+ (let ((v (vector 1 2 3)))
+ (and (eq? v (array-amend! (array-from v) #(a b c)))
+ (array-equal? v #(a b c)))))
+
+ (pass-if "array I"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (and (eq? a (array-amend! a 'x 1 1))
+ (array-equal? a #2((1 2 3) (4 x 6))))))
+
+ (pass-if "array II"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (and (eq? a (array-amend! a #(a b c) 1))
+ (array-equal? a #2((1 2 3) (a b c))))))
+
+ (pass-if "array III"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (and (eq? a (array-amend! a #2((a b c) (x y z))))
+ (array-equal? a #2((a b c) (x y z))))))
+
+ (pass-if "rank 0 array"
+ (let ((a (make-array 77)))
+ (and (eq? a (array-amend! a 99))
+ (array-equal? a #0(99))))))
+
+
;;;
;;; array-contents
;;;
--
2.7.3
[-- Attachment #8: 0007-Remove-deprecated-array-functions.patch --]
[-- Type: application/octet-stream, Size: 10734 bytes --]
From 2f2a098bef85d350198ce4a0ff0d25c18a3cf598 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Fri, 13 Feb 2015 16:45:21 +0100
Subject: [PATCH 07/12] Remove deprecated array functions
* libguile/array-map.c (scm_array_fill_int, scm_array_fill_int,
scm_ra_eqp, scm_ra_lessp scm_ra_leqp, scm_ra_grp, scm_ra_greqp,
scm_ra_sum, scm_ra_difference, scm_ra_product, scm_ra_divide,
scm_array_identity): Remove deprecated functions.
* libguile/array-map.h: Remove declaration of deprecated functions.
* libguile/generalized-vectors.h, libguile/generalized-vectors.c
(scm_is_generalized_vector, scm_c_generalized_vector_length,
scm_c_generalized_vector_ref, scm_c_generalized_vector_set_x): These
functions were deprecated in 2.0.9. Remove.
---
libguile/array-map.c | 261 -----------------------------------------
libguile/array-map.h | 16 ---
libguile/generalized-vectors.c | 31 -----
libguile/generalized-vectors.h | 4 -
4 files changed, 312 deletions(-)
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 938f0a7..587df02 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -307,267 +307,6 @@ SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
#undef FUNC_NAME
-#if SCM_ENABLE_DEPRECATED == 1
-
-/* to be used as cproc in scm_ramapc to fill an array dimension with
- "fill". */
-int
-scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
-{
- unsigned long i;
- unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
- long inc = SCM_I_ARRAY_DIMS (ra)->inc;
- unsigned long base = SCM_I_ARRAY_BASE (ra);
-
- ra = SCM_I_ARRAY_V (ra);
-
- for (i = base; n--; i += inc)
- ASET (ra, i, fill);
-
- return 1;
-}
-
-/* Functions callable by ARRAY-MAP! */
-
-int
-scm_ra_eqp (SCM ra0, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
- scm_t_array_handle ra0_handle;
- scm_t_array_dim *ra0_dims;
- size_t n;
- ssize_t inc0;
- size_t i0 = 0;
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- ra2 = SCM_I_ARRAY_V (ra2);
-
- scm_array_get_handle (ra0, &ra0_handle);
- ra0_dims = scm_array_handle_dims (&ra0_handle);
- n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
- inc0 = ra0_dims[0].inc;
-
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
- if (!scm_is_eq (AREF (ra1, i1), AREF (ra2, i2)))
- scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
- }
-
- scm_array_handle_release (&ra0_handle);
- return 1;
-}
-
-/* opt 0 means <, nonzero means >= */
-
-static int
-ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
-{
- scm_t_array_handle ra0_handle;
- scm_t_array_dim *ra0_dims;
- size_t n;
- ssize_t inc0;
- size_t i0 = 0;
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- ra2 = SCM_I_ARRAY_V (ra2);
-
- scm_array_get_handle (ra0, &ra0_handle);
- ra0_dims = scm_array_handle_dims (&ra0_handle);
- n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
- inc0 = ra0_dims[0].inc;
-
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
- if (opt ?
- scm_is_true (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))) :
- scm_is_false (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))))
- scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
- }
-
- scm_array_handle_release (&ra0_handle);
- return 1;
-}
-
-
-
-int
-scm_ra_lessp (SCM ra0, SCM ras)
-{
- return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
-}
-
-
-int
-scm_ra_leqp (SCM ra0, SCM ras)
-{
- return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
-}
-
-
-int
-scm_ra_grp (SCM ra0, SCM ras)
-{
- return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
-}
-
-
-int
-scm_ra_greqp (SCM ra0, SCM ras)
-{
- return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
-}
-
-
-int
-scm_ra_sum (SCM ra0, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (!scm_is_null(ras))
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- ASET (ra0, i0, scm_sum (AREF(ra0, i0), AREF(ra1, i1)));
- break;
- }
- }
- }
- return 1;
-}
-
-
-
-int
-scm_ra_difference (SCM ra0, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (scm_is_null (ras))
- {
- switch (SCM_TYP7 (ra0))
- {
- default:
- {
- for (; n-- > 0; i0 += inc0)
- ASET (ra0, i0, scm_difference (AREF(ra0, i0), SCM_UNDEFINED));
- break;
- }
- }
- }
- else
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- ASET (ra0, i0, scm_difference (AREF (ra0, i0), AREF (ra1, i1)));
- break;
- }
- }
- }
- return 1;
-}
-
-
-
-int
-scm_ra_product (SCM ra0, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (!scm_is_null (ras))
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- ASET (ra0, i0, scm_product (AREF (ra0, i0), AREF (ra1, i1)));
- }
- }
- }
- return 1;
-}
-
-
-int
-scm_ra_divide (SCM ra0, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (scm_is_null (ras))
- {
- switch (SCM_TYP7 (ra0))
- {
- default:
- {
- for (; n-- > 0; i0 += inc0)
- ASET (ra0, i0, scm_divide (AREF (ra0, i0), SCM_UNDEFINED));
- break;
- }
- }
- }
- else
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- {
- SCM res = scm_divide (AREF (ra0, i0), AREF (ra1, i1));
- ASET (ra0, i0, res);
- }
- break;
- }
- }
- }
- return 1;
-}
-
-
-int
-scm_array_identity (SCM dst, SCM src)
-{
- return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
-}
-
-#endif /* SCM_ENABLE_DEPRECATED */
-
static int
ramap (SCM ra0, SCM proc, SCM ras)
{
diff --git a/libguile/array-map.h b/libguile/array-map.h
index b0592d8..e7431b1 100644
--- a/libguile/array-map.h
+++ b/libguile/array-map.h
@@ -39,22 +39,6 @@ SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc);
SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1);
SCM_INTERNAL void scm_init_array_map (void);
-#if SCM_ENABLE_DEPRECATED == 1
-
-SCM_DEPRECATED int scm_array_fill_int (SCM ra, SCM fill, SCM ignore);
-SCM_DEPRECATED int scm_ra_eqp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_lessp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_leqp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_grp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_greqp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_sum (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_difference (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_product (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_divide (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_array_identity (SCM src, SCM dst);
-
-#endif /* SCM_ENABLE_DEPRECATED == 1 */
-
#endif /* SCM_ARRAY_MAP_H */
/*
diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c
index fc493bc..0fe8b89 100644
--- a/libguile/generalized-vectors.c
+++ b/libguile/generalized-vectors.c
@@ -69,19 +69,6 @@ SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0,
}
#undef FUNC_NAME
-int
-scm_is_generalized_vector (SCM obj)
-{
- int ret = 0;
- if (scm_is_array (obj))
- {
- scm_t_array_handle h;
- scm_array_get_handle (obj, &h);
- ret = scm_array_handle_rank (&h) == 1;
- scm_array_handle_release (&h);
- }
- return ret;
-}
#define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \
scm_generalized_vector_get_handle (val, handle)
@@ -98,24 +85,6 @@ scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h)
}
}
-size_t
-scm_c_generalized_vector_length (SCM v)
-{
- return scm_c_array_length (v);
-}
-
-SCM
-scm_c_generalized_vector_ref (SCM v, ssize_t idx)
-{
- return scm_c_array_ref_1 (v, idx);
-}
-
-void
-scm_c_generalized_vector_set_x (SCM v, ssize_t idx, SCM val)
-{
- scm_c_array_set_1_x (v, val, idx);
-}
-
void
scm_init_generalized_vectors ()
{
diff --git a/libguile/generalized-vectors.h b/libguile/generalized-vectors.h
index 876537a..77d6272 100644
--- a/libguile/generalized-vectors.h
+++ b/libguile/generalized-vectors.h
@@ -30,10 +30,6 @@
/* Generalized vectors */
-SCM_API int scm_is_generalized_vector (SCM obj);
-SCM_API size_t scm_c_generalized_vector_length (SCM v);
-SCM_API SCM scm_c_generalized_vector_ref (SCM v, ssize_t idx);
-SCM_API void scm_c_generalized_vector_set_x (SCM v, ssize_t idx, SCM val);
SCM_API void scm_generalized_vector_get_handle (SCM vec,
scm_t_array_handle *h);
--
2.7.3
[-- Attachment #9: 0008-Do-not-use-array-handles-in-scm_vector.patch --]
[-- Type: application/octet-stream, Size: 3542 bytes --]
From 83c4f1882858feea508cacf6d77b15155a2eb2ea Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 25 Feb 2015 09:47:40 +0100
Subject: [PATCH 08/12] Do not use array handles in scm_vector
* libguile/vectors.c (scm_vector): Use SCM_I_VECTOR_WELTS on new vector
instead of generic scm_vector_elements; cf. scm_vector_copy().
(scm_vector_elements): Forward to scm_vector_writable_elements().
(scm_vector_writable_elements): Remove special error message for weak
vector arg.
* libguile/generalized-vectors.c (SCM_VALIDATE_VECTOR_WITH_HANDLE):
Remove unused macro.
* libguile/array-handle.c (scm_array_handle_elements): Forward to
scm_array_handle_writable_elements().
---
libguile/array-handle.c | 4 +---
libguile/generalized-vectors.c | 5 -----
libguile/vectors.c | 20 ++------------------
3 files changed, 3 insertions(+), 26 deletions(-)
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 3595266..89277d9 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -320,9 +320,7 @@ scm_array_handle_release (scm_t_array_handle *h)
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;
+ return scm_array_handle_writable_elements (h);
}
SCM *
diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c
index 0fe8b89..276b9d8 100644
--- a/libguile/generalized-vectors.c
+++ b/libguile/generalized-vectors.c
@@ -69,11 +69,6 @@ SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0,
}
#undef FUNC_NAME
-
-#define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \
- scm_generalized_vector_get_handle (val, handle)
-
-
void
scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h)
{
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 5dab545..6dcc7eb 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -59,26 +59,13 @@ const SCM *
scm_vector_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
- if (SCM_I_WVECTP (vec))
- scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
-
- scm_generalized_vector_get_handle (vec, h);
- if (lenp)
- {
- scm_t_array_dim *dim = scm_array_handle_dims (h);
- *lenp = dim->ubnd - dim->lbnd + 1;
- *incp = dim->inc;
- }
- return scm_array_handle_elements (h);
+ return scm_vector_writable_elements (vec, h, lenp, incp);
}
SCM *
scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
- if (SCM_I_WVECTP (vec))
- scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
-
scm_generalized_vector_get_handle (vec, h);
if (lenp)
{
@@ -141,12 +128,11 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
SCM res;
SCM *data;
long i, len;
- scm_t_array_handle handle;
SCM_VALIDATE_LIST_COPYLEN (1, l, len);
res = scm_c_make_vector (len, SCM_UNSPECIFIED);
- data = scm_vector_writable_elements (res, &handle, NULL, NULL);
+ data = SCM_I_VECTOR_WELTS (res);
i = 0;
while (scm_is_pair (l) && i < len)
{
@@ -155,8 +141,6 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
i += 1;
}
- scm_array_handle_release (&handle);
-
return res;
}
#undef FUNC_NAME
--
2.7.3
[-- Attachment #10: 0009-Speed-up-for-multi-arg-cases-of-scm_ramap-functions.patch --]
[-- Type: application/octet-stream, Size: 11938 bytes --]
From e9f0ee4e1235097f656d281aa2e384b08253a3e6 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Fri, 13 Feb 2015 18:42:27 +0100
Subject: [PATCH 09/12] Speed up for multi-arg cases of scm_ramap functions
This patch results in a 20%-40% speedup in the > 1 argument cases of
the following microbenchmarks:
(define A (make-shared-array #0(1) (const '()) #e1e7))
; 1, 2, 3 arguments.
(define a 0) ,time (array-for-each (lambda (b) (set! a (+ a b))) A)
(define a 0) ,time (array-for-each (lambda (b c) (set! a (+ a b c))) A A)
(define a 0) ,time (array-for-each (lambda (b c d) (set! a (+ a b c d))) A A A)
(define A (make-shared-array (make-array 1) (const '()) #e1e7))
(define B (make-shared-array #0(1) (const '()) #e1e7))
; 1, 2, 3 arguments.
,time (array-map! A + B)
,time (array-map! A + B B)
,time (array-map! A + B B B)
* libguile/array-map.c (scm_ramap): Note on cproc arguments.
(rafill): Assume that dst's lbnd is 0.
(racp): Assume that src's lbnd is 0.
(ramap): Assume that ra0's lbnd is 0. When there're more than two
arguments, compute the array handles before the loop. Allocate the arg
list once and reuse it in the loop.
(rafe): Do as in ramap(), when there's more than one argument.
(AREF, ASET): Remove.
---
libguile/array-map.c | 151 +++++++++++++++++++++++---------------------
libguile/array-map.h | 2 +-
test-suite/tests/ramap.test | 4 +-
3 files changed, 83 insertions(+), 74 deletions(-)
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 587df02..058b6fe 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
- * 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+ * 2010, 2011, 2012, 2013, 2014, 2015 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
@@ -48,18 +48,6 @@
static const char vi_gc_hint[] = "array-indices";
static SCM
-AREF (SCM v, size_t pos)
-{
- return scm_c_array_ref_1 (v, pos);
-}
-
-static void
-ASET (SCM v, size_t pos, SCM val)
-{
- scm_c_array_set_1_x (v, val, pos);
-}
-
-static SCM
make1array (SCM v, ssize_t inc)
{
SCM a = scm_i_make_array (1);
@@ -99,6 +87,10 @@ cindk (SCM ra, ssize_t *ve, int kend)
#define LBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].lbnd
#define UBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].ubnd
+
+/* scm_ramapc() always calls cproc with rank-1 arrays created by
+ make1array. cproc (rafe, ramap, rafill, racp) can assume that the
+ dims[0].lbnd of these arrays is always 0. */
int
scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
{
@@ -167,7 +159,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
va1 = make1array (ra1, 1);
- if (LBND (ra0, 0) < LBND (va1, 0) || UBND (ra0, 0) > UBND (va1, 0))
+ if (LBND (ra0, 0) < 0 /* LBND (va1, 0) */ || UBND (ra0, 0) > UBND (va1, 0))
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
}
*plva = scm_cons (va1, SCM_EOL);
@@ -224,14 +216,12 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
static int
rafill (SCM dst, SCM fill)
{
- scm_t_array_handle h;
- size_t n, i;
- ssize_t inc;
- scm_array_get_handle (SCM_I_ARRAY_V (dst), &h);
- i = SCM_I_ARRAY_BASE (dst);
- inc = SCM_I_ARRAY_DIMS (dst)->inc;
- n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1);
+ size_t n = SCM_I_ARRAY_DIMS (dst)->ubnd + 1;
+ size_t i = SCM_I_ARRAY_BASE (dst);
+ ssize_t inc = SCM_I_ARRAY_DIMS (dst)->inc;
dst = SCM_I_ARRAY_V (dst);
+ scm_t_array_handle h;
+ scm_array_get_handle (dst, &h);
for (; n-- > 0; i += inc)
h.vset (h.vector, i, fill);
@@ -255,19 +245,15 @@ SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
static int
racp (SCM src, SCM dst)
{
- scm_t_array_handle h_s, h_d;
- size_t n, i_s, i_d;
- ssize_t inc_s, inc_d;
-
dst = SCM_CAR (dst);
- i_s = SCM_I_ARRAY_BASE (src);
- i_d = SCM_I_ARRAY_BASE (dst);
- inc_s = SCM_I_ARRAY_DIMS (src)->inc;
- inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
- n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
+ size_t i_s = SCM_I_ARRAY_BASE (src);
+ size_t i_d = SCM_I_ARRAY_BASE (dst);
+ size_t n = (SCM_I_ARRAY_DIMS (src)->ubnd + 1);
+ ssize_t inc_s = SCM_I_ARRAY_DIMS (src)->inc;
+ ssize_t inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
src = SCM_I_ARRAY_V (src);
dst = SCM_I_ARRAY_V (dst);
-
+ scm_t_array_handle h_s, h_d;
scm_array_get_handle (src, &h_s);
scm_array_get_handle (dst, &h_d);
@@ -310,44 +296,56 @@ SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
static int
ramap (SCM ra0, SCM proc, SCM ras)
{
- scm_t_array_handle h0;
- size_t n, i0;
- ssize_t i, inc0;
- i0 = SCM_I_ARRAY_BASE (ra0);
- inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
- n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
+ size_t i0 = SCM_I_ARRAY_BASE (ra0);
+ ssize_t inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd + 1;
ra0 = SCM_I_ARRAY_V (ra0);
+ scm_t_array_handle h0;
scm_array_get_handle (ra0, &h0);
+
if (scm_is_null (ras))
for (; n--; i0 += inc0)
h0.vset (h0.vector, i0, scm_call_0 (proc));
else
{
SCM ra1 = SCM_CAR (ras);
- scm_t_array_handle h1;
- size_t i1;
- ssize_t inc1;
- i1 = SCM_I_ARRAY_BASE (ra1);
- inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
ras = SCM_CDR (ras);
+ size_t i1 = SCM_I_ARRAY_BASE (ra1);
+ ssize_t inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
ra1 = SCM_I_ARRAY_V (ra1);
+ scm_t_array_handle h1;
scm_array_get_handle (ra1, &h1);
if (scm_is_null (ras))
for (; n--; i0 += inc0, i1 += inc1)
h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1)));
else
{
- ras = scm_vector (ras);
- for (; n--; i0 += inc0, i1 += inc1, ++i)
+ size_t restn = scm_ilength (ras);
+
+ SCM args = SCM_EOL;
+ SCM *p = &args;
+ SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k)
+ {
+ *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
+ sa[k] = SCM_CARLOC (*p);
+ p = SCM_CDRLOC (*p);
+ }
+
+ scm_t_array_handle *hs = scm_gc_malloc
+ (sizeof(scm_t_array_handle) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k, ras = scm_cdr (ras))
+ scm_array_get_handle (scm_car (ras), hs+k);
+
+ for (ssize_t i = 0; n--; i0 += inc0, i1 += inc1, ++i)
{
- SCM args = SCM_EOL;
- unsigned long k;
- for (k = scm_c_vector_length (ras); k--;)
- args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
- h0.vset (h0.vector, i0,
- scm_apply_1 (proc, h1.vref (h1.vector, i1), args));
+ for (size_t k = 0; k < restn; ++k)
+ *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc);
+ h0.vset (h0.vector, i0, scm_apply_1 (proc, h1.vref (h1.vector, i1), args));
}
+
+ for (size_t k = 0; k < restn; ++k)
+ scm_array_handle_release (hs+k);
}
scm_array_handle_release (&h1);
}
@@ -384,30 +382,44 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
static int
rafe (SCM ra0, SCM proc, SCM ras)
{
- ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
- size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
-
- scm_t_array_handle h0;
- size_t i0;
- ssize_t inc0;
- i0 = SCM_I_ARRAY_BASE (ra0);
- inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ size_t i0 = SCM_I_ARRAY_BASE (ra0);
+ ssize_t inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd + 1;
ra0 = SCM_I_ARRAY_V (ra0);
+ scm_t_array_handle h0;
scm_array_get_handle (ra0, &h0);
+
if (scm_is_null (ras))
for (; n--; i0 += inc0)
scm_call_1 (proc, h0.vref (h0.vector, i0));
else
{
- ras = scm_vector (ras);
- for (; n--; i0 += inc0, ++i)
+ size_t restn = scm_ilength (ras);
+
+ SCM args = SCM_EOL;
+ SCM *p = &args;
+ SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k)
{
- SCM args = SCM_EOL;
- unsigned long k;
- for (k = scm_c_vector_length (ras); k--;)
- args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
+ *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
+ sa[k] = SCM_CARLOC (*p);
+ p = SCM_CDRLOC (*p);
+ }
+
+ scm_t_array_handle *hs = scm_gc_malloc
+ (sizeof(scm_t_array_handle) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k, ras = scm_cdr (ras))
+ scm_array_get_handle (scm_car (ras), hs+k);
+
+ for (ssize_t i = 0; n--; i0 += inc0, ++i)
+ {
+ for (size_t k = 0; k < restn; ++k)
+ *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc);
scm_apply_1 (proc, h0.vref (h0.vector, i0), args);
}
+
+ for (size_t k = 0; k < restn; ++k)
+ scm_array_handle_release (hs+k);
}
scm_array_handle_release (&h0);
return 1;
@@ -445,15 +457,12 @@ static void
array_index_map_n (SCM ra, SCM proc)
{
scm_t_array_handle h;
- size_t i;
int k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
- ssize_t *vi;
- SCM **si;
SCM args = SCM_EOL;
SCM *p = &args;
- vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * (kmax + 1), vi_gc_hint);
- si = scm_gc_malloc_pointerless (sizeof(SCM *) * (kmax + 1), vi_gc_hint);
+ ssize_t *vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * (kmax + 1), vi_gc_hint);
+ SCM **si = scm_gc_malloc_pointerless (sizeof(SCM *) * (kmax + 1), vi_gc_hint);
for (k = 0; k <= kmax; k++)
{
@@ -472,7 +481,7 @@ array_index_map_n (SCM ra, SCM proc)
if (k == kmax)
{
vi[kmax] = SCM_I_ARRAY_DIMS (ra)[kmax].lbnd;
- i = cindk (ra, vi, kmax+1);
+ size_t i = cindk (ra, vi, kmax+1);
for (; vi[kmax] <= SCM_I_ARRAY_DIMS (ra)[kmax].ubnd; ++vi[kmax])
{
*(si[kmax]) = scm_from_ssize_t (vi[kmax]);
diff --git a/libguile/array-map.h b/libguile/array-map.h
index e7431b1..cb18a62 100644
--- a/libguile/array-map.h
+++ b/libguile/array-map.h
@@ -4,7 +4,7 @@
#define SCM_ARRAY_MAP_H
/* Copyright (C) 1995, 1996, 1997, 2000, 2006, 2008, 2009, 2010,
- * 2011, 2013 Free Software Foundation, Inc.
+ * 2011, 2013, 2015 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
diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
index c8eaf96..bd8a434 100644
--- a/test-suite/tests/ramap.test
+++ b/test-suite/tests/ramap.test
@@ -453,11 +453,11 @@
(with-test-prefix "3 sources"
(pass-if-equal "noncompact arrays 1"
- '((3 3 3) (2 2 2))
+ '((3 1 3) (2 0 2))
(let* ((a #2((0 1) (2 3)))
(l '())
(rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-row a 1) (array-row a 1) (array-row a 1))
+ (array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1))
l))
(pass-if-equal "noncompact arrays 2"
--
2.7.3
[-- Attachment #11: 0010-Remove-uniform-array-read-uniform-array-write-from-t.patch --]
[-- Type: application/octet-stream, Size: 2167 bytes --]
From a96b4984c30c8e2f44abec1aeeeeafa55e15d6f0 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Thu, 23 Jun 2016 12:15:31 +0200
Subject: [PATCH 10/12] Remove uniform-array-read!, uniform-array-write from
the manual
These procedures where removed in
fc7bd367ab4b5027a7f80686b1e229c62e43c90b (2011-05-12).
* doc/ref/api-compound.texi: Ditto.
---
doc/ref/api-compound.texi | 33 ---------------------------------
1 file changed, 33 deletions(-)
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index ccafa7a..d17c4bf 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1568,39 +1568,6 @@ $\left(\matrix{%
@end example
@end deffn
-@deffn {Scheme Procedure} uniform-array-read! ra [port_or_fd [start [end]]]
-@deffnx {C Function} scm_uniform_array_read_x (ra, port_or_fd, start, end)
-Attempt to read all elements of array @var{ra}, in lexicographic order, as
-binary objects from @var{port_or_fd}.
-If an end of file is encountered,
-the objects up to that point are put into @var{ra}
-(starting at the beginning) and the remainder of the array is
-unchanged.
-
-The optional arguments @var{start} and @var{end} allow
-a specified region of a vector (or linearized array) to be read,
-leaving the remainder of the vector unchanged.
-
-@code{uniform-array-read!} returns the number of objects read.
-@var{port_or_fd} may be omitted, in which case it defaults to the value
-returned by @code{(current-input-port)}.
-@end deffn
-
-@deffn {Scheme Procedure} uniform-array-write ra [port_or_fd [start [end]]]
-@deffnx {C Function} scm_uniform_array_write (ra, port_or_fd, start, end)
-Writes all elements of @var{ra} as binary objects to
-@var{port_or_fd}.
-
-The optional arguments @var{start}
-and @var{end} allow
-a specified region of a vector (or linearized array) to be written.
-
-The number of objects actually written is returned.
-@var{port_or_fd} may be
-omitted, in which case it defaults to the value returned by
-@code{(current-output-port)}.
-@end deffn
-
@node Shared Arrays
@subsubsection Shared Arrays
--
2.7.3
[-- Attachment #12: 0011-Support-typed-arrays-in-some-sort-functions.patch --]
[-- Type: application/octet-stream, Size: 13591 bytes --]
From c338fd7e027e3257fc79715a88de31ac9cf6e835 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Tue, 12 Jul 2016 18:43:03 +0200
Subject: [PATCH 11/12] Support typed arrays in some sort functions
* libguile/sort.c (sort!, sort, restricted-vector-sort!, sorted?):
Support arrays of rank 1, whatever the type.
* libguile/quicksort.i.c: Fix accessors to handle typed arrays.
* test-suite/tests/sort.test: Test also with typed arrays.
---
libguile/quicksort.i.c | 45 ++++++++--------
libguile/sort.c | 126 ++++++++++++++++++++++++++++++---------------
test-suite/tests/sort.test | 32 +++++++++++-
3 files changed, 136 insertions(+), 67 deletions(-)
diff --git a/libguile/quicksort.i.c b/libguile/quicksort.i.c
index 4e39f82..cf1742e 100644
--- a/libguile/quicksort.i.c
+++ b/libguile/quicksort.i.c
@@ -11,7 +11,7 @@
version but doesn't consume extra memory.
*/
-#define SWAP(a, b) do { const SCM _tmp = a; a = b; b = _tmp; } while (0)
+#define SWAP(a, b) do { const SCM _tmp = GET(a); SET(a, GET(b)); SET(b, _tmp); } while (0)
/* Order using quicksort. This implementation incorporates four
@@ -54,8 +54,7 @@
#define STACK_NOT_EMPTY (stack < top)
static void
-NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
- SCM less)
+NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
{
/* Stack node declarations used to store unfulfilled partition obligations. */
typedef struct {
@@ -65,8 +64,6 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
static const char s_buggy_less[] = "buggy less predicate used when sorting";
-#define ELT(i) base_ptr[(i)*INC]
-
if (nr_elems == 0)
/* Avoid lossage with unsigned arithmetic below. */
return;
@@ -93,17 +90,17 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
SCM_TICK;
- if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo))))
- SWAP (ELT(mid), ELT(lo));
- if (scm_is_true (scm_call_2 (less, ELT(hi), ELT(mid))))
- SWAP (ELT(mid), ELT(hi));
+ if (scm_is_true (scm_call_2 (less, GET(mid), GET(lo))))
+ SWAP (mid, lo);
+ if (scm_is_true (scm_call_2 (less, GET(hi), GET(mid))))
+ SWAP (mid, hi);
else
goto jump_over;
- if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo))))
- SWAP (ELT(mid), ELT(lo));
+ if (scm_is_true (scm_call_2 (less, GET(mid), GET(lo))))
+ SWAP (mid, lo);
jump_over:;
- pivot = ELT(mid);
+ pivot = GET(mid);
left = lo + 1;
right = hi - 1;
@@ -112,7 +109,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
that this algorithm runs much faster than others. */
do
{
- while (scm_is_true (scm_call_2 (less, ELT(left), pivot)))
+ while (scm_is_true (scm_call_2 (less, GET(left), pivot)))
{
left += 1;
/* The comparison predicate may be buggy */
@@ -120,7 +117,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
scm_misc_error (NULL, s_buggy_less, SCM_EOL);
}
- while (scm_is_true (scm_call_2 (less, pivot, ELT(right))))
+ while (scm_is_true (scm_call_2 (less, pivot, GET(right))))
{
right -= 1;
/* The comparison predicate may be buggy */
@@ -130,7 +127,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
if (left < right)
{
- SWAP (ELT(left), ELT(right));
+ SWAP (left, right);
left += 1;
right -= 1;
}
@@ -192,11 +189,11 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
and the operation speeds up insertion sort's inner loop. */
for (run = tmp + 1; run <= thresh; run += 1)
- if (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp))))
+ if (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
tmp = run;
if (tmp != 0)
- SWAP (ELT(tmp), ELT(0));
+ SWAP (tmp, 0);
/* Insertion sort, running from left-hand-side up to right-hand-side. */
@@ -206,7 +203,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
SCM_TICK;
tmp = run - 1;
- while (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp))))
+ while (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
{
/* The comparison predicate may be buggy */
if (tmp == 0)
@@ -218,12 +215,12 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
tmp += 1;
if (tmp != run)
{
- SCM to_insert = ELT(run);
+ SCM to_insert = GET(run);
size_t hi, lo;
for (hi = lo = run; --lo >= tmp; hi = lo)
- ELT(hi) = ELT(lo);
- ELT(hi) = to_insert;
+ SET(hi, GET(lo));
+ SET(hi, to_insert);
}
}
}
@@ -235,9 +232,9 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
#undef PUSH
#undef POP
#undef STACK_NOT_EMPTY
-#undef ELT
+#undef GET
+#undef SET
#undef NAME
#undef INC_PARAM
-#undef INC
-
+#undef VEC_PARAM
diff --git a/libguile/sort.c b/libguile/sort.c
index 9373fb8..c3cc103 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -51,21 +51,23 @@
#include "libguile/validate.h"
#include "libguile/sort.h"
-/* We have two quicksort variants: one for contigous vectors and one
- for vectors with arbitrary increments between elements. Note that
- increments can be negative.
+/* We have two quicksort variants: one for SCM (#t) arrays and one for
+ typed arrays.
*/
-#define NAME quicksort1
-#define INC_PARAM /* empty */
-#define INC 1
-#include "libguile/quicksort.i.c"
-
#define NAME quicksort
#define INC_PARAM ssize_t inc,
-#define INC inc
+#define VEC_PARAM SCM * ra,
+#define GET(i) ra[(i)*inc]
+#define SET(i, val) ra[(i)*inc] = val
#include "libguile/quicksort.i.c"
+#define NAME quicksorta
+#define INC_PARAM
+#define VEC_PARAM scm_t_array_handle * const ra,
+#define GET(i) scm_array_handle_ref (ra, scm_array_handle_pos_1 (ra, i))
+#define SET(i, val) scm_array_handle_set (ra, scm_array_handle_pos_1 (ra, i), val)
+#include "libguile/quicksort.i.c"
SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
(SCM vec, SCM less, SCM startpos, SCM endpos),
@@ -76,22 +78,38 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
"is not specified.")
#define FUNC_NAME s_scm_restricted_vector_sort_x
{
- size_t vlen, spos, len;
- ssize_t vinc;
+ ssize_t spos = scm_to_ssize_t (startpos);
+ size_t epos = scm_to_ssize_t (endpos);
+
scm_t_array_handle handle;
- SCM *velts;
+ scm_array_get_handle (vec, &handle);
+ scm_t_array_dim const * dims = scm_array_handle_dims (&handle);
- velts = scm_vector_writable_elements (vec, &handle, &vlen, &vinc);
- spos = scm_to_unsigned_integer (startpos, 0, vlen);
- len = scm_to_unsigned_integer (endpos, spos, vlen) - spos;
+ if (scm_array_handle_rank(&handle) != 1)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", vec, SCM_EOL);
+ }
+ if (spos < dims[0].lbnd)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_out_of_range_key, FUNC_NAME, "startpos out of range",
+ vec, scm_list_1(startpos));
+ }
+ if (epos > dims[0].ubnd+1)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_out_of_range_key, FUNC_NAME, "endpos out of range",
+ vec, scm_list_1(endpos));
+ }
- if (vinc == 1)
- quicksort1 (velts + spos*vinc, len, less);
+ if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
+ quicksort (scm_array_handle_writable_elements (&handle) + (spos-dims[0].lbnd) * dims[0].inc,
+ epos-spos, dims[0].inc, less);
else
- quicksort (velts + spos*vinc, len, vinc, less);
+ quicksorta (&handle, epos-spos, less);
scm_array_handle_release (&handle);
-
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -140,29 +158,48 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
}
else
{
- scm_t_array_handle handle;
- size_t i, len;
- ssize_t inc;
- const SCM *elts;
SCM result = SCM_BOOL_T;
- elts = scm_vector_elements (items, &handle, &len, &inc);
-
- for (i = 1; i < len; i++, elts += inc)
- {
- if (scm_is_true (scm_call_2 (less, elts[inc], elts[0])))
- {
- result = SCM_BOOL_F;
- break;
- }
- }
+ scm_t_array_handle handle;
+ scm_array_get_handle (items, &handle);
+ scm_t_array_dim const * dims = scm_array_handle_dims (&handle);
+
+ if (scm_array_handle_rank(&handle) != 1)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items, SCM_EOL);
+ }
+
+ if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
+ {
+ ssize_t inc = dims[0].inc;
+ const SCM *elts = scm_array_handle_elements (&handle);
+ for (ssize_t i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i, elts += inc)
+ {
+ if (scm_is_true (scm_call_2 (less, elts[inc], elts[0])))
+ {
+ result = SCM_BOOL_F;
+ break;
+ }
+ }
+ }
+ else
+ {
+ for (ssize_t i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i)
+ {
+ if (scm_is_true (scm_call_2 (less,
+ scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i)),
+ scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i-1)))))
+ {
+ result = SCM_BOOL_F;
+ break;
+ }
+ }
+ }
scm_array_handle_release (&handle);
-
return result;
}
-
- return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -404,7 +441,13 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
if (scm_is_pair (items))
return scm_sort_x (scm_list_copy (items), less);
else if (scm_is_array (items) && scm_c_array_rank (items) == 1)
- return scm_sort_x (scm_vector_copy (items), less);
+ {
+ if (scm_c_array_rank (items) != 1)
+ scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items, SCM_EOL);
+ SCM copy = scm_make_typed_array (scm_array_type (items), SCM_UNSPECIFIED, scm_array_dimensions (items));
+ scm_array_copy_x (items, copy);
+ return scm_sort_x (copy, less);
+ }
else
SCM_WRONG_TYPE_ARG (1, items);
}
@@ -498,10 +541,11 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
vec_elts = scm_vector_writable_elements (items, &vec_handle,
&len, &inc);
- if (len == 0) {
- scm_array_handle_release (&vec_handle);
- return items;
- }
+ if (len == 0)
+ {
+ scm_array_handle_release (&vec_handle);
+ return items;
+ }
temp = scm_c_make_vector (len, SCM_UNDEFINED);
temp_elts = scm_vector_writable_elements (temp, &temp_handle,
diff --git a/test-suite/tests/sort.test b/test-suite/tests/sort.test
index 9209b53..249f890 100644
--- a/test-suite/tests/sort.test
+++ b/test-suite/tests/sort.test
@@ -31,22 +31,51 @@
exception:wrong-num-args
(sort '(1 2) (lambda (x y z) z)))
- (pass-if "sort!"
+ (pass-if "sort of vector"
+ (let* ((v (randomize-vector! (make-vector 1000) 1000))
+ (w (vector-copy v)))
+ (and (sorted? (sort v <) <)
+ (equal? w v))))
+
+ (pass-if "sort of typed array"
+ (let* ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99))
+ (w (make-typed-array 'f64 *unspecified* 99)))
+ (array-copy! v w)
+ (and (sorted? (sort v <) <)
+ (equal? w v))))
+
+ (pass-if "sort! of vector"
(let ((v (randomize-vector! (make-vector 1000) 1000)))
(sorted? (sort! v <) <)))
+ (pass-if "sort! of typed array"
+ (let ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99)))
+ (sorted? (sort! v <) <)))
+
(pass-if "sort! of non-contigous vector"
(let* ((a (make-array 0 1000 3))
(v (make-shared-array a (lambda (i) (list i 0)) 1000)))
(randomize-vector! v 1000)
(sorted? (sort! v <) <)))
+ (pass-if "sort! of non-contigous typed array"
+ (let* ((a (make-typed-array 'f64 0 99 3))
+ (v (make-shared-array a (lambda (i) (list i 0)) 99)))
+ (randomize-vector! v 99)
+ (sorted? (sort! v <) <)))
+
(pass-if "sort! of negative-increment vector"
(let* ((a (make-array 0 1000 3))
(v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000)))
(randomize-vector! v 1000)
(sorted? (sort! v <) <)))
+ (pass-if "sort! of negative-increment typed array"
+ (let* ((a (make-typed-array 'f64 0 99 3))
+ (v (make-shared-array a (lambda (i) (list (- 98 i) 0)) 99)))
+ (randomize-vector! v 99)
+ (sorted? (sort! v <) <)))
+
(pass-if "stable-sort!"
(let ((v (randomize-vector! (make-vector 1000) 1000)))
(sorted? (stable-sort! v <) <)))
@@ -79,4 +108,3 @@
;; behavior (integer underflow) leading to crashes.
(pass-if "empty vector"
(equal? '#() (stable-sort '#() <))))
-
--
2.7.3
[-- Attachment #13: 0012-New-functions-array-for-each-cell-array-for-each-cel.patch --]
[-- Type: application/octet-stream, Size: 59458 bytes --]
From 2bea30576ed2f9b3c2f50efac4b46f7492b664fe Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Tue, 8 Sep 2015 16:57:30 +0200
Subject: [PATCH 12/12] New functions (array-for-each-cell,
array-for-each-cell-in-order)
* libguile/array-map.c (scm_i_array_rebase, scm_array_for_each_cell):
New functions. Export scm_array_for_each_cell() as
(array-for-each-cell).
(array-for-each-cell-in-order): Define additional export.
* libguile/array-map.h (scm_i_array_rebase, scm_array_for_each_cell):
Add prototypes.
* doc/ref/api-compound.texi: New section 'Arrays as arrays of
arrays'. Move the documentation for (array-from), (array-from*) and
(array-amend!) in here. Add documentation for (array-for-each-cell).
* test-suite/tests/array-map.test: Renamed from
test-suite/tests/ramap.test, fix module name. Add tests for
(array-for-each-cell).
* test-suite/Makefile.am: Apply rename array-map.test -> ramap.test.
* doc/ref/api-compound.texi: Minor documentation fixes.
---
doc/ref/api-compound.texi | 169 +++++++++----
libguile/array-map.c | 265 +++++++++++++++++++-
libguile/array-map.h | 4 +
libguile/arrays.c | 5 +-
test-suite/Makefile.am | 2 +-
test-suite/tests/array-map.test | 540 ++++++++++++++++++++++++++++++++++++++++
test-suite/tests/ramap.test | 509 -------------------------------------
7 files changed, 928 insertions(+), 566 deletions(-)
create mode 100644 test-suite/tests/array-map.test
delete mode 100644 test-suite/tests/ramap.test
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index d17c4bf..bc2c98b 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1203,6 +1203,7 @@ dimensional arrays.
* Array Syntax::
* Array Procedures::
* Shared Arrays::
+* Arrays as arrays of arrays::
* Accessing Arrays from C::
@end menu
@@ -1682,24 +1683,91 @@ sample points are enough because @var{mapfunc} is linear.
Return the element at @code{(idx @dots{})} in @var{array}.
@end deffn
+
+@deffn {Scheme Procedure} shared-array-increments array
+@deffnx {C Function} scm_shared_array_increments (array)
+For each dimension, return the distance between elements in the root vector.
+@end deffn
+
+@deffn {Scheme Procedure} shared-array-offset array
+@deffnx {C Function} scm_shared_array_offset (array)
+Return the root vector index of the first element in the array.
+@end deffn
+
+@deffn {Scheme Procedure} shared-array-root array
+@deffnx {C Function} scm_shared_array_root (array)
+Return the root vector of a shared array.
+@end deffn
+
+@deffn {Scheme Procedure} array-contents array [strict]
+@deffnx {C Function} scm_array_contents (array, strict)
+If @var{array} may be @dfn{unrolled} into a one dimensional shared array
+without changing their order (last subscript changing fastest), then
+@code{array-contents} returns that shared array, otherwise it returns
+@code{#f}. All arrays made by @code{make-array} and
+@code{make-typed-array} may be unrolled, some arrays made by
+@code{make-shared-array} may not be.
+
+If the optional argument @var{strict} is provided, a shared array will
+be returned only if its elements are stored internally contiguous in
+memory.
+@end deffn
+
+@deffn {Scheme Procedure} transpose-array array dim1 dim2 @dots{}
+@deffnx {C Function} scm_transpose_array (array, dimlist)
+Return an array sharing contents with @var{array}, but with
+dimensions arranged in a different order. There must be one
+@var{dim} argument for each dimension of @var{array}.
+@var{dim1}, @var{dim2}, @dots{} should be integers between 0
+and the rank of the array to be returned. Each integer in that
+range must appear at least once in the argument list.
+
+The values of @var{dim1}, @var{dim2}, @dots{} correspond to
+dimensions in the array to be returned, and their positions in the
+argument list to dimensions of @var{array}. Several @var{dim}s
+may have the same value, in which case the returned array will
+have smaller rank than @var{array}.
+
+@lisp
+(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))
+(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)
+(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}
+ #2((a 4) (b 5) (c 6))
+@end lisp
+@end deffn
+
+@node Arrays as arrays of arrays
+@subsubsection Arrays as arrays of arrays
+
+The functions in this section allow you to treat an array of rank
+@math{n} as an array of lower rank @math{n-k} where the elements are
+themselves arrays (`cells') of rank @math{k}. This replicates some of
+the functionality of `enclosed arrays', a feature of old Guile that was
+removed before @w{version 2.0}. However, these functions do not require
+a special type and operate on any array.
+
+When we operate on an array in this way, we speak of the first @math{k}
+dimensions of the array as the @math{k}-`frame' of the array, while the
+last @math{n-k} dimensions are the dimensions of the
+@math{n-k}-`cell'. For example, a 2D-array (a matrix) can be seen as a
+1D array of rows. In this case, the rows are the 1-cells of the array.
+
@deffn {Scheme Procedure} array-from array idx @dots{}
@deffnx {C Function} scm_array_from (array, idxlist)
If the length of @var{idxlist} equals the rank @math{n} of
@var{array}, return the element at @code{(idx @dots{})}, just like
@code{(array-ref array idx @dots{})}. If, however, the length @math{k}
of @var{idxlist} is shorter than @math{n}, then return the shared
-@math{(n-k)}-rank prefix cell of @var{array} given by @var{idxlist}.
+@math{(n-k)}-rank cell of @var{array} given by @var{idxlist}.
For example:
-@example
@lisp
(array-from #2((a b) (c d)) 0) @result{} #(a b)
(array-from #2((a b) (c d)) 1) @result{} #(c d)
(array-from #2((a b) (c d)) 1 1) @result{} d
(array-from #2((a b) (c d))) @result{} #2((a b) (c d))
@end lisp
-@end example
@code{(apply array-from array indices)} is equivalent to
@@ -1719,12 +1787,11 @@ The name `from' comes from the J language.
@deffnx {C Function} scm_array_from_s (array, idxlist)
Like @code{(array-from array idx @dots{})}, but return a 0-rank shared
array if the length of @var{idxlist} matches the rank of
-@var{array}. This can be useful when using @var{ARRAY} as destination
-of copies.
+@var{array}. This can be useful when using @var{ARRAY} as a place to
+write into.
Compare:
-@example
@lisp
(array-from #2((a b) (c d)) 1 1) @result{} d
(array-from* #2((a b) (c d)) 1) @result{} #0(d)
@@ -1733,7 +1800,6 @@ Compare:
a @result{} #2((a a) (a b)).
(array-fill! (array-from a 1 1) 'b) @result{} error: not an array
@end lisp
-@end example
@code{(apply array-from* array indices)} is equivalent to
@@ -1752,7 +1818,7 @@ If the length of @var{idxlist} equals the rank @math{n} of
@var{x}, just like @code{(array-set! array x idx @dots{})}. If,
however, the length @math{k} of @var{idxlist} is shorter than
@math{n}, then copy the @math{(n-k)}-rank array @var{x}
-into @math{(n-k)}-rank prefix cell of @var{array} given by
+into the @math{(n-k)}-cell of @var{array} given by
@var{idxlist}. In this case, the last @math{(n-k)} dimensions of
@var{array} and the dimensions of @var{x} must match exactly.
@@ -1760,12 +1826,19 @@ This function returns the modified @var{array}.
For example:
-@example
@lisp
(array-amend! (make-array 'a 2 2) b 1 1) @result{} #2((a a) (a b))
(array-amend! (make-array 'a 2 2) #(x y) 1) @result{} #2((a a) (x y))
@end lisp
-@end example
+
+Note that @code{array-amend!} will expect elements, not arrays, when the
+destination has rank 0. One can work around this using
+@code{array-from*} instead.
+
+@lisp
+(array-amend! (make-array 'a 2 2) #0(b) 1 1) @result{} #2((a a) (a #0(b)))
+(let ((a (make-array 'a 2 2))) (array-copy! #0(b) (array-from* a 1 1)) a) @result{} #2((a a) (a b))
+@end lisp
@code{(apply array-amend! array x indices)} is equivalent to
@@ -1781,58 +1854,52 @@ The name `amend' comes from the J language.
@end deffn
-@deffn {Scheme Procedure} shared-array-increments array
-@deffnx {C Function} scm_shared_array_increments (array)
-For each dimension, return the distance between elements in the root vector.
-@end deffn
+@deffn {Scheme Procedure} array-for-each-cell frame-rank op x @dots{}
+@deffnx {C Function} scm_array_for_each_cell (array, frame_rank, op, xlist)
+Each @var{x} must be an array of rank ≥ @var{frame-rank}, and
+the first @var{frame-rank} dimensions of each @var{x} must all be the
+same. @var{array-for-each-cell} calls @var{op} with each set of
+(rank(@var{x}) - @var{frame-rank})-cells from @var{x}, in unspecified order.
-@deffn {Scheme Procedure} shared-array-offset array
-@deffnx {C Function} scm_shared_array_offset (array)
-Return the root vector index of the first element in the array.
-@end deffn
+@var{array-for-each-cell} allows you to loop over cells of any rank
+without having to carry an index list or construct slices manually. The
+cells passed to @var{op} are shared arrays of @var{X} so it is possible
+to write to them.
-@deffn {Scheme Procedure} shared-array-root array
-@deffnx {C Function} scm_shared_array_root (array)
-Return the root vector of a shared array.
-@end deffn
+This function returns an unspecified value.
-@deffn {Scheme Procedure} array-contents array [strict]
-@deffnx {C Function} scm_array_contents (array, strict)
-If @var{array} may be @dfn{unrolled} into a one dimensional shared array
-without changing their order (last subscript changing fastest), then
-@code{array-contents} returns that shared array, otherwise it returns
-@code{#f}. All arrays made by @code{make-array} and
-@code{make-typed-array} may be unrolled, some arrays made by
-@code{make-shared-array} may not be.
+For example, to sort the rows of rank-2 array @code{a}:
-If the optional argument @var{strict} is provided, a shared array will
-be returned only if its elements are stored internally contiguous in
-memory.
-@end deffn
+@lisp
+(array-for-each-cell 1 (lambda (x) (sort! x <)) a)
+@end lisp
-@deffn {Scheme Procedure} transpose-array array dim1 dim2 @dots{}
-@deffnx {C Function} scm_transpose_array (array, dimlist)
-Return an array sharing contents with @var{array}, but with
-dimensions arranged in a different order. There must be one
-@var{dim} argument for each dimension of @var{array}.
-@var{dim1}, @var{dim2}, @dots{} should be integers between 0
-and the rank of the array to be returned. Each integer in that
-range must appear at least once in the argument list.
+As another example, let @code{a} be a rank-2 array where each row is a 2-vector @math{(x,y)}.
+Let's compute the arguments of these vectors and store them in rank-1 array @code{b}.
+@lisp
+(array-for-each-cell 1
+ (lambda (a b)
+ (array-set! b (atan (array-ref a 1) (array-ref a 0))))
+ a b)
+@end lisp
-The values of @var{dim1}, @var{dim2}, @dots{} correspond to
-dimensions in the array to be returned, and their positions in the
-argument list to dimensions of @var{array}. Several @var{dim}s
-may have the same value, in which case the returned array will
-have smaller rank than @var{array}.
+@code{(apply array-for-each-cell frame-rank op x)} is functionally
+equivalent to
@lisp
-(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))
-(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)
-(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}
- #2((a 4) (b 5) (c 6))
+(let ((frame (take (array-dimensions (car x)) frank)))
+ (unless (every (lambda (x)
+ (equal? frame (take (array-dimensions x) frank)))
+ (cdr x))
+ (error))
+ (array-index-map!
+ (apply make-shared-array (make-array #t) (const '()) frame)
+ (lambda i (apply op (map (lambda (x) (apply array-from* x i)) x)))))
@end lisp
+
@end deffn
+
@node Accessing Arrays from C
@subsubsection Accessing Arrays from C
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 058b6fe..396aafe 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -42,7 +42,7 @@
#include "libguile/validate.h"
#include "libguile/array-map.h"
-\f
+#include <assert.h>
/* The WHAT argument for `scm_gc_malloc ()' et al. */
static const char vi_gc_hint[] = "array-indices";
@@ -610,7 +610,8 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
return SCM_BOOL_T;
while (!scm_is_null (rest))
- { if (scm_is_false (scm_array_equal_p (ra0, ra1)))
+ {
+ if (scm_is_false (scm_array_equal_p (ra0, ra1)))
return SCM_BOOL_F;
ra0 = ra1;
ra1 = scm_car (rest);
@@ -621,6 +622,265 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
#undef FUNC_NAME
+// Copy array descriptor with different base.
+SCM
+scm_i_array_rebase (SCM a, size_t base)
+{
+ size_t ndim = SCM_I_ARRAY_NDIM (a);
+ SCM b = scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3);
+ SCM_I_ARRAY_SET_V (b, SCM_I_ARRAY_V (a));
+// FIXME do check base
+ SCM_I_ARRAY_SET_BASE (b, base);
+ memcpy (SCM_I_ARRAY_DIMS (b), SCM_I_ARRAY_DIMS (a), sizeof (scm_t_array_dim)*ndim);
+ return b;
+}
+
+static inline size_t padtoptr(size_t d) { return (d + (sizeof (void *) - 1)) & ~(sizeof (void *) - 1); }
+
+SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1,
+ (SCM frame_rank, SCM op, SCM args),
+ "Apply @var{op} to each of the cells of rank rank(@var{arg})-@var{frame_rank}\n"
+ "of the arrays @var{args}, in unspecified order. The first\n"
+ "@var{frame_rank} dimensions of each @var{arg} must match.\n"
+ "Rank-0 cells are passed as rank-0 arrays.\n\n"
+ "The value returned is unspecified.\n\n"
+ "For example:\n"
+ "@lisp\n"
+ ";; Sort the rows of rank-2 array A.\n\n"
+ "(array-for-each-cell 1 (lambda (x) (sort! x <)) a)\n"
+ "\n"
+ ";; Compute the arguments of the (x y) vectors in the rows of rank-2\n"
+ ";; array XYS and store them in rank-1 array ANGLES. Inside OP,\n"
+ ";; XY is a rank-1 (2-1) array, and ANGLE is a rank-0 (1-1) array.\n\n"
+ "(array-for-each-cell 1 \n"
+ " (lambda (xy angle)\n"
+ " (array-set! angle (atan (array-ref xy 1) (array-ref xy 0))))\n"
+ " xys angles)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_for_each_cell
+{
+ int const N = scm_ilength (args);
+ int const frank = scm_to_int (frame_rank);
+ SCM dargs_ = SCM_EOL;
+
+ size_t stack_size = 0;
+ stack_size += padtoptr(N*sizeof (scm_t_array_handle));
+ stack_size += padtoptr(N*sizeof (SCM));
+ stack_size += padtoptr(N*sizeof (scm_t_array_dim *));
+ stack_size += padtoptr(N*sizeof (int));
+
+ stack_size += padtoptr(frank*sizeof (ssize_t));
+ stack_size += padtoptr(N*sizeof (SCM));
+ stack_size += padtoptr(N*sizeof (SCM *));
+ stack_size += padtoptr(frank*sizeof (ssize_t));
+
+ stack_size += padtoptr(frank*sizeof (int));
+ stack_size += padtoptr(N*sizeof (size_t));
+ char * stack = scm_gc_malloc (stack_size, "stack");
+
+#define AFIC_ALLOC_ADVANCE(stack, count, type, name) \
+ type * name = (void *)stack; \
+ stack += padtoptr(count*sizeof (type));
+
+ char * stack0 = stack;
+ AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_handle, ah);
+ AFIC_ALLOC_ADVANCE (stack, N, SCM, args_);
+ AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_dim *, as);
+ AFIC_ALLOC_ADVANCE (stack, N, int, rank);
+
+ AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, s);
+ AFIC_ALLOC_ADVANCE (stack, N, SCM, ai);
+ AFIC_ALLOC_ADVANCE (stack, N, SCM *, dargs);
+ AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, i);
+
+ AFIC_ALLOC_ADVANCE (stack, frank, int, order);
+ AFIC_ALLOC_ADVANCE (stack, N, size_t, base);
+ assert((stack0+stack_size==stack) && "internal error");
+#undef AFIC_ALLOC_ADVANCE
+
+ for (int n=0; scm_is_pair(args); args=scm_cdr(args), ++n)
+ {
+ args_[n] = scm_car(args);
+ scm_array_get_handle(args_[n], ah+n);
+ as[n] = scm_array_handle_dims(ah+n);
+ rank[n] = scm_array_handle_rank(ah+n);
+ }
+ // checks.
+ char const * msg = NULL;
+ if (frank<0)
+ {
+ msg = "bad frame rank";
+ }
+ else
+ {
+ for (int n=0; n!=N; ++n)
+ {
+ if (rank[n]<frank)
+ {
+ msg = "frame too large for arguments";
+ goto check_msg;
+ }
+ for (int k=0; k!=frank; ++k)
+ {
+ if (as[n][k].lbnd!=0)
+ {
+ msg = "non-zero base index is not supported";
+ goto check_msg;
+ }
+ if (as[0][k].ubnd!=as[n][k].ubnd)
+ {
+ msg = "mismatched frames";
+ goto check_msg;
+ }
+ s[k] = as[n][k].ubnd + 1;
+
+ // this check is needed if the array cannot be entirely
+ // unrolled, because the unrolled subloop will be run before
+ // checking the dimensions of the frame.
+ if (s[k]==0)
+ {
+ goto end;
+ }
+ }
+ }
+ }
+ check_msg: ;
+ if (msg!=NULL)
+ {
+ for (int n=0; n!=N; ++n)
+ {
+ scm_array_handle_release(ah+n);
+ }
+ scm_misc_error("array-for-each-cell", msg, scm_cons_star(frame_rank, args));
+ }
+ // prepare moving cells.
+ for (int n=0; n!=N; ++n)
+ {
+ ai[n] = scm_i_make_array(rank[n]-frank);
+ SCM_I_ARRAY_SET_V (ai[n], scm_shared_array_root(args_[n]));
+ // FIXME scm_array_handle_base (ah+n) should be in Guile
+ SCM_I_ARRAY_SET_BASE (ai[n], ah[n].base);
+ scm_t_array_dim * ais = SCM_I_ARRAY_DIMS(ai[n]);
+ for (int k=frank; k!=rank[n]; ++k)
+ {
+ ais[k-frank] = as[n][k];
+ }
+ }
+ // prepare rest list for callee.
+ {
+ SCM *p = &dargs_;
+ for (int n=0; n<N; ++n)
+ {
+ *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
+ dargs[n] = SCM_CARLOC (*p);
+ p = SCM_CDRLOC (*p);
+ }
+ }
+ // special case for rank 0.
+ if (frank==0)
+ {
+ for (int n=0; n<N; ++n)
+ {
+ *dargs[n] = ai[n];
+ }
+ scm_apply_0(op, dargs_);
+ for (int n=0; n<N; ++n)
+ {
+ scm_array_handle_release(ah+n);
+ }
+ return SCM_UNSPECIFIED;
+ }
+ // FIXME determine best looping order.
+ for (int k=0; k!=frank; ++k)
+ {
+ i[k] = 0;
+ order[k] = frank-1-k;
+ }
+ // find outermost compact dim.
+ ssize_t step = s[order[0]];
+ int ocd = 1;
+ for (; ocd<frank; step *= s[order[ocd]], ++ocd)
+ {
+ for (int n=0; n!=N; ++n)
+ {
+ if (step*as[n][order[0]].inc!=as[n][order[ocd]].inc)
+ {
+ goto ocd_reached;
+ }
+ }
+ }
+ ocd_reached: ;
+ // rank loop.
+ for (int n=0; n!=N; ++n)
+ {
+ base[n] = SCM_I_ARRAY_BASE(ai[n]);
+ }
+ for (;;)
+ {
+ // unrolled loop.
+ for (ssize_t z=0; z!=step; ++z)
+ {
+ // we are forced to create fresh array descriptors for each
+ // call since we don't know whether the callee will keep them,
+ // and Guile offers no way to copy the descriptor (since
+ // descriptors are immutable). Yet another reason why this
+ // should be in Scheme.
+ for (int n=0; n<N; ++n)
+ {
+ *dargs[n] = scm_i_array_rebase(ai[n], base[n]);
+ base[n] += as[n][order[0]].inc;
+ }
+ scm_apply_0(op, dargs_);
+ }
+ for (int n=0; n<N; ++n)
+ {
+ base[n] -= step*as[n][order[0]].inc;
+ }
+ for (int k=ocd; ; ++k)
+ {
+ if (k==frank)
+ {
+ goto end;
+ }
+ else if (i[order[k]]<s[order[k]]-1)
+ {
+ ++i[order[k]];
+ for (int n=0; n<N; ++n)
+ {
+ base[n] += as[n][order[k]].inc;
+ }
+ break;
+ }
+ else
+ {
+ i[order[k]] = 0;
+ for (int n=0; n<N; ++n)
+ {
+ base[n] += as[n][order[k]].inc*(1-s[order[k]]);
+ }
+ }
+ }
+ }
+ end:;
+ for (int n=0; n<N; ++n)
+ {
+ scm_array_handle_release(ah+n);
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_array_for_each_cell_in_order, "array-for-each-cell-in-order", 2, 0, 1,
+ (SCM frank, SCM op, SCM a),
+ "Same as array-for-each-cell, but visit the cells sequentially\n"
+ "and in row-major order.\n")
+#define FUNC_NAME s_scm_array_for_each_cell_in_order
+{
+ return scm_array_for_each_cell (frank, op, a);
+}
+#undef FUNC_NAME
+
+
void
scm_init_array_map (void)
{
@@ -628,6 +888,7 @@ scm_init_array_map (void)
scm_add_feature (s_scm_array_for_each);
}
+
/*
Local Variables:
c-file-style: "gnu"
diff --git a/libguile/array-map.h b/libguile/array-map.h
index cb18a62..acfdd5e 100644
--- a/libguile/array-map.h
+++ b/libguile/array-map.h
@@ -37,6 +37,10 @@ SCM_API SCM scm_array_map_x (SCM ra0, SCM proc, SCM lra);
SCM_API SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra);
SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc);
SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1);
+SCM_API SCM scm_array_for_each_cell (SCM frank, SCM op, SCM args);
+SCM_API SCM scm_array_for_each_cell_in_order (SCM frank, SCM op, SCM args);
+
+SCM_INTERNAL SCM scm_i_array_rebase (SCM a, size_t base);
SCM_INTERNAL void scm_init_array_map (void);
#endif /* SCM_ARRAY_MAP_H */
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 26c4543..d360cda 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -28,7 +28,6 @@
#include <stdio.h>
#include <errno.h>
#include <string.h>
-#include <assert.h>
#include "verify.h"
@@ -546,7 +545,7 @@ SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
{ ARRAY_FROM_GET_O }
scm_array_handle_release(&handle);
/* an error is still possible here if o and b don't match. */
- /* TODO copying like this wastes the handle, and the bounds matching
+ /* FIXME copying like this wastes the handle, and the bounds matching
behavior of array-copy! is not strict. */
scm_array_copy_x(b, o);
}
@@ -564,7 +563,6 @@ SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
}
#undef FUNC_NAME
-
#undef ARRAY_FROM_POS
#undef ARRAY_FROM_GET_O
@@ -943,6 +941,7 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
}
+
void
scm_init_arrays ()
{
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 473501e..49584b9 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -115,7 +115,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/r6rs-records-syntactic.test \
tests/r6rs-unicode.test \
tests/rnrs-libraries.test \
- tests/ramap.test \
+ tests/array-map.test \
tests/random.test \
tests/rdelim.test \
tests/reader.test \
diff --git a/test-suite/tests/array-map.test b/test-suite/tests/array-map.test
new file mode 100644
index 0000000..3095b78
--- /dev/null
+++ b/test-suite/tests/array-map.test
@@ -0,0 +1,540 @@
+;;;; array-map.test --- test array mapping functions -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2004, 2005, 2006, 2009, 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
+
+(define-module (test-suite test-array-map)
+ #:use-module (test-suite lib))
+
+(define exception:shape-mismatch
+ (cons 'misc-error ".*shape mismatch.*"))
+
+(define (array-row a i)
+ (make-shared-array a (lambda (j) (list i j))
+ (cadr (array-dimensions a))))
+
+(define (array-col a j)
+ (make-shared-array a (lambda (i) (list i j))
+ (car (array-dimensions a))))
+
+;;;
+;;; array-index-map!
+;;;
+
+(with-test-prefix "array-index-map!"
+
+ (pass-if "basic test"
+ (let ((nlst '()))
+ (array-index-map! (make-array #f '(1 1))
+ (lambda (n)
+ (set! nlst (cons n nlst))))
+ (equal? nlst '(1))))
+
+ (with-test-prefix "empty arrays"
+
+ (pass-if "all axes empty"
+ (array-index-map! (make-typed-array 'f64 0 0 0) (const 0))
+ (array-index-map! (make-typed-array 'b #t 0 0) (const #t))
+ (array-index-map! (make-typed-array #t 0 0 0) (const 0))
+ #t)
+
+ (pass-if "last axis empty"
+ (array-index-map! (make-typed-array 'f64 0 2 0) (const 0))
+ (array-index-map! (make-typed-array 'b #t 2 0) (const #t))
+ (array-index-map! (make-typed-array #t 0 2 0) (const 0))
+ #t)
+
+ ; the 'f64 cases fail in 2.0.9 with out-of-range.
+ (pass-if "axis empty, other than last"
+ (array-index-map! (make-typed-array 'f64 0 0 2) (const 0))
+ (array-index-map! (make-typed-array 'b #t 0 2) (const #t))
+ (array-index-map! (make-typed-array #t 0 0 2) (const 0))
+ #t))
+
+ (pass-if "rank 2"
+ (let ((a (make-array 0 2 2))
+ (b (make-array 0 2 2)))
+ (array-index-map! a (lambda (i j) i))
+ (array-index-map! b (lambda (i j) j))
+ (and (array-equal? a #2((0 0) (1 1)))
+ (array-equal? b #2((0 1) (0 1)))))))
+
+;;;
+;;; array-copy!
+;;;
+
+(with-test-prefix "array-copy!"
+
+ (with-test-prefix "empty arrays"
+
+ (pass-if "empty other than last, #t"
+ (let* ((b (make-array 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-copy! #2:0:2() c)
+ (array-equal? #2:0:2() c)))
+
+ (pass-if "empty other than last, 'f64"
+ (let* ((b (make-typed-array 'f64 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-copy! #2:0:2() c)
+ (array-equal? #2f64:0:2() c)))
+
+ ;; FIXME add empty, type 'b cases.
+
+ )
+
+ ;; note that it is the opposite of array-map!. This is, unfortunately,
+ ;; documented in the manual.
+
+ (pass-if "matching behavior I"
+ (let ((a #(1 2))
+ (b (make-array 0 3)))
+ (array-copy! a b)
+ (equal? b #(1 2 0))))
+
+ (pass-if-exception "matching behavior II" exception:shape-mismatch
+ (let ((a #(1 2 3))
+ (b (make-array 0 2)))
+ (array-copy! a b)
+ (equal? b #(1 2))))
+
+ ;; here both a & b are are unrollable down to the first axis, but the
+ ;; size mismatch limits unrolling to the last axis only.
+
+ (pass-if "matching behavior III"
+ (let ((a #3(((1 2) (3 4)) ((5 6) (7 8))))
+ (b (make-array 0 2 3 2)))
+ (array-copy! a b)
+ (array-equal? b #3(((1 2) (3 4) (0 0)) ((5 6) (7 8) (0 0))))))
+
+ (pass-if "rank 0"
+ (let ((a #0(99))
+ (b (make-array 0)))
+ (array-copy! a b)
+ (equal? b #0(99))))
+
+ (pass-if "rank 1"
+ (let* ((a #2((1 2) (3 4)))
+ (b (make-shared-array a (lambda (j) (list 1 j)) 2))
+ (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
+ (d (make-array 0 2))
+ (e (make-array 0 2)))
+ (array-copy! b d)
+ (array-copy! c e)
+ (and (equal? d #(3 4))
+ (equal? e #(4 2)))))
+
+ (pass-if "rank 2"
+ (let ((a #2((1 2) (3 4)))
+ (b (make-array 0 2 2))
+ (c (make-array 0 2 2))
+ (d (make-array 0 2 2))
+ (e (make-array 0 2 2)))
+ (array-copy! a b)
+ (array-copy! a (transpose-array c 1 0))
+ (array-copy! (transpose-array a 1 0) d)
+ (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
+ (and (equal? a #2((1 2) (3 4)))
+ (equal? b #2((1 2) (3 4)))
+ (equal? c #2((1 3) (2 4)))
+ (equal? d #2((1 3) (2 4)))
+ (equal? e #2((1 2) (3 4))))))
+
+ (pass-if "rank 2, discontinuous"
+ (let ((A #2((0 1) (2 3) (4 5)))
+ (B #2((10 11) (12 13) (14 15)))
+ (C #2((20) (21) (22)))
+ (X (make-array 0 3 5))
+ (piece (lambda (X w s)
+ (make-shared-array
+ X (lambda (i j) (list i (+ j s))) 3 w))))
+ (array-copy! A (piece X 2 0))
+ (array-copy! B (piece X 2 2))
+ (array-copy! C (piece X 1 4))
+ (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
+
+ (pass-if "null increments, not empty"
+ (let ((a (make-array 0 2 2)))
+ (array-copy! (make-shared-array #0(1) (lambda x '()) 2 2) a)
+ (array-equal? #2((1 1) (1 1))))))
+
+;;;
+;;; array-map!
+;;;
+
+(with-test-prefix "array-map!"
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (array-map!))
+
+ (pass-if-exception "one arg" exception:wrong-num-args
+ (array-map! (make-array #f 5)))
+
+ (with-test-prefix "no sources"
+
+ (pass-if "closure 0"
+ (array-map! (make-array #f 5) (lambda () #f))
+ #t)
+
+ (pass-if-exception "closure 1" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x) #f)))
+
+ (pass-if-exception "closure 2" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x y) #f)))
+
+ (pass-if-exception "subr_1" exception:wrong-num-args
+ (array-map! (make-array #f 5) length))
+
+ (pass-if-exception "subr_2" exception:wrong-num-args
+ (array-map! (make-array #f 5) logtest))
+
+ (pass-if-exception "subr_2o" exception:wrong-num-args
+ (array-map! (make-array #f 5) number->string))
+
+ (pass-if-exception "dsubr" exception:wrong-num-args
+ (array-map! (make-array #f 5) sqrt))
+
+ (pass-if "rpsubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a =)
+ (equal? a (make-array #t 5))))
+
+ (pass-if "asubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a +)
+ (equal? a (make-array 0 5))))
+
+ ;; in Guile 1.6.4 and earlier this resulted in a segv
+ (pass-if "noop"
+ (array-map! (make-array #f 5) noop)
+ #t))
+
+ (with-test-prefix "one source"
+
+ (pass-if-exception "closure 0" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda () #f)
+ (make-array #f 5)))
+
+ (pass-if "closure 1"
+ (let ((a (make-array #f 5)))
+ (array-map! a (lambda (x) 'foo) (make-array #f 5))
+ (equal? a (make-array 'foo 5))))
+
+ (pass-if-exception "closure 2" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x y) #f)
+ (make-array #f 5)))
+
+ (pass-if "subr_1"
+ (let ((a (make-array #f 5)))
+ (array-map! a length (make-array '(x y z) 5))
+ (equal? a (make-array 3 5))))
+
+ (pass-if-exception "subr_2" exception:wrong-num-args
+ (array-map! (make-array #f 5) logtest
+ (make-array 999 5)))
+
+ (pass-if "subr_2o"
+ (let ((a (make-array #f 5)))
+ (array-map! a number->string (make-array 99 5))
+ (equal? a (make-array "99" 5))))
+
+ (pass-if "dsubr"
+ (let ((a (make-array #f 5)))
+ (array-map! a sqrt (make-array 16.0 5))
+ (equal? a (make-array 4.0 5))))
+
+ (pass-if "rpsubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a = (make-array 0 5))
+ (equal? a (make-array #t 5))))
+
+ (pass-if "asubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a - (make-array 99 5))
+ (equal? a (make-array -99 5))))
+
+ ;; in Guile 1.6.5 and 1.6.6 this was an error
+ (pass-if "1+"
+ (let ((a (make-array #f 5)))
+ (array-map! a 1+ (make-array 123 5))
+ (equal? a (make-array 124 5))))
+
+ (pass-if "rank 0"
+ (let ((a #0(99))
+ (b (make-array 0)))
+ (array-map! b values a)
+ (equal? b #0(99))))
+
+ (pass-if "rank 2, discontinuous"
+ (let ((A #2((0 1) (2 3) (4 5)))
+ (B #2((10 11) (12 13) (14 15)))
+ (C #2((20) (21) (22)))
+ (X (make-array 0 3 5))
+ (piece (lambda (X w s)
+ (make-shared-array
+ X (lambda (i j) (list i (+ j s))) 3 w))))
+ (array-map! (piece X 2 0) values A)
+ (array-map! (piece X 2 2) values B)
+ (array-map! (piece X 1 4) values C)
+ (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
+
+ (pass-if "null increments, not empty"
+ (let ((a (make-array 0 2 2)))
+ (array-map! a values (make-shared-array #0(1) (lambda x '()) 2 2))
+ (array-equal? a #2((1 1) (1 1))))))
+
+ (with-test-prefix "two sources"
+
+ (pass-if-exception "closure 0" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda () #f)
+ (make-array #f 5) (make-array #f 5)))
+
+ (pass-if-exception "closure 1" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x) #f)
+ (make-array #f 5) (make-array #f 5)))
+
+ (pass-if "closure 2"
+ (let ((a (make-array #f 5)))
+ (array-map! a (lambda (x y) 'foo)
+ (make-array #f 5) (make-array #f 5))
+ (equal? a (make-array 'foo 5))))
+
+ (pass-if-exception "subr_1" exception:wrong-num-args
+ (array-map! (make-array #f 5) length
+ (make-array #f 5) (make-array #f 5)))
+
+ (pass-if "subr_2"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a logtest
+ (make-array 999 5) (make-array 999 5))
+ (equal? a (make-array #t 5))))
+
+ (pass-if "subr_2o"
+ (let ((a (make-array #f 5)))
+ (array-map! a number->string
+ (make-array 32 5) (make-array 16 5))
+ (equal? a (make-array "20" 5))))
+
+ (pass-if-exception "dsubr" exception:wrong-num-args
+ (let ((a (make-array #f 5)))
+ (array-map! a sqrt
+ (make-array 16.0 5) (make-array 16.0 5))
+ (equal? a (make-array 4.0 5))))
+
+ (pass-if "rpsubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a = (make-array 99 5) (make-array 77 5))
+ (equal? a (make-array #f 5))))
+
+ (pass-if "asubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a - (make-array 99 5) (make-array 11 5))
+ (equal? a (make-array 88 5))))
+
+ (pass-if "+"
+ (let ((a (make-array #f 4)))
+ (array-map! a + #(1 2 3 4) #(5 6 7 8))
+ (equal? a #(6 8 10 12))))
+
+ (pass-if "noncompact arrays 1"
+ (let ((a #2((0 1) (2 3)))
+ (c (make-array 0 2)))
+ (begin
+ (array-map! c + (array-row a 1) (array-row a 1))
+ (array-equal? c #(4 6)))))
+
+ (pass-if "noncompact arrays 2"
+ (let ((a #2((0 1) (2 3)))
+ (c (make-array 0 2)))
+ (begin
+ (array-map! c + (array-col a 1) (array-col a 1))
+ (array-equal? c #(2 6)))))
+
+ (pass-if "noncompact arrays 3"
+ (let ((a #2((0 1) (2 3)))
+ (c (make-array 0 2)))
+ (begin
+ (array-map! c + (array-col a 1) (array-row a 1))
+ (array-equal? c #(3 6)))))
+
+ (pass-if "noncompact arrays 4"
+ (let ((a #2((0 1) (2 3)))
+ (c (make-array 0 2)))
+ (begin
+ (array-map! c + (array-col a 1) (array-row a 1))
+ (array-equal? c #(3 6)))))
+
+ (pass-if "offset arrays 1"
+ (let ((a #2@1@-3((0 1) (2 3)))
+ (c (make-array 0 '(1 2) '(-3 -2))))
+ (begin
+ (array-map! c + a a)
+ (array-equal? c #2@1@-3((0 2) (4 6)))))))
+
+ ;; note that array-copy! has the opposite behavior.
+
+ (pass-if-exception "matching behavior I" exception:shape-mismatch
+ (let ((a #(1 2))
+ (b (make-array 0 3)))
+ (array-map! b values a)
+ (equal? b #(1 2 0))))
+
+ (pass-if "matching behavior II"
+ (let ((a #(1 2 3))
+ (b (make-array 0 2)))
+ (array-map! b values a)
+ (equal? b #(1 2))))
+
+ ;; here both a & b are are unrollable down to the first axis, but the
+ ;; size mismatch limits unrolling to the last axis only.
+
+ (pass-if "matching behavior III"
+ (let ((a #3(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12))))
+ (b (make-array 0 2 2 2)))
+ (array-map! b values a)
+ (array-equal? b #3(((1 2) (3 4)) ((7 8) (9 10)))))))
+
+;;;
+;;; array-for-each
+;;;
+
+(with-test-prefix "array-for-each"
+
+ (with-test-prefix "1 source"
+ (pass-if-equal "rank 0"
+ '(99)
+ (let* ((a #0(99))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
+ (pass-if-equal "noncompact array"
+ '(3 2 1 0)
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
+ (pass-if-equal "vector"
+ '(3 2 1 0)
+ (let* ((a #(0 1 2 3))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
+ (pass-if-equal "shared array"
+ '(3 2 1 0)
+ (let* ((a #2((0 1) (2 3)))
+ (a' (make-shared-array a
+ (lambda (x)
+ (list (quotient x 4)
+ (modulo x 4)))
+ 4))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a')
+ l)))
+
+ (with-test-prefix "3 sources"
+ (pass-if-equal "noncompact arrays 1"
+ '((3 1 3) (2 0 2))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1))
+ l))
+
+ (pass-if-equal "noncompact arrays 2"
+ '((3 3 3) (2 2 1))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
+ l))
+
+ (pass-if-equal "noncompact arrays 3"
+ '((3 3 3) (2 1 1))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
+ l))
+
+ (pass-if-equal "noncompact arrays 4"
+ '((3 2 3) (1 0 2))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
+ l)))
+
+ (with-test-prefix "empty arrays"
+
+ (pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
+ (let* ((a (list))
+ (b (make-array 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-for-each (lambda (c) (set! a (cons c a))) c)
+ (equal? a '())))
+
+ (pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
+ (let* ((a (list))
+ (b (make-typed-array 'f64 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-for-each (lambda (c) (set! a (cons c a))) c)
+ (equal? a '())))
+
+ ;; FIXME add type 'b cases.
+
+ (pass-if-exception "empty arrays shape check" exception:shape-mismatch
+ (let* ((a (list))
+ (b (make-typed-array 'f64 0 0 2))
+ (c (make-typed-array 'f64 0 2 0)))
+ (array-for-each (lambda (b c) (set! a (cons* b c a))) b c)))))
+
+;;;
+;;; array-for-each-cell
+;;;
+
+(with-test-prefix "array-for-each-cell"
+
+ (pass-if-equal "1 argument frame rank 1"
+ #2((1 3 9) (2 7 8))
+ (let* ((a (list->array 2 '((9 1 3) (7 8 2)))))
+ (array-for-each-cell 1 (lambda (a) (sort! a <)) a)
+ a))
+
+ (pass-if-equal "2 arguments frame rank 1"
+ #f64(8 -1)
+ (let* ((x (list->typed-array 'f64 2 '((9 1) (7 8))))
+ (y (f64vector 99 99)))
+ (array-for-each-cell 1 (lambda (y x) (array-set! y (- (array-ref x 0) (array-ref x 1)))) y x)
+ y))
+
+ (pass-if-equal "regression: zero-sized frame loop without unrolling"
+ 99
+ (let* ((x 99)
+ (o (make-array 0. 0 3 2)))
+ (array-for-each-cell 2
+ (lambda (o a0 a1)
+ (set! x 0))
+ o
+ (make-shared-array (make-array 1. 0 1) (const '(0 0)) 0 3)
+ (make-array 2. 0 3))
+ x)))
diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
deleted file mode 100644
index bd8a434..0000000
--- a/test-suite/tests/ramap.test
+++ /dev/null
@@ -1,509 +0,0 @@
-;;;; ramap.test --- test array mapping functions -*- scheme -*-
-;;;;
-;;;; Copyright (C) 2004, 2005, 2006, 2009, 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
-
-(define-module (test-suite test-ramap)
- #:use-module (test-suite lib))
-
-(define exception:shape-mismatch
- (cons 'misc-error ".*shape mismatch.*"))
-
-(define (array-row a i)
- (make-shared-array a (lambda (j) (list i j))
- (cadr (array-dimensions a))))
-
-(define (array-col a j)
- (make-shared-array a (lambda (i) (list i j))
- (car (array-dimensions a))))
-
-;;;
-;;; array-index-map!
-;;;
-
-(with-test-prefix "array-index-map!"
-
- (pass-if "basic test"
- (let ((nlst '()))
- (array-index-map! (make-array #f '(1 1))
- (lambda (n)
- (set! nlst (cons n nlst))))
- (equal? nlst '(1))))
-
- (with-test-prefix "empty arrays"
-
- (pass-if "all axes empty"
- (array-index-map! (make-typed-array 'f64 0 0 0) (const 0))
- (array-index-map! (make-typed-array 'b #t 0 0) (const #t))
- (array-index-map! (make-typed-array #t 0 0 0) (const 0))
- #t)
-
- (pass-if "last axis empty"
- (array-index-map! (make-typed-array 'f64 0 2 0) (const 0))
- (array-index-map! (make-typed-array 'b #t 2 0) (const #t))
- (array-index-map! (make-typed-array #t 0 2 0) (const 0))
- #t)
-
- ; the 'f64 cases fail in 2.0.9 with out-of-range.
- (pass-if "axis empty, other than last"
- (array-index-map! (make-typed-array 'f64 0 0 2) (const 0))
- (array-index-map! (make-typed-array 'b #t 0 2) (const #t))
- (array-index-map! (make-typed-array #t 0 0 2) (const 0))
- #t))
-
- (pass-if "rank 2"
- (let ((a (make-array 0 2 2))
- (b (make-array 0 2 2)))
- (array-index-map! a (lambda (i j) i))
- (array-index-map! b (lambda (i j) j))
- (and (array-equal? a #2((0 0) (1 1)))
- (array-equal? b #2((0 1) (0 1)))))))
-
-;;;
-;;; array-copy!
-;;;
-
-(with-test-prefix "array-copy!"
-
- (with-test-prefix "empty arrays"
-
- (pass-if "empty other than last, #t"
- (let* ((b (make-array 0 2 2))
- (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
- (array-copy! #2:0:2() c)
- (array-equal? #2:0:2() c)))
-
- (pass-if "empty other than last, 'f64"
- (let* ((b (make-typed-array 'f64 0 2 2))
- (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
- (array-copy! #2:0:2() c)
- (array-equal? #2f64:0:2() c)))
-
- ;; FIXME add empty, type 'b cases.
-
- )
-
- ;; note that it is the opposite of array-map!. This is, unfortunately,
- ;; documented in the manual.
-
- (pass-if "matching behavior I"
- (let ((a #(1 2))
- (b (make-array 0 3)))
- (array-copy! a b)
- (equal? b #(1 2 0))))
-
- (pass-if-exception "matching behavior II" exception:shape-mismatch
- (let ((a #(1 2 3))
- (b (make-array 0 2)))
- (array-copy! a b)
- (equal? b #(1 2))))
-
- ;; here both a & b are are unrollable down to the first axis, but the
- ;; size mismatch limits unrolling to the last axis only.
-
- (pass-if "matching behavior III"
- (let ((a #3(((1 2) (3 4)) ((5 6) (7 8))))
- (b (make-array 0 2 3 2)))
- (array-copy! a b)
- (array-equal? b #3(((1 2) (3 4) (0 0)) ((5 6) (7 8) (0 0))))))
-
- (pass-if "rank 0"
- (let ((a #0(99))
- (b (make-array 0)))
- (array-copy! a b)
- (equal? b #0(99))))
-
- (pass-if "rank 1"
- (let* ((a #2((1 2) (3 4)))
- (b (make-shared-array a (lambda (j) (list 1 j)) 2))
- (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
- (d (make-array 0 2))
- (e (make-array 0 2)))
- (array-copy! b d)
- (array-copy! c e)
- (and (equal? d #(3 4))
- (equal? e #(4 2)))))
-
- (pass-if "rank 2"
- (let ((a #2((1 2) (3 4)))
- (b (make-array 0 2 2))
- (c (make-array 0 2 2))
- (d (make-array 0 2 2))
- (e (make-array 0 2 2)))
- (array-copy! a b)
- (array-copy! a (transpose-array c 1 0))
- (array-copy! (transpose-array a 1 0) d)
- (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
- (and (equal? a #2((1 2) (3 4)))
- (equal? b #2((1 2) (3 4)))
- (equal? c #2((1 3) (2 4)))
- (equal? d #2((1 3) (2 4)))
- (equal? e #2((1 2) (3 4))))))
-
- (pass-if "rank 2, discontinuous"
- (let ((A #2((0 1) (2 3) (4 5)))
- (B #2((10 11) (12 13) (14 15)))
- (C #2((20) (21) (22)))
- (X (make-array 0 3 5))
- (piece (lambda (X w s)
- (make-shared-array
- X (lambda (i j) (list i (+ j s))) 3 w))))
- (array-copy! A (piece X 2 0))
- (array-copy! B (piece X 2 2))
- (array-copy! C (piece X 1 4))
- (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
-
- (pass-if "null increments, not empty"
- (let ((a (make-array 0 2 2)))
- (array-copy! (make-shared-array #0(1) (lambda x '()) 2 2) a)
- (array-equal? #2((1 1) (1 1))))))
-
-;;;
-;;; array-map!
-;;;
-
-(with-test-prefix "array-map!"
-
- (pass-if-exception "no args" exception:wrong-num-args
- (array-map!))
-
- (pass-if-exception "one arg" exception:wrong-num-args
- (array-map! (make-array #f 5)))
-
- (with-test-prefix "no sources"
-
- (pass-if "closure 0"
- (array-map! (make-array #f 5) (lambda () #f))
- #t)
-
- (pass-if-exception "closure 1" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda (x) #f)))
-
- (pass-if-exception "closure 2" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda (x y) #f)))
-
- (pass-if-exception "subr_1" exception:wrong-num-args
- (array-map! (make-array #f 5) length))
-
- (pass-if-exception "subr_2" exception:wrong-num-args
- (array-map! (make-array #f 5) logtest))
-
- (pass-if-exception "subr_2o" exception:wrong-num-args
- (array-map! (make-array #f 5) number->string))
-
- (pass-if-exception "dsubr" exception:wrong-num-args
- (array-map! (make-array #f 5) sqrt))
-
- (pass-if "rpsubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a =)
- (equal? a (make-array #t 5))))
-
- (pass-if "asubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a +)
- (equal? a (make-array 0 5))))
-
- ;; in Guile 1.6.4 and earlier this resulted in a segv
- (pass-if "noop"
- (array-map! (make-array #f 5) noop)
- #t))
-
- (with-test-prefix "one source"
-
- (pass-if-exception "closure 0" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda () #f)
- (make-array #f 5)))
-
- (pass-if "closure 1"
- (let ((a (make-array #f 5)))
- (array-map! a (lambda (x) 'foo) (make-array #f 5))
- (equal? a (make-array 'foo 5))))
-
- (pass-if-exception "closure 2" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda (x y) #f)
- (make-array #f 5)))
-
- (pass-if "subr_1"
- (let ((a (make-array #f 5)))
- (array-map! a length (make-array '(x y z) 5))
- (equal? a (make-array 3 5))))
-
- (pass-if-exception "subr_2" exception:wrong-num-args
- (array-map! (make-array #f 5) logtest
- (make-array 999 5)))
-
- (pass-if "subr_2o"
- (let ((a (make-array #f 5)))
- (array-map! a number->string (make-array 99 5))
- (equal? a (make-array "99" 5))))
-
- (pass-if "dsubr"
- (let ((a (make-array #f 5)))
- (array-map! a sqrt (make-array 16.0 5))
- (equal? a (make-array 4.0 5))))
-
- (pass-if "rpsubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a = (make-array 0 5))
- (equal? a (make-array #t 5))))
-
- (pass-if "asubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a - (make-array 99 5))
- (equal? a (make-array -99 5))))
-
- ;; in Guile 1.6.5 and 1.6.6 this was an error
- (pass-if "1+"
- (let ((a (make-array #f 5)))
- (array-map! a 1+ (make-array 123 5))
- (equal? a (make-array 124 5))))
-
- (pass-if "rank 0"
- (let ((a #0(99))
- (b (make-array 0)))
- (array-map! b values a)
- (equal? b #0(99))))
-
- (pass-if "rank 2, discontinuous"
- (let ((A #2((0 1) (2 3) (4 5)))
- (B #2((10 11) (12 13) (14 15)))
- (C #2((20) (21) (22)))
- (X (make-array 0 3 5))
- (piece (lambda (X w s)
- (make-shared-array
- X (lambda (i j) (list i (+ j s))) 3 w))))
- (array-map! (piece X 2 0) values A)
- (array-map! (piece X 2 2) values B)
- (array-map! (piece X 1 4) values C)
- (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
-
- (pass-if "null increments, not empty"
- (let ((a (make-array 0 2 2)))
- (array-map! a values (make-shared-array #0(1) (lambda x '()) 2 2))
- (array-equal? a #2((1 1) (1 1))))))
-
- (with-test-prefix "two sources"
-
- (pass-if-exception "closure 0" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda () #f)
- (make-array #f 5) (make-array #f 5)))
-
- (pass-if-exception "closure 1" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda (x) #f)
- (make-array #f 5) (make-array #f 5)))
-
- (pass-if "closure 2"
- (let ((a (make-array #f 5)))
- (array-map! a (lambda (x y) 'foo)
- (make-array #f 5) (make-array #f 5))
- (equal? a (make-array 'foo 5))))
-
- (pass-if-exception "subr_1" exception:wrong-num-args
- (array-map! (make-array #f 5) length
- (make-array #f 5) (make-array #f 5)))
-
- (pass-if "subr_2"
- (let ((a (make-array 'foo 5)))
- (array-map! a logtest
- (make-array 999 5) (make-array 999 5))
- (equal? a (make-array #t 5))))
-
- (pass-if "subr_2o"
- (let ((a (make-array #f 5)))
- (array-map! a number->string
- (make-array 32 5) (make-array 16 5))
- (equal? a (make-array "20" 5))))
-
- (pass-if-exception "dsubr" exception:wrong-num-args
- (let ((a (make-array #f 5)))
- (array-map! a sqrt
- (make-array 16.0 5) (make-array 16.0 5))
- (equal? a (make-array 4.0 5))))
-
- (pass-if "rpsubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a = (make-array 99 5) (make-array 77 5))
- (equal? a (make-array #f 5))))
-
- (pass-if "asubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a - (make-array 99 5) (make-array 11 5))
- (equal? a (make-array 88 5))))
-
- (pass-if "+"
- (let ((a (make-array #f 4)))
- (array-map! a + #(1 2 3 4) #(5 6 7 8))
- (equal? a #(6 8 10 12))))
-
- (pass-if "noncompact arrays 1"
- (let ((a #2((0 1) (2 3)))
- (c (make-array 0 2)))
- (begin
- (array-map! c + (array-row a 1) (array-row a 1))
- (array-equal? c #(4 6)))))
-
- (pass-if "noncompact arrays 2"
- (let ((a #2((0 1) (2 3)))
- (c (make-array 0 2)))
- (begin
- (array-map! c + (array-col a 1) (array-col a 1))
- (array-equal? c #(2 6)))))
-
- (pass-if "noncompact arrays 3"
- (let ((a #2((0 1) (2 3)))
- (c (make-array 0 2)))
- (begin
- (array-map! c + (array-col a 1) (array-row a 1))
- (array-equal? c #(3 6)))))
-
- (pass-if "noncompact arrays 4"
- (let ((a #2((0 1) (2 3)))
- (c (make-array 0 2)))
- (begin
- (array-map! c + (array-col a 1) (array-row a 1))
- (array-equal? c #(3 6)))))
-
- (pass-if "offset arrays 1"
- (let ((a #2@1@-3((0 1) (2 3)))
- (c (make-array 0 '(1 2) '(-3 -2))))
- (begin
- (array-map! c + a a)
- (array-equal? c #2@1@-3((0 2) (4 6)))))))
-
- ;; note that array-copy! has the opposite behavior.
-
- (pass-if-exception "matching behavior I" exception:shape-mismatch
- (let ((a #(1 2))
- (b (make-array 0 3)))
- (array-map! b values a)
- (equal? b #(1 2 0))))
-
- (pass-if "matching behavior II"
- (let ((a #(1 2 3))
- (b (make-array 0 2)))
- (array-map! b values a)
- (equal? b #(1 2))))
-
- ;; here both a & b are are unrollable down to the first axis, but the
- ;; size mismatch limits unrolling to the last axis only.
-
- (pass-if "matching behavior III"
- (let ((a #3(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12))))
- (b (make-array 0 2 2 2)))
- (array-map! b values a)
- (array-equal? b #3(((1 2) (3 4)) ((7 8) (9 10)))))))
-
-;;;
-;;; array-for-each
-;;;
-
-(with-test-prefix "array-for-each"
-
- (with-test-prefix "1 source"
- (pass-if-equal "rank 0"
- '(99)
- (let* ((a #0(99))
- (l '())
- (p (lambda (x) (set! l (cons x l)))))
- (array-for-each p a)
- l))
-
- (pass-if-equal "noncompact array"
- '(3 2 1 0)
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (p (lambda (x) (set! l (cons x l)))))
- (array-for-each p a)
- l))
-
- (pass-if-equal "vector"
- '(3 2 1 0)
- (let* ((a #(0 1 2 3))
- (l '())
- (p (lambda (x) (set! l (cons x l)))))
- (array-for-each p a)
- l))
-
- (pass-if-equal "shared array"
- '(3 2 1 0)
- (let* ((a #2((0 1) (2 3)))
- (a' (make-shared-array a
- (lambda (x)
- (list (quotient x 4)
- (modulo x 4)))
- 4))
- (l '())
- (p (lambda (x) (set! l (cons x l)))))
- (array-for-each p a')
- l)))
-
- (with-test-prefix "3 sources"
- (pass-if-equal "noncompact arrays 1"
- '((3 1 3) (2 0 2))
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1))
- l))
-
- (pass-if-equal "noncompact arrays 2"
- '((3 3 3) (2 2 1))
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
- l))
-
- (pass-if-equal "noncompact arrays 3"
- '((3 3 3) (2 1 1))
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
- l))
-
- (pass-if-equal "noncompact arrays 4"
- '((3 2 3) (1 0 2))
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
- l)))
-
- (with-test-prefix "empty arrays"
-
- (pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
- (let* ((a (list))
- (b (make-array 0 2 2))
- (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
- (array-for-each (lambda (c) (set! a (cons c a))) c)
- (equal? a '())))
-
- (pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
- (let* ((a (list))
- (b (make-typed-array 'f64 0 2 2))
- (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
- (array-for-each (lambda (c) (set! a (cons c a))) c)
- (equal? a '())))
-
- ;; FIXME add type 'b cases.
-
- (pass-if-exception "empty arrays shape check" exception:shape-mismatch
- (let* ((a (list))
- (b (make-typed-array 'f64 0 0 2))
- (c (make-typed-array 'f64 0 2 0)))
- (array-for-each (lambda (b c) (set! a (cons* b c a))) b c)))))
--
2.7.3
^ permalink raw reply related [flat|nested] 16+ messages in thread
* Re: Patchset related to array functions
2016-07-12 17:16 ` Daniel Llorens
@ 2016-07-14 9:46 ` Andy Wingo
2016-07-14 15:41 ` [PATCH] " Daniel Llorens
2016-07-15 17:41 ` Mark H Weaver
0 siblings, 2 replies; 16+ messages in thread
From: Andy Wingo @ 2016-07-14 9:46 UTC (permalink / raw)
To: Daniel Llorens; +Cc: guile-devel
Thanks for the update.
On Tue 12 Jul 2016 19:16, Daniel Llorens <daniel.llorens@bluewin.ch> writes:
> Subject: [PATCH 01/12] Compile in C99 mode
This could be a good change but it is not the fastest path to patch
review :) There are three considerations here:
(1) Can we support C99 on all targets we care about?
(2) Can we use C99 in our public interface, or just internally? If we
use it publically, what should we change? No more scm_t_uint8 I
hope, besides for back-compat? This patch set does not have to
include these changes, but we should have a plan.
(3) Most importantly, what is the impact on inlining? See the comment
in __scm.h around line 165.
If you want your patch set to depend on C99 that's fine, but you have to
answer these questions first for the project as a whole and get some
consensus.
Andy
^ permalink raw reply [flat|nested] 16+ messages in thread
* [PATCH] Re: Patchset related to array functions
2016-07-14 9:46 ` Andy Wingo
@ 2016-07-14 15:41 ` Daniel Llorens
2016-07-14 18:20 ` Andy Wingo
2016-07-15 10:52 ` Chris Vine
2016-07-15 17:41 ` Mark H Weaver
1 sibling, 2 replies; 16+ messages in thread
From: Daniel Llorens @ 2016-07-14 15:41 UTC (permalink / raw)
To: Andy Wingo; +Cc: guile-devel
[-- Attachment #1: Type: text/plain, Size: 2352 bytes --]
On 14 Jul 2016, at 11:46, Andy Wingo <wingo@pobox.com> wrote:
> Thanks for the update.
>
> On Tue 12 Jul 2016 19:16, Daniel Llorens <daniel.llorens@bluewin.ch> writes:
>
>> Subject: [PATCH 01/12] Compile in C99 mode
>
> This could be a good change but it is not the fastest path to patch
> review :) There are three considerations here:
>
> (1) Can we support C99 on all targets we care about?
The manual doesn't seem to list which platforms we support, or I can't find it. I know that bugs are reported on the list occasionally for Solaris etc. which I guess counts as exotic nowadays.
The wiki mentions GNU, GNU/Linux, BSD, MinGW and Cygwin. All those systems have C99 compilers. Apparently the list of supported platforms for Emacs (future versions at least) is the same, plus a few proprietary Unixes all of which I assume have C99 compilers (plus gcc runs in all of them).
> (2) Can we use C99 in our public interface, or just internally? If we
> use it publically, what should we change? No more scm_t_uint8 I
> hope, besides for back-compat? This patch set does not have to
> include these changes, but we should have a plan.
I think we'd want C89/C90 users to still be able to #include <libguile.h>. Dunno.
> (3) Most importantly, what is the impact on inlining? See the comment
> in __scm.h around line 165.
Apparently the standard practice in C99 is to put inline definition in the header and extern declaration in the .c, while with ‘Guile inline’ both SCM_INLINE and SCM_INLINE_IMPLEMENTATION are in the header. I can try to fix Guile to follow the C99 practice and remove most of the #define guards. Would a patch doing this be accepted? I'd welcome advice on how to test such a patch. E.g. with both -O2 and -O0 or so. I'm mostly a C++ programmer and I don't want to mess anything up.
The source has a lot of guarding against the compiler landscape of the 90s that might not be necessary today.
> If you want your patch set to depend on C99 that's fine, but you have to
> answer these questions first for the project as a whole and get some
> consensus.
That is a very reasonable viewpoint. Since C99 was just a minor convenience to me, I withdraw that particular patch. I have rebased everything to avoid the C99 requirement. Revised patchset attached.
[-- Attachment #2: 0001-Fix-compilation-of-rank-0-typed-array-literals.patch --]
[-- Type: application/octet-stream, Size: 1768 bytes --]
From e657d1f11aad8a9d37eec5ac13007bfcc88300fe Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Thu, 12 Feb 2015 13:02:24 +0100
Subject: [PATCH 01/11] Fix compilation of rank 0 typed array literals
* module/system/vm/assembler.scm (simple-uniform-vector?): array-length
fails for rank 0 arrays; fix the shape condition.
* test-suite/tests/arrays.test: Test reading of #0f64(x) in compilation
context.
---
module/system/vm/assembler.scm | 4 +++-
test-suite/tests/arrays.test | 8 +++++++-
2 files changed, 10 insertions(+), 2 deletions(-)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 20a652c..f6b3caa 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -995,7 +995,9 @@ immediate, and @code{#f} otherwise."
(define (simple-uniform-vector? obj)
(and (array? obj)
(symbol? (array-type obj))
- (equal? (array-shape obj) (list (list 0 (1- (array-length obj)))))))
+ (match (array-shape obj)
+ (((0 n)) #t)
+ (else #f))))
(define (statically-allocatable? x)
"Return @code{#t} if a non-immediate constant can be allocated
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index e76c699..20cb78b 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -204,7 +204,13 @@
(with-test-prefix/c&e "array-equal?"
(pass-if "#s16(...)"
- (array-equal? #s16(1 2 3) #s16(1 2 3))))
+ (array-equal? #s16(1 2 3) #s16(1 2 3)))
+
+ (pass-if "#0f64(...)"
+ (array-equal? #0f64(99) (make-typed-array 'f64 99)))
+
+ (pass-if "#0(...)"
+ (array-equal? #0(99) (make-array 99))))
;;;
;;; make-shared-array
--
2.7.3
[-- Attachment #3: 0002-Remove-scm_from_contiguous_array-array-contiguous-fl.patch --]
[-- Type: application/octet-stream, Size: 8747 bytes --]
From 56deb6ae1da4edd28a461fd2a01bf682391dfb62 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Mon, 9 Feb 2015 17:27:33 +0100
Subject: [PATCH 02/11] Remove scm_from_contiguous_array, array 'contiguous'
flag
scm_from_contiguous_array() is undocumented, unused within Guile, and
can be trivially replaced by make-array + array-copy without requiring
contiguity.
The related SCM_I_ARRAY_FLAG_CONTIGUOUS (arrays.h) was set by all
array-creating functions (make-typed-array, transpose-array,
make-shared-array) but it was only used by array-contents, which needed
to traverse the dimensions anyway.
* libguile/arrays.h (scm_from_contiguous_array): Remove declaration.
* libguile/arrays.c (scm_from_contiguous_array): Remove.
(scm_make_typed_array, scm_from_contiguous_typed_array): Don't set the
contiguous flag.
(scm_transpose_array, scm_make_shared_array): Don't call
scm_i_ra_set_contp.
(scm_array_contents): Inline scm_i_ra_set_contp() here. Adopt uniform
type check order. Remove redundant comments.
(scm_i_ra_set_contp): Remove.
* test-suite/tests/arrays.test: Test array-contents with rank 0 array.
---
libguile/arrays.c | 112 +++++++++++--------------------------------
libguile/arrays.h | 4 +-
test-suite/tests/arrays.test | 6 +++
3 files changed, 36 insertions(+), 86 deletions(-)
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 52fe90a..3cb547f 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -188,7 +188,6 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
SCM ra;
ra = scm_i_shap2ra (bounds);
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
s = SCM_I_ARRAY_DIMS (ra);
k = SCM_I_ARRAY_NDIM (ra);
@@ -225,7 +224,6 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
size_t sz;
ra = scm_i_shap2ra (bounds);
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
s = SCM_I_ARRAY_DIMS (ra);
k = SCM_I_ARRAY_NDIM (ra);
@@ -270,41 +268,6 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
}
#undef FUNC_NAME
-SCM
-scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len)
-#define FUNC_NAME "scm_from_contiguous_array"
-{
- size_t k, rlen = 1;
- scm_t_array_dim *s;
- SCM ra;
- scm_t_array_handle h;
-
- ra = scm_i_shap2ra (bounds);
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
- s = SCM_I_ARRAY_DIMS (ra);
- k = SCM_I_ARRAY_NDIM (ra);
-
- while (k--)
- {
- s[k].inc = rlen;
- SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
- rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
- }
- if (rlen != len)
- SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL);
-
- SCM_I_ARRAY_SET_V (ra, scm_c_make_vector (rlen, SCM_UNDEFINED));
- scm_array_get_handle (ra, &h);
- memcpy (h.writable_elements, elts, rlen * sizeof(SCM));
- scm_array_handle_release (&h);
-
- if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
- if (0 == s->lbnd)
- return SCM_I_ARRAY_V (ra);
- return ra;
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
(SCM fill, SCM bounds),
"Create and return an array.")
@@ -314,27 +277,6 @@ SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
}
#undef FUNC_NAME
-static void
-scm_i_ra_set_contp (SCM ra)
-{
- size_t k = SCM_I_ARRAY_NDIM (ra);
- if (k)
- {
- ssize_t inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc;
- while (k--)
- {
- if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc)
- {
- SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
- return;
- }
- inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
- - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
- }
- }
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
-}
-
SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
(SCM oldra, SCM mapfunc, SCM dims),
@@ -448,7 +390,6 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0,
SCM_UNDEFINED);
}
- scm_i_ra_set_contp (ra);
return ra;
}
#undef FUNC_NAME
@@ -547,16 +488,12 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
}
if (ndim > 0)
SCM_MISC_ERROR ("bad argument list", SCM_EOL);
- scm_i_ra_set_contp (res);
return res;
}
}
#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 true, return #f if returned array
- wouldn't have contiguous elements. */
+
SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
(SCM ra, SCM strict),
"If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n"
@@ -566,31 +503,38 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
"@code{make-array} and @code{make-uniform-array} may be unrolled,\n"
"some arrays made by @code{make-shared-array} may not be. If\n"
"the optional argument @var{strict} is provided, a shared array\n"
- "will be returned only if its elements are stored internally\n"
- "contiguous in memory.")
+ "will be returned only if its elements are stored contiguously\n"
+ "in memory.")
#define FUNC_NAME s_scm_array_contents
{
- if (!scm_is_array (ra))
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
- else if (SCM_I_ARRAYP (ra))
+ if (SCM_I_ARRAYP (ra))
{
SCM v;
- size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
- if (!SCM_I_ARRAY_CONTP (ra))
- return SCM_BOOL_F;
- for (k = 0; k < ndim; k++)
- len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
+ size_t ndim = SCM_I_ARRAY_NDIM (ra);
+ scm_t_array_dim *s = SCM_I_ARRAY_DIMS (ra);
+ size_t k = ndim;
+ size_t len = 1;
+
+ if (k)
+ {
+ ssize_t last_inc = s[k - 1].inc;
+ while (k--)
+ {
+ if (len*last_inc != s[k].inc)
+ return SCM_BOOL_F;
+ len *= (s[k].ubnd - s[k].lbnd + 1);
+ }
+ }
+
if (!SCM_UNBNDP (strict) && scm_is_true (strict))
{
- if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc))
+ if (ndim && (1 != s[ndim - 1].inc))
return SCM_BOOL_F;
- if (scm_is_bitvector (SCM_I_ARRAY_V (ra)))
- {
- if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
- SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
- len % SCM_LONG_BIT)
- return SCM_BOOL_F;
- }
+ if (scm_is_bitvector (SCM_I_ARRAY_V (ra))
+ && (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
+ SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
+ len % SCM_LONG_BIT))
+ return SCM_BOOL_F;
}
v = SCM_I_ARRAY_V (ra);
@@ -607,8 +551,10 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
return sra;
}
}
- else
+ else if (scm_is_array (ra))
return ra;
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
}
#undef FUNC_NAME
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 5f40597..4baa51e 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -37,8 +37,6 @@
/** Arrays */
SCM_API SCM scm_make_array (SCM fill, SCM bounds);
-SCM_API SCM scm_from_contiguous_array (SCM bounds, const SCM *elts,
- size_t len);
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,
@@ -54,7 +52,7 @@ SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);
/* internal. */
-#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0)
+#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0) /* currently unused */
#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc7_array, a)
#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x)>>17))
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 20cb78b..6f37196 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -294,6 +294,12 @@
(with-test-prefix/c&e "array-contents"
+ (pass-if "0-rank array"
+ (let ((a (make-vector 1 77)))
+ (and
+ (eq? a (array-contents (make-shared-array a (const '(0)))))
+ (eq? a (array-contents (make-shared-array a (const '(0))) #t)))))
+
(pass-if "simple vector"
(let* ((a (make-array 0 4)))
(eq? a (array-contents a))))
--
2.7.3
[-- Attachment #4: 0003-Avoid-unneeded-internal-use-of-array-handles.patch --]
[-- Type: application/octet-stream, Size: 9393 bytes --]
From 2d00cf1571d4f82f5945df266732b6046858a849 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Mon, 9 Feb 2015 12:11:52 +0100
Subject: [PATCH 03/11] Avoid unneeded internal use of array handles
* libguile/arrays.c (scm_shared_array_root): Adopt uniform check order.
(scm_shared_array_offset, scm_shared_array_increments): Use the array
fields directly just as scm_shared_array_root does.
(scm_c_array_rank): Moved from libguile/generalized-arrays.c. Don't
use array handles, but follow the same type check sequence as the
other array functions (shared-array-root, etc).
(scm_array_rank): Moved from libguile/generalized-arrays.h.
* libguile/arrays.h: Move prototypes here.
* test-suite/tests/arrays.test: Tests for shared-array-offset,
shared-array-increments.
---
libguile/arrays.c | 65 +++++++++++++++++++++++-------------
libguile/arrays.h | 3 ++
libguile/generalized-arrays.c | 21 ------------
libguile/generalized-arrays.h | 3 --
test-suite/tests/arrays.test | 76 +++++++++++++++++++++++++++++++++++--------
5 files changed, 109 insertions(+), 59 deletions(-)
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 3cb547f..fb522e1 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -64,6 +64,27 @@
(SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
+size_t
+scm_c_array_rank (SCM array)
+{
+ if (SCM_I_ARRAYP (array))
+ return SCM_I_ARRAY_NDIM (array);
+ else if (scm_is_array (array))
+ return 1;
+ else
+ scm_wrong_type_arg_msg ("array-rank", SCM_ARG1, array, "array");
+}
+
+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_shared_array_root, "shared-array-root", 1, 0, 0,
(SCM ra),
"Return the root vector of a shared array.")
@@ -71,10 +92,10 @@ SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
{
if (SCM_I_ARRAYP (ra))
return SCM_I_ARRAY_V (ra);
- else if (!scm_is_array (ra))
- scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
- else
+ else if (scm_is_array (ra))
return ra;
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME
@@ -84,13 +105,12 @@ SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
"Return the root vector index of the first element in the array.")
#define FUNC_NAME s_scm_shared_array_offset
{
- scm_t_array_handle handle;
- SCM res;
-
- scm_array_get_handle (ra, &handle);
- res = scm_from_size_t (handle.base);
- scm_array_handle_release (&handle);
- return res;
+ if (SCM_I_ARRAYP (ra))
+ return scm_from_size_t (SCM_I_ARRAY_BASE (ra));
+ else if (scm_is_array (ra))
+ return scm_from_size_t (0);
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME
@@ -100,18 +120,19 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
"For each dimension, return the distance between elements in the root vector.")
#define FUNC_NAME s_scm_shared_array_increments
{
- scm_t_array_handle handle;
- SCM res = SCM_EOL;
- size_t k;
- scm_t_array_dim *s;
-
- scm_array_get_handle (ra, &handle);
- k = scm_array_handle_rank (&handle);
- s = scm_array_handle_dims (&handle);
- while (k--)
- res = scm_cons (scm_from_ssize_t (s[k].inc), res);
- scm_array_handle_release (&handle);
- return res;
+ if (SCM_I_ARRAYP (ra))
+ {
+ size_t k = SCM_I_ARRAY_NDIM (ra);
+ SCM res = SCM_EOL;
+ scm_t_array_dim *dims = SCM_I_ARRAY_DIMS (ra);
+ while (k--)
+ res = scm_cons (scm_from_ssize_t (dims[k].inc), res);
+ return res;
+ }
+ else if (scm_is_array (ra))
+ return scm_list_1 (scm_from_ssize_t (1));
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 4baa51e..d3e409f 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -50,6 +50,9 @@ SCM_API SCM scm_array_contents (SCM ra, SCM strict);
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 size_t scm_c_array_rank (SCM ra);
+SCM_API SCM scm_array_rank (SCM ra);
+
/* internal. */
#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0) /* currently unused */
diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c
index 9a001eb..fdbdb4a 100644
--- a/libguile/generalized-arrays.c
+++ b/libguile/generalized-arrays.c
@@ -104,27 +104,6 @@ SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
}
#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)
diff --git a/libguile/generalized-arrays.h b/libguile/generalized-arrays.h
index dfdb8bd..cfa6905 100644
--- a/libguile/generalized-arrays.h
+++ b/libguile/generalized-arrays.h
@@ -41,9 +41,6 @@ SCM_INTERNAL SCM scm_array_p_2 (SCM);
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 size_t scm_c_array_length (SCM ra);
SCM_API SCM scm_array_length (SCM ra);
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 6f37196..c40457b 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -23,9 +23,13 @@
#:use-module (srfi srfi-4)
#:use-module (srfi srfi-4 gnu))
-;;;
-;;; array?
-;;;
+(define (array-row a i)
+ (make-shared-array a (lambda (j) (list i j))
+ (cadr (array-dimensions a))))
+
+(define (array-col a j)
+ (make-shared-array a (lambda (i) (list i j))
+ (car (array-dimensions a))))
(define exception:wrong-num-indices
(cons 'misc-error "^wrong number of indices.*"))
@@ -33,6 +37,15 @@
(define exception:length-non-negative
(cons 'read-error ".*array length must be non-negative.*"))
+(define exception:wrong-type-arg
+ (cons #t "Wrong type"))
+
+(define exception:mapping-out-of-range
+ (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
+
+;;;
+;;; array?
+;;;
(with-test-prefix "array?"
@@ -216,9 +229,6 @@
;;; make-shared-array
;;;
-(define exception:mapping-out-of-range
- (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
-
(with-test-prefix/c&e "make-shared-array"
;; this failed in guile 1.8.0
@@ -404,13 +414,57 @@
(eq? (shared-array-root a) (shared-array-root b) (array-contents a)))))
;;;
+;;; shared-array-offset
+;;;
+
+(with-test-prefix/c&e "shared-array-offset"
+
+ (pass-if "plain vector"
+ (zero? (shared-array-offset (make-vector 4 0))))
+
+ (pass-if "plain array rank 2"
+ (zero? (shared-array-offset (make-array 0 4 4))))
+
+ (pass-if "row of rank-2 array, I"
+ (= 0 (shared-array-offset (array-row (make-array 0 5 3) 0))))
+
+ (pass-if "row of rank-2 array, II"
+ (= 4 (shared-array-offset (array-row (make-array 0 6 4) 1))))
+
+ (pass-if "col of rank-2 array, I"
+ (= 0 (shared-array-offset (array-col (make-array 0 5 3) 0))))
+
+ (pass-if "col of rank-2 array, II"
+ (= 1 (shared-array-offset (array-col (make-array 0 6 4) 1)))))
+
+
+;;;
+;;; shared-array-increments
+;;;
+
+(with-test-prefix/c&e "shared-array-increments"
+
+ (pass-if "plain vector"
+ (equal? '(1) (shared-array-increments (make-vector 4 0))))
+
+ (pass-if "plain array rank 2"
+ (equal? '(4 1) (shared-array-increments (make-array 0 3 4))))
+
+ (pass-if "plain array rank 3"
+ (equal? '(20 5 1) (shared-array-increments (make-array 0 3 4 5))))
+
+ (pass-if "row of rank-2 array"
+ (equal? '(1) (shared-array-increments (array-row (make-array 0 5 3) 0))))
+
+ (pass-if "col of rank-2 array"
+ (equal? '(3) (shared-array-increments (array-col (make-array 0 5 3) 0)))))
+
+
+;;;
;;; transpose-array
;;;
; see strings.test.
-(define exception:wrong-type-arg
- (cons #t "Wrong type"))
-
(with-test-prefix/c&e "transpose-array"
(pass-if-exception "non array argument" exception:wrong-type-arg
@@ -821,10 +875,6 @@
;;; slices as generalized vectors
;;;
-(define (array-row a i)
- (make-shared-array a (lambda (j) (list i j))
- (cadr (array-dimensions a))))
-
(with-test-prefix/c&e "generalized vector slices"
(pass-if (equal? (array-row #2u32((0 1) (2 3)) 1)
#u32(2 3)))
--
2.7.3
[-- Attachment #5: 0004-Reuse-SCM_BYTEVECTOR_TYPED_LENGTH-in-scm_array_get_h.patch --]
[-- Type: application/octet-stream, Size: 2817 bytes --]
From a2583cc04f034df90a804740d178ab92ff6a0c02 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 11 Feb 2015 12:58:01 +0100
Subject: [PATCH 04/11] Reuse SCM_BYTEVECTOR_TYPED_LENGTH in
scm_array_get_handle
* libguile/bytevectors.h (SCM_BYTEVECTOR_TYPE_SIZE,
SCM_BYTEVECTOR_TYPED_LENGTH): Moved from libguile/bytevectors.c.
* libguile/array-handle.c (scm_array_get_handle): Reuse
SCM_BYTEVECTOR_TYPED_LENGTH.
---
libguile/array-handle.c | 6 ++----
libguile/bytevectors.c | 5 -----
libguile/bytevectors.h | 5 +++++
3 files changed, 7 insertions(+), 9 deletions(-)
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 2252ecc..3595266 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -185,15 +185,13 @@ scm_array_get_handle (SCM array, scm_t_array_handle *h)
break;
case scm_tc7_bytevector:
{
- size_t byte_length, length, element_byte_size;
+ size_t length;
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;
+ length = SCM_BYTEVECTOR_TYPED_LENGTH (array);
switch (element_type)
{
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index e426ae3..cf247dc 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -192,11 +192,6 @@
#define SCM_BYTEVECTOR_SET_PARENT(_bv, _parent) \
SCM_SET_CELL_OBJECT_3 ((_bv), (_parent))
-#define SCM_BYTEVECTOR_TYPE_SIZE(var) \
- (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
-#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \
- (SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var))
-
/* The empty bytevector. */
SCM scm_null_bytevector = SCM_UNSPECIFIED;
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
index a5eeaea..af4ac1c 100644
--- a/libguile/bytevectors.h
+++ b/libguile/bytevectors.h
@@ -129,6 +129,11 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM);
#define SCM_BYTEVECTOR_CONTIGUOUS_P(_bv) \
(SCM_BYTEVECTOR_FLAGS (_bv) >> 8UL)
+#define SCM_BYTEVECTOR_TYPE_SIZE(var) \
+ (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
+#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \
+ (SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var))
+
/* Hint that is passed to `scm_gc_malloc ()' and friends. */
#define SCM_GC_BYTEVECTOR "bytevector"
--
2.7.3
[-- Attachment #6: 0005-Remove-deprecated-array-functions.patch --]
[-- Type: application/octet-stream, Size: 12634 bytes --]
From 3248c26c6891cbcdc2cc89015d0afb9942b1383d Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Fri, 13 Feb 2015 16:45:21 +0100
Subject: [PATCH 05/11] Remove deprecated array functions
* libguile/array-map.c (scm_array_fill_int, scm_array_fill_int,
scm_ra_eqp, scm_ra_lessp scm_ra_leqp, scm_ra_grp, scm_ra_greqp,
scm_ra_sum, scm_ra_difference, scm_ra_product, scm_ra_divide,
scm_array_identity): Remove deprecated functions.
* libguile/array-map.h: Remove declaration of deprecated functions.
* libguile/generalized-vectors.h, libguile/generalized-vectors.c
(scm_is_generalized_vector, scm_c_generalized_vector_length,
scm_c_generalized_vector_ref, scm_c_generalized_vector_set_x): These
functions were deprecated in 2.0.9. Remove.
* doc/ref/api-compound.texi: Remove uniform-array-read!,
uniform-array-write from the manual. These procedures where removed in
fc7bd367ab4b5027a7f80686b1e229c62e43c90b (2011-05-12).
---
doc/ref/api-compound.texi | 33 ------
libguile/array-map.c | 261 -----------------------------------------
libguile/array-map.h | 16 ---
libguile/generalized-vectors.c | 31 -----
libguile/generalized-vectors.h | 4 -
5 files changed, 345 deletions(-)
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index b4ae79c..cc9eef4 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1568,39 +1568,6 @@ $\left(\matrix{%
@end example
@end deffn
-@deffn {Scheme Procedure} uniform-array-read! ra [port_or_fd [start [end]]]
-@deffnx {C Function} scm_uniform_array_read_x (ra, port_or_fd, start, end)
-Attempt to read all elements of array @var{ra}, in lexicographic order, as
-binary objects from @var{port_or_fd}.
-If an end of file is encountered,
-the objects up to that point are put into @var{ra}
-(starting at the beginning) and the remainder of the array is
-unchanged.
-
-The optional arguments @var{start} and @var{end} allow
-a specified region of a vector (or linearized array) to be read,
-leaving the remainder of the vector unchanged.
-
-@code{uniform-array-read!} returns the number of objects read.
-@var{port_or_fd} may be omitted, in which case it defaults to the value
-returned by @code{(current-input-port)}.
-@end deffn
-
-@deffn {Scheme Procedure} uniform-array-write ra [port_or_fd [start [end]]]
-@deffnx {C Function} scm_uniform_array_write (ra, port_or_fd, start, end)
-Writes all elements of @var{ra} as binary objects to
-@var{port_or_fd}.
-
-The optional arguments @var{start}
-and @var{end} allow
-a specified region of a vector (or linearized array) to be written.
-
-The number of objects actually written is returned.
-@var{port_or_fd} may be
-omitted, in which case it defaults to the value returned by
-@code{(current-output-port)}.
-@end deffn
-
@node Shared Arrays
@subsubsection Shared Arrays
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 938f0a7..587df02 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -307,267 +307,6 @@ SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
#undef FUNC_NAME
-#if SCM_ENABLE_DEPRECATED == 1
-
-/* to be used as cproc in scm_ramapc to fill an array dimension with
- "fill". */
-int
-scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
-{
- unsigned long i;
- unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
- long inc = SCM_I_ARRAY_DIMS (ra)->inc;
- unsigned long base = SCM_I_ARRAY_BASE (ra);
-
- ra = SCM_I_ARRAY_V (ra);
-
- for (i = base; n--; i += inc)
- ASET (ra, i, fill);
-
- return 1;
-}
-
-/* Functions callable by ARRAY-MAP! */
-
-int
-scm_ra_eqp (SCM ra0, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
- scm_t_array_handle ra0_handle;
- scm_t_array_dim *ra0_dims;
- size_t n;
- ssize_t inc0;
- size_t i0 = 0;
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- ra2 = SCM_I_ARRAY_V (ra2);
-
- scm_array_get_handle (ra0, &ra0_handle);
- ra0_dims = scm_array_handle_dims (&ra0_handle);
- n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
- inc0 = ra0_dims[0].inc;
-
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
- if (!scm_is_eq (AREF (ra1, i1), AREF (ra2, i2)))
- scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
- }
-
- scm_array_handle_release (&ra0_handle);
- return 1;
-}
-
-/* opt 0 means <, nonzero means >= */
-
-static int
-ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
-{
- scm_t_array_handle ra0_handle;
- scm_t_array_dim *ra0_dims;
- size_t n;
- ssize_t inc0;
- size_t i0 = 0;
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- ra2 = SCM_I_ARRAY_V (ra2);
-
- scm_array_get_handle (ra0, &ra0_handle);
- ra0_dims = scm_array_handle_dims (&ra0_handle);
- n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
- inc0 = ra0_dims[0].inc;
-
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
- if (opt ?
- scm_is_true (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))) :
- scm_is_false (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))))
- scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
- }
-
- scm_array_handle_release (&ra0_handle);
- return 1;
-}
-
-
-
-int
-scm_ra_lessp (SCM ra0, SCM ras)
-{
- return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
-}
-
-
-int
-scm_ra_leqp (SCM ra0, SCM ras)
-{
- return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
-}
-
-
-int
-scm_ra_grp (SCM ra0, SCM ras)
-{
- return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
-}
-
-
-int
-scm_ra_greqp (SCM ra0, SCM ras)
-{
- return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
-}
-
-
-int
-scm_ra_sum (SCM ra0, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (!scm_is_null(ras))
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- ASET (ra0, i0, scm_sum (AREF(ra0, i0), AREF(ra1, i1)));
- break;
- }
- }
- }
- return 1;
-}
-
-
-
-int
-scm_ra_difference (SCM ra0, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (scm_is_null (ras))
- {
- switch (SCM_TYP7 (ra0))
- {
- default:
- {
- for (; n-- > 0; i0 += inc0)
- ASET (ra0, i0, scm_difference (AREF(ra0, i0), SCM_UNDEFINED));
- break;
- }
- }
- }
- else
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- ASET (ra0, i0, scm_difference (AREF (ra0, i0), AREF (ra1, i1)));
- break;
- }
- }
- }
- return 1;
-}
-
-
-
-int
-scm_ra_product (SCM ra0, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (!scm_is_null (ras))
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- ASET (ra0, i0, scm_product (AREF (ra0, i0), AREF (ra1, i1)));
- }
- }
- }
- return 1;
-}
-
-
-int
-scm_ra_divide (SCM ra0, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (scm_is_null (ras))
- {
- switch (SCM_TYP7 (ra0))
- {
- default:
- {
- for (; n-- > 0; i0 += inc0)
- ASET (ra0, i0, scm_divide (AREF (ra0, i0), SCM_UNDEFINED));
- break;
- }
- }
- }
- else
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- {
- SCM res = scm_divide (AREF (ra0, i0), AREF (ra1, i1));
- ASET (ra0, i0, res);
- }
- break;
- }
- }
- }
- return 1;
-}
-
-
-int
-scm_array_identity (SCM dst, SCM src)
-{
- return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
-}
-
-#endif /* SCM_ENABLE_DEPRECATED */
-
static int
ramap (SCM ra0, SCM proc, SCM ras)
{
diff --git a/libguile/array-map.h b/libguile/array-map.h
index b0592d8..e7431b1 100644
--- a/libguile/array-map.h
+++ b/libguile/array-map.h
@@ -39,22 +39,6 @@ SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc);
SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1);
SCM_INTERNAL void scm_init_array_map (void);
-#if SCM_ENABLE_DEPRECATED == 1
-
-SCM_DEPRECATED int scm_array_fill_int (SCM ra, SCM fill, SCM ignore);
-SCM_DEPRECATED int scm_ra_eqp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_lessp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_leqp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_grp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_greqp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_sum (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_difference (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_product (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_divide (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_array_identity (SCM src, SCM dst);
-
-#endif /* SCM_ENABLE_DEPRECATED == 1 */
-
#endif /* SCM_ARRAY_MAP_H */
/*
diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c
index fc493bc..0fe8b89 100644
--- a/libguile/generalized-vectors.c
+++ b/libguile/generalized-vectors.c
@@ -69,19 +69,6 @@ SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0,
}
#undef FUNC_NAME
-int
-scm_is_generalized_vector (SCM obj)
-{
- int ret = 0;
- if (scm_is_array (obj))
- {
- scm_t_array_handle h;
- scm_array_get_handle (obj, &h);
- ret = scm_array_handle_rank (&h) == 1;
- scm_array_handle_release (&h);
- }
- return ret;
-}
#define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \
scm_generalized_vector_get_handle (val, handle)
@@ -98,24 +85,6 @@ scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h)
}
}
-size_t
-scm_c_generalized_vector_length (SCM v)
-{
- return scm_c_array_length (v);
-}
-
-SCM
-scm_c_generalized_vector_ref (SCM v, ssize_t idx)
-{
- return scm_c_array_ref_1 (v, idx);
-}
-
-void
-scm_c_generalized_vector_set_x (SCM v, ssize_t idx, SCM val)
-{
- scm_c_array_set_1_x (v, val, idx);
-}
-
void
scm_init_generalized_vectors ()
{
diff --git a/libguile/generalized-vectors.h b/libguile/generalized-vectors.h
index 876537a..77d6272 100644
--- a/libguile/generalized-vectors.h
+++ b/libguile/generalized-vectors.h
@@ -30,10 +30,6 @@
/* Generalized vectors */
-SCM_API int scm_is_generalized_vector (SCM obj);
-SCM_API size_t scm_c_generalized_vector_length (SCM v);
-SCM_API SCM scm_c_generalized_vector_ref (SCM v, ssize_t idx);
-SCM_API void scm_c_generalized_vector_set_x (SCM v, ssize_t idx, SCM val);
SCM_API void scm_generalized_vector_get_handle (SCM vec,
scm_t_array_handle *h);
--
2.7.3
[-- Attachment #7: 0006-Support-typed-arrays-in-some-sort-functions.patch --]
[-- Type: application/octet-stream, Size: 13636 bytes --]
From 82c3a8b4ee11fb612d309a2011f60f0f6cc6ee4d Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Tue, 12 Jul 2016 18:43:03 +0200
Subject: [PATCH 06/11] Support typed arrays in some sort functions
* libguile/sort.c (sort!, sort, restricted-vector-sort!, sorted?):
Support arrays of rank 1, whatever the type.
* libguile/quicksort.i.c: Fix accessors to handle typed arrays.
* test-suite/tests/sort.test: Test also with typed arrays.
---
libguile/quicksort.i.c | 45 ++++++++--------
libguile/sort.c | 131 ++++++++++++++++++++++++++++++---------------
test-suite/tests/sort.test | 32 ++++++++++-
3 files changed, 140 insertions(+), 68 deletions(-)
diff --git a/libguile/quicksort.i.c b/libguile/quicksort.i.c
index 4e39f82..cf1742e 100644
--- a/libguile/quicksort.i.c
+++ b/libguile/quicksort.i.c
@@ -11,7 +11,7 @@
version but doesn't consume extra memory.
*/
-#define SWAP(a, b) do { const SCM _tmp = a; a = b; b = _tmp; } while (0)
+#define SWAP(a, b) do { const SCM _tmp = GET(a); SET(a, GET(b)); SET(b, _tmp); } while (0)
/* Order using quicksort. This implementation incorporates four
@@ -54,8 +54,7 @@
#define STACK_NOT_EMPTY (stack < top)
static void
-NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
- SCM less)
+NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
{
/* Stack node declarations used to store unfulfilled partition obligations. */
typedef struct {
@@ -65,8 +64,6 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
static const char s_buggy_less[] = "buggy less predicate used when sorting";
-#define ELT(i) base_ptr[(i)*INC]
-
if (nr_elems == 0)
/* Avoid lossage with unsigned arithmetic below. */
return;
@@ -93,17 +90,17 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
SCM_TICK;
- if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo))))
- SWAP (ELT(mid), ELT(lo));
- if (scm_is_true (scm_call_2 (less, ELT(hi), ELT(mid))))
- SWAP (ELT(mid), ELT(hi));
+ if (scm_is_true (scm_call_2 (less, GET(mid), GET(lo))))
+ SWAP (mid, lo);
+ if (scm_is_true (scm_call_2 (less, GET(hi), GET(mid))))
+ SWAP (mid, hi);
else
goto jump_over;
- if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo))))
- SWAP (ELT(mid), ELT(lo));
+ if (scm_is_true (scm_call_2 (less, GET(mid), GET(lo))))
+ SWAP (mid, lo);
jump_over:;
- pivot = ELT(mid);
+ pivot = GET(mid);
left = lo + 1;
right = hi - 1;
@@ -112,7 +109,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
that this algorithm runs much faster than others. */
do
{
- while (scm_is_true (scm_call_2 (less, ELT(left), pivot)))
+ while (scm_is_true (scm_call_2 (less, GET(left), pivot)))
{
left += 1;
/* The comparison predicate may be buggy */
@@ -120,7 +117,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
scm_misc_error (NULL, s_buggy_less, SCM_EOL);
}
- while (scm_is_true (scm_call_2 (less, pivot, ELT(right))))
+ while (scm_is_true (scm_call_2 (less, pivot, GET(right))))
{
right -= 1;
/* The comparison predicate may be buggy */
@@ -130,7 +127,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
if (left < right)
{
- SWAP (ELT(left), ELT(right));
+ SWAP (left, right);
left += 1;
right -= 1;
}
@@ -192,11 +189,11 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
and the operation speeds up insertion sort's inner loop. */
for (run = tmp + 1; run <= thresh; run += 1)
- if (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp))))
+ if (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
tmp = run;
if (tmp != 0)
- SWAP (ELT(tmp), ELT(0));
+ SWAP (tmp, 0);
/* Insertion sort, running from left-hand-side up to right-hand-side. */
@@ -206,7 +203,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
SCM_TICK;
tmp = run - 1;
- while (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp))))
+ while (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
{
/* The comparison predicate may be buggy */
if (tmp == 0)
@@ -218,12 +215,12 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
tmp += 1;
if (tmp != run)
{
- SCM to_insert = ELT(run);
+ SCM to_insert = GET(run);
size_t hi, lo;
for (hi = lo = run; --lo >= tmp; hi = lo)
- ELT(hi) = ELT(lo);
- ELT(hi) = to_insert;
+ SET(hi, GET(lo));
+ SET(hi, to_insert);
}
}
}
@@ -235,9 +232,9 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
#undef PUSH
#undef POP
#undef STACK_NOT_EMPTY
-#undef ELT
+#undef GET
+#undef SET
#undef NAME
#undef INC_PARAM
-#undef INC
-
+#undef VEC_PARAM
diff --git a/libguile/sort.c b/libguile/sort.c
index 9373fb8..8c20d34 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -51,21 +51,23 @@
#include "libguile/validate.h"
#include "libguile/sort.h"
-/* We have two quicksort variants: one for contigous vectors and one
- for vectors with arbitrary increments between elements. Note that
- increments can be negative.
+/* We have two quicksort variants: one for SCM (#t) arrays and one for
+ typed arrays.
*/
-#define NAME quicksort1
-#define INC_PARAM /* empty */
-#define INC 1
-#include "libguile/quicksort.i.c"
-
#define NAME quicksort
#define INC_PARAM ssize_t inc,
-#define INC inc
+#define VEC_PARAM SCM * ra,
+#define GET(i) ra[(i)*inc]
+#define SET(i, val) ra[(i)*inc] = val
#include "libguile/quicksort.i.c"
+#define NAME quicksorta
+#define INC_PARAM
+#define VEC_PARAM scm_t_array_handle * const ra,
+#define GET(i) scm_array_handle_ref (ra, scm_array_handle_pos_1 (ra, i))
+#define SET(i, val) scm_array_handle_set (ra, scm_array_handle_pos_1 (ra, i), val)
+#include "libguile/quicksort.i.c"
SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
(SCM vec, SCM less, SCM startpos, SCM endpos),
@@ -76,22 +78,39 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
"is not specified.")
#define FUNC_NAME s_scm_restricted_vector_sort_x
{
- size_t vlen, spos, len;
- ssize_t vinc;
+ ssize_t spos = scm_to_ssize_t (startpos);
+ size_t epos = scm_to_ssize_t (endpos);
+
scm_t_array_handle handle;
- SCM *velts;
+ scm_t_array_dim const * dims;
+ scm_array_get_handle (vec, &handle);
+ dims = scm_array_handle_dims (&handle);
- velts = scm_vector_writable_elements (vec, &handle, &vlen, &vinc);
- spos = scm_to_unsigned_integer (startpos, 0, vlen);
- len = scm_to_unsigned_integer (endpos, spos, vlen) - spos;
+ if (scm_array_handle_rank(&handle) != 1)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", vec, SCM_EOL);
+ }
+ if (spos < dims[0].lbnd)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_out_of_range_key, FUNC_NAME, "startpos out of range",
+ vec, scm_list_1(startpos));
+ }
+ if (epos > dims[0].ubnd+1)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_out_of_range_key, FUNC_NAME, "endpos out of range",
+ vec, scm_list_1(endpos));
+ }
- if (vinc == 1)
- quicksort1 (velts + spos*vinc, len, less);
+ if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
+ quicksort (scm_array_handle_writable_elements (&handle) + (spos-dims[0].lbnd) * dims[0].inc,
+ epos-spos, dims[0].inc, less);
else
- quicksort (velts + spos*vinc, len, vinc, less);
+ quicksorta (&handle, epos-spos, less);
scm_array_handle_release (&handle);
-
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -140,29 +159,49 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
}
else
{
- scm_t_array_handle handle;
- size_t i, len;
- ssize_t inc;
- const SCM *elts;
SCM result = SCM_BOOL_T;
-
- elts = scm_vector_elements (items, &handle, &len, &inc);
-
- for (i = 1; i < len; i++, elts += inc)
- {
- if (scm_is_true (scm_call_2 (less, elts[inc], elts[0])))
- {
- result = SCM_BOOL_F;
- break;
- }
- }
+ ssize_t i, end;
+ scm_t_array_handle handle;
+ scm_t_array_dim const * dims;
+ scm_array_get_handle (items, &handle);
+ dims = scm_array_handle_dims (&handle);
+
+ if (scm_array_handle_rank(&handle) != 1)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items, SCM_EOL);
+ }
+
+ if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
+ {
+ ssize_t inc = dims[0].inc;
+ const SCM *elts = scm_array_handle_elements (&handle);
+ for (i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i, elts += inc)
+ {
+ if (scm_is_true (scm_call_2 (less, elts[inc], elts[0])))
+ {
+ result = SCM_BOOL_F;
+ break;
+ }
+ }
+ }
+ else
+ {
+ for (i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i)
+ {
+ if (scm_is_true (scm_call_2 (less,
+ scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i)),
+ scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i-1)))))
+ {
+ result = SCM_BOOL_F;
+ break;
+ }
+ }
+ }
scm_array_handle_release (&handle);
-
return result;
}
-
- return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -404,7 +443,14 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
if (scm_is_pair (items))
return scm_sort_x (scm_list_copy (items), less);
else if (scm_is_array (items) && scm_c_array_rank (items) == 1)
- return scm_sort_x (scm_vector_copy (items), less);
+ {
+ SCM copy;
+ if (scm_c_array_rank (items) != 1)
+ scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items, SCM_EOL);
+ copy = scm_make_typed_array (scm_array_type (items), SCM_UNSPECIFIED, scm_array_dimensions (items));
+ scm_array_copy_x (items, copy);
+ return scm_sort_x (copy, less);
+ }
else
SCM_WRONG_TYPE_ARG (1, items);
}
@@ -498,10 +544,11 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
vec_elts = scm_vector_writable_elements (items, &vec_handle,
&len, &inc);
- if (len == 0) {
- scm_array_handle_release (&vec_handle);
- return items;
- }
+ if (len == 0)
+ {
+ scm_array_handle_release (&vec_handle);
+ return items;
+ }
temp = scm_c_make_vector (len, SCM_UNDEFINED);
temp_elts = scm_vector_writable_elements (temp, &temp_handle,
diff --git a/test-suite/tests/sort.test b/test-suite/tests/sort.test
index 9209b53..249f890 100644
--- a/test-suite/tests/sort.test
+++ b/test-suite/tests/sort.test
@@ -31,22 +31,51 @@
exception:wrong-num-args
(sort '(1 2) (lambda (x y z) z)))
- (pass-if "sort!"
+ (pass-if "sort of vector"
+ (let* ((v (randomize-vector! (make-vector 1000) 1000))
+ (w (vector-copy v)))
+ (and (sorted? (sort v <) <)
+ (equal? w v))))
+
+ (pass-if "sort of typed array"
+ (let* ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99))
+ (w (make-typed-array 'f64 *unspecified* 99)))
+ (array-copy! v w)
+ (and (sorted? (sort v <) <)
+ (equal? w v))))
+
+ (pass-if "sort! of vector"
(let ((v (randomize-vector! (make-vector 1000) 1000)))
(sorted? (sort! v <) <)))
+ (pass-if "sort! of typed array"
+ (let ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99)))
+ (sorted? (sort! v <) <)))
+
(pass-if "sort! of non-contigous vector"
(let* ((a (make-array 0 1000 3))
(v (make-shared-array a (lambda (i) (list i 0)) 1000)))
(randomize-vector! v 1000)
(sorted? (sort! v <) <)))
+ (pass-if "sort! of non-contigous typed array"
+ (let* ((a (make-typed-array 'f64 0 99 3))
+ (v (make-shared-array a (lambda (i) (list i 0)) 99)))
+ (randomize-vector! v 99)
+ (sorted? (sort! v <) <)))
+
(pass-if "sort! of negative-increment vector"
(let* ((a (make-array 0 1000 3))
(v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000)))
(randomize-vector! v 1000)
(sorted? (sort! v <) <)))
+ (pass-if "sort! of negative-increment typed array"
+ (let* ((a (make-typed-array 'f64 0 99 3))
+ (v (make-shared-array a (lambda (i) (list (- 98 i) 0)) 99)))
+ (randomize-vector! v 99)
+ (sorted? (sort! v <) <)))
+
(pass-if "stable-sort!"
(let ((v (randomize-vector! (make-vector 1000) 1000)))
(sorted? (stable-sort! v <) <)))
@@ -79,4 +108,3 @@
;; behavior (integer underflow) leading to crashes.
(pass-if "empty vector"
(equal? '#() (stable-sort '#() <))))
-
--
2.7.3
[-- Attachment #8: 0007-Do-not-use-array-handles-in-scm_vector.patch --]
[-- Type: application/octet-stream, Size: 3542 bytes --]
From a39ed77e78f49e848b38db9bb876445dd02fd9ed Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 25 Feb 2015 09:47:40 +0100
Subject: [PATCH 07/11] Do not use array handles in scm_vector
* libguile/vectors.c (scm_vector): Use SCM_I_VECTOR_WELTS on new vector
instead of generic scm_vector_elements; cf. scm_vector_copy().
(scm_vector_elements): Forward to scm_vector_writable_elements().
(scm_vector_writable_elements): Remove special error message for weak
vector arg.
* libguile/generalized-vectors.c (SCM_VALIDATE_VECTOR_WITH_HANDLE):
Remove unused macro.
* libguile/array-handle.c (scm_array_handle_elements): Forward to
scm_array_handle_writable_elements().
---
libguile/array-handle.c | 4 +---
libguile/generalized-vectors.c | 5 -----
libguile/vectors.c | 20 ++------------------
3 files changed, 3 insertions(+), 26 deletions(-)
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 3595266..89277d9 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -320,9 +320,7 @@ scm_array_handle_release (scm_t_array_handle *h)
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;
+ return scm_array_handle_writable_elements (h);
}
SCM *
diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c
index 0fe8b89..276b9d8 100644
--- a/libguile/generalized-vectors.c
+++ b/libguile/generalized-vectors.c
@@ -69,11 +69,6 @@ SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0,
}
#undef FUNC_NAME
-
-#define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \
- scm_generalized_vector_get_handle (val, handle)
-
-
void
scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h)
{
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 5dab545..6dcc7eb 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -59,26 +59,13 @@ const SCM *
scm_vector_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
- if (SCM_I_WVECTP (vec))
- scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
-
- scm_generalized_vector_get_handle (vec, h);
- if (lenp)
- {
- scm_t_array_dim *dim = scm_array_handle_dims (h);
- *lenp = dim->ubnd - dim->lbnd + 1;
- *incp = dim->inc;
- }
- return scm_array_handle_elements (h);
+ return scm_vector_writable_elements (vec, h, lenp, incp);
}
SCM *
scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
- if (SCM_I_WVECTP (vec))
- scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
-
scm_generalized_vector_get_handle (vec, h);
if (lenp)
{
@@ -141,12 +128,11 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
SCM res;
SCM *data;
long i, len;
- scm_t_array_handle handle;
SCM_VALIDATE_LIST_COPYLEN (1, l, len);
res = scm_c_make_vector (len, SCM_UNSPECIFIED);
- data = scm_vector_writable_elements (res, &handle, NULL, NULL);
+ data = SCM_I_VECTOR_WELTS (res);
i = 0;
while (scm_is_pair (l) && i < len)
{
@@ -155,8 +141,6 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
i += 1;
}
- scm_array_handle_release (&handle);
-
return res;
}
#undef FUNC_NAME
--
2.7.3
[-- Attachment #9: 0008-Speed-up-for-multi-arg-cases-of-scm_ramap-functions.patch --]
[-- Type: application/octet-stream, Size: 11611 bytes --]
From 068598cf864c757c5ab36d40c9184143023f0fc8 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Fri, 13 Feb 2015 18:42:27 +0100
Subject: [PATCH 08/11] Speed up for multi-arg cases of scm_ramap functions
This patch results in a 20%-40% speedup in the > 1 argument cases of
the following microbenchmarks:
(define A (make-shared-array #0(1) (const '()) #e1e7))
; 1, 2, 3 arguments.
(define a 0) ,time (array-for-each (lambda (b) (set! a (+ a b))) A)
(define a 0) ,time (array-for-each (lambda (b c) (set! a (+ a b c))) A A)
(define a 0) ,time (array-for-each (lambda (b c d) (set! a (+ a b c d))) A A A)
(define A (make-shared-array (make-array 1) (const '()) #e1e7))
(define B (make-shared-array #0(1) (const '()) #e1e7))
; 1, 2, 3 arguments.
,time (array-map! A + B)
,time (array-map! A + B B)
,time (array-map! A + B B B)
* libguile/array-map.c (scm_ramap): Note on cproc arguments.
(rafill): Assume that dst's lbnd is 0.
(racp): Assume that src's lbnd is 0.
(ramap): Assume that ra0's lbnd is 0. When there're more than two
arguments, compute the array handles before the loop. Allocate the arg
list once and reuse it in the loop.
(rafe): Do as in ramap(), when there's more than one argument.
(AREF, ASET): Remove.
---
libguile/array-map.c | 136 ++++++++++++++++++++++++--------------------
libguile/array-map.h | 2 +-
test-suite/tests/ramap.test | 4 +-
3 files changed, 77 insertions(+), 65 deletions(-)
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 587df02..9caded8 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
- * 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+ * 2010, 2011, 2012, 2013, 2014, 2015 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
@@ -48,18 +48,6 @@
static const char vi_gc_hint[] = "array-indices";
static SCM
-AREF (SCM v, size_t pos)
-{
- return scm_c_array_ref_1 (v, pos);
-}
-
-static void
-ASET (SCM v, size_t pos, SCM val)
-{
- scm_c_array_set_1_x (v, val, pos);
-}
-
-static SCM
make1array (SCM v, ssize_t inc)
{
SCM a = scm_i_make_array (1);
@@ -99,6 +87,10 @@ cindk (SCM ra, ssize_t *ve, int kend)
#define LBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].lbnd
#define UBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].ubnd
+
+/* scm_ramapc() always calls cproc with rank-1 arrays created by
+ make1array. cproc (rafe, ramap, rafill, racp) can assume that the
+ dims[0].lbnd of these arrays is always 0. */
int
scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
{
@@ -167,7 +159,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
va1 = make1array (ra1, 1);
- if (LBND (ra0, 0) < LBND (va1, 0) || UBND (ra0, 0) > UBND (va1, 0))
+ if (LBND (ra0, 0) < 0 /* LBND (va1, 0) */ || UBND (ra0, 0) > UBND (va1, 0))
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
}
*plva = scm_cons (va1, SCM_EOL);
@@ -224,14 +216,12 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
static int
rafill (SCM dst, SCM fill)
{
+ size_t n = SCM_I_ARRAY_DIMS (dst)->ubnd + 1;
+ size_t i = SCM_I_ARRAY_BASE (dst);
+ ssize_t inc = SCM_I_ARRAY_DIMS (dst)->inc;
scm_t_array_handle h;
- size_t n, i;
- ssize_t inc;
- scm_array_get_handle (SCM_I_ARRAY_V (dst), &h);
- i = SCM_I_ARRAY_BASE (dst);
- inc = SCM_I_ARRAY_DIMS (dst)->inc;
- n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1);
dst = SCM_I_ARRAY_V (dst);
+ scm_array_get_handle (dst, &h);
for (; n-- > 0; i += inc)
h.vset (h.vector, i, fill);
@@ -255,19 +245,17 @@ SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
static int
racp (SCM src, SCM dst)
{
- scm_t_array_handle h_s, h_d;
- size_t n, i_s, i_d;
+ size_t i_s, i_d, n;
ssize_t inc_s, inc_d;
-
+ scm_t_array_handle h_s, h_d;
dst = SCM_CAR (dst);
i_s = SCM_I_ARRAY_BASE (src);
i_d = SCM_I_ARRAY_BASE (dst);
+ n = (SCM_I_ARRAY_DIMS (src)->ubnd + 1);
inc_s = SCM_I_ARRAY_DIMS (src)->inc;
inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
- n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
src = SCM_I_ARRAY_V (src);
dst = SCM_I_ARRAY_V (dst);
-
scm_array_get_handle (src, &h_s);
scm_array_get_handle (dst, &h_d);
@@ -310,44 +298,56 @@ SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
static int
ramap (SCM ra0, SCM proc, SCM ras)
{
+ size_t i0 = SCM_I_ARRAY_BASE (ra0);
+ ssize_t inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd + 1;
scm_t_array_handle h0;
- size_t n, i0;
- ssize_t i, inc0;
- i0 = SCM_I_ARRAY_BASE (ra0);
- inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
- n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
ra0 = SCM_I_ARRAY_V (ra0);
scm_array_get_handle (ra0, &h0);
+
if (scm_is_null (ras))
for (; n--; i0 += inc0)
h0.vset (h0.vector, i0, scm_call_0 (proc));
else
{
SCM ra1 = SCM_CAR (ras);
+ size_t i1 = SCM_I_ARRAY_BASE (ra1);
+ ssize_t inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
scm_t_array_handle h1;
- size_t i1;
- ssize_t inc1;
- i1 = SCM_I_ARRAY_BASE (ra1);
- inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ras = SCM_CDR (ras);
ra1 = SCM_I_ARRAY_V (ra1);
scm_array_get_handle (ra1, &h1);
+ ras = SCM_CDR (ras);
if (scm_is_null (ras))
for (; n--; i0 += inc0, i1 += inc1)
h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1)));
else
{
- ras = scm_vector (ras);
- for (; n--; i0 += inc0, i1 += inc1, ++i)
+ scm_t_array_handle *hs;
+ size_t restn = scm_ilength (ras);
+
+ SCM args = SCM_EOL;
+ SCM *p = &args;
+ SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k)
+ {
+ *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
+ sa[k] = SCM_CARLOC (*p);
+ p = SCM_CDRLOC (*p);
+ }
+
+ hs = scm_gc_malloc (sizeof(scm_t_array_handle) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k, ras = scm_cdr (ras))
+ scm_array_get_handle (scm_car (ras), hs+k);
+
+ for (ssize_t i = 0; n--; i0 += inc0, i1 += inc1, ++i)
{
- SCM args = SCM_EOL;
- unsigned long k;
- for (k = scm_c_vector_length (ras); k--;)
- args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
- h0.vset (h0.vector, i0,
- scm_apply_1 (proc, h1.vref (h1.vector, i1), args));
+ for (size_t k = 0; k < restn; ++k)
+ *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc);
+ h0.vset (h0.vector, i0, scm_apply_1 (proc, h1.vref (h1.vector, i1), args));
}
+
+ for (size_t k = 0; k < restn; ++k)
+ scm_array_handle_release (hs+k);
}
scm_array_handle_release (&h1);
}
@@ -384,30 +384,44 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
static int
rafe (SCM ra0, SCM proc, SCM ras)
{
- ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
- size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
-
+ size_t i0 = SCM_I_ARRAY_BASE (ra0);
+ ssize_t inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd + 1;
scm_t_array_handle h0;
- size_t i0;
- ssize_t inc0;
- i0 = SCM_I_ARRAY_BASE (ra0);
- inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
ra0 = SCM_I_ARRAY_V (ra0);
scm_array_get_handle (ra0, &h0);
+
if (scm_is_null (ras))
for (; n--; i0 += inc0)
scm_call_1 (proc, h0.vref (h0.vector, i0));
else
{
- ras = scm_vector (ras);
- for (; n--; i0 += inc0, ++i)
+ scm_t_array_handle *hs;
+ size_t restn = scm_ilength (ras);
+
+ SCM args = SCM_EOL;
+ SCM *p = &args;
+ SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k)
{
- SCM args = SCM_EOL;
- unsigned long k;
- for (k = scm_c_vector_length (ras); k--;)
- args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
+ *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
+ sa[k] = SCM_CARLOC (*p);
+ p = SCM_CDRLOC (*p);
+ }
+
+ hs = scm_gc_malloc (sizeof(scm_t_array_handle) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k, ras = scm_cdr (ras))
+ scm_array_get_handle (scm_car (ras), hs+k);
+
+ for (ssize_t i = 0; n--; i0 += inc0, ++i)
+ {
+ for (size_t k = 0; k < restn; ++k)
+ *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc);
scm_apply_1 (proc, h0.vref (h0.vector, i0), args);
}
+
+ for (size_t k = 0; k < restn; ++k)
+ scm_array_handle_release (hs+k);
}
scm_array_handle_release (&h0);
return 1;
@@ -445,15 +459,12 @@ static void
array_index_map_n (SCM ra, SCM proc)
{
scm_t_array_handle h;
- size_t i;
int k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
- ssize_t *vi;
- SCM **si;
SCM args = SCM_EOL;
SCM *p = &args;
- vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * (kmax + 1), vi_gc_hint);
- si = scm_gc_malloc_pointerless (sizeof(SCM *) * (kmax + 1), vi_gc_hint);
+ ssize_t *vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * (kmax + 1), vi_gc_hint);
+ SCM **si = scm_gc_malloc_pointerless (sizeof(SCM *) * (kmax + 1), vi_gc_hint);
for (k = 0; k <= kmax; k++)
{
@@ -471,6 +482,7 @@ array_index_map_n (SCM ra, SCM proc)
{
if (k == kmax)
{
+ size_t i;
vi[kmax] = SCM_I_ARRAY_DIMS (ra)[kmax].lbnd;
i = cindk (ra, vi, kmax+1);
for (; vi[kmax] <= SCM_I_ARRAY_DIMS (ra)[kmax].ubnd; ++vi[kmax])
diff --git a/libguile/array-map.h b/libguile/array-map.h
index e7431b1..cb18a62 100644
--- a/libguile/array-map.h
+++ b/libguile/array-map.h
@@ -4,7 +4,7 @@
#define SCM_ARRAY_MAP_H
/* Copyright (C) 1995, 1996, 1997, 2000, 2006, 2008, 2009, 2010,
- * 2011, 2013 Free Software Foundation, Inc.
+ * 2011, 2013, 2015 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
diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
index c8eaf96..bd8a434 100644
--- a/test-suite/tests/ramap.test
+++ b/test-suite/tests/ramap.test
@@ -453,11 +453,11 @@
(with-test-prefix "3 sources"
(pass-if-equal "noncompact arrays 1"
- '((3 3 3) (2 2 2))
+ '((3 1 3) (2 0 2))
(let* ((a #2((0 1) (2 3)))
(l '())
(rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-row a 1) (array-row a 1) (array-row a 1))
+ (array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1))
l))
(pass-if-equal "noncompact arrays 2"
--
2.7.3
[-- Attachment #10: 0009-Special-case-for-array-map-with-three-arguments.patch --]
[-- Type: application/octet-stream, Size: 4120 bytes --]
From 475b365631bf06e601ebc0da1f4e763c4396e39d Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 9 Dec 2015 13:10:48 +0100
Subject: [PATCH 09/11] Special case for array-map! with three arguments
Benchmark:
(define type #t)
(define A (make-typed-array 's32 0 10000 1000))
(define B (make-typed-array 's32 0 10000 1000))
(define C (make-typed-array 's32 0 10000 1000))
before:
scheme@(guile-user)> ,time (array-map! C + A B)
;; 0.792653s real time, 0.790970s run time. 0.000000s spent in GC.
after:
scheme@(guile-user)> ,time (array-map! C + A B)
;; 0.598513s real time, 0.597146s run time. 0.000000s spent in GC.
* libguile/array-map.c (ramap): Add special case with 3 arguments.
---
libguile/array-map.c | 60 +++++++++++++++++++++++++++++++++-------------------
1 file changed, 38 insertions(+), 22 deletions(-)
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 9caded8..01bebb8 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -322,32 +322,48 @@ ramap (SCM ra0, SCM proc, SCM ras)
h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1)));
else
{
- scm_t_array_handle *hs;
- size_t restn = scm_ilength (ras);
-
- SCM args = SCM_EOL;
- SCM *p = &args;
- SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint);
- for (size_t k = 0; k < restn; ++k)
+ SCM ra2 = SCM_CAR (ras);
+ size_t i2 = SCM_I_ARRAY_BASE (ra2);
+ ssize_t inc2 = SCM_I_ARRAY_DIMS (ra2)->inc;
+ scm_t_array_handle h2;
+ ra2 = SCM_I_ARRAY_V (ra2);
+ scm_array_get_handle (ra2, &h2);
+ ras = SCM_CDR (ras);
+ if (scm_is_null (ras))
+ for (; n--; i0 += inc0, i1 += inc1, i2 += inc2)
+ h0.vset (h0.vector, i0, scm_call_2 (proc, h1.vref (h1.vector, i1), h2.vref (h2.vector, i2)));
+ else
{
- *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
- sa[k] = SCM_CARLOC (*p);
- p = SCM_CDRLOC (*p);
- }
+ scm_t_array_handle *hs;
+ size_t restn = scm_ilength (ras);
+ SCM args = SCM_EOL;
+ SCM *p = &args;
+ SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint);
+ size_t k;
+ ssize_t i;
+
+ for (k = 0; k < restn; ++k)
+ {
+ *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
+ sa[k] = SCM_CARLOC (*p);
+ p = SCM_CDRLOC (*p);
+ }
- hs = scm_gc_malloc (sizeof(scm_t_array_handle) * restn, vi_gc_hint);
- for (size_t k = 0; k < restn; ++k, ras = scm_cdr (ras))
- scm_array_get_handle (scm_car (ras), hs+k);
+ hs = scm_gc_malloc (sizeof(scm_t_array_handle) * restn, vi_gc_hint);
+ for (k = 0; k < restn; ++k, ras = scm_cdr (ras))
+ scm_array_get_handle (scm_car (ras), hs+k);
- for (ssize_t i = 0; n--; i0 += inc0, i1 += inc1, ++i)
- {
- for (size_t k = 0; k < restn; ++k)
- *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc);
- h0.vset (h0.vector, i0, scm_apply_1 (proc, h1.vref (h1.vector, i1), args));
- }
+ for (i = 0; n--; i0 += inc0, i1 += inc1, i2 += inc2, ++i)
+ {
+ for (k = 0; k < restn; ++k)
+ *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc);
+ h0.vset (h0.vector, i0, scm_apply_2 (proc, h1.vref (h1.vector, i1), h2.vref (h2.vector, i2), args));
+ }
- for (size_t k = 0; k < restn; ++k)
- scm_array_handle_release (hs+k);
+ for (k = 0; k < restn; ++k)
+ scm_array_handle_release (hs+k);
+ }
+ scm_array_handle_release (&h2);
}
scm_array_handle_release (&h1);
}
--
2.7.3
[-- Attachment #11: 0010-New-functions-array-from-array-from-array-amend.patch --]
[-- Type: application/octet-stream, Size: 16430 bytes --]
From a1e57225689af768fbab06dcbce43360a299eaaa Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 11 Feb 2015 16:44:21 +0100
Subject: [PATCH 10/11] New functions array-from, array-from*, array-amend!
* libguile/arrays.h (scm_array_from, scm_array_from_s,
scm_array_amend_x): New declarations.
* libguile/arrays.c (scm_array_from, scm_array_from_s,
scm_array_amend_x): New functions, export as array-from, array-from*,
array-amend!.
* test-suite/tests/arrays.test: Tests for array-from, array-from*,
array-amend!.
* doc/ref/api-compound.texi: Document array-from, array-from*,
array-amend!.
---
doc/ref/api-compound.texi | 105 ++++++++++++++++++++++++++++
libguile/arrays.c | 158 +++++++++++++++++++++++++++++++++++++++++++
libguile/arrays.h | 6 ++
test-suite/tests/arrays.test | 109 +++++++++++++++++++++++++++++
4 files changed, 378 insertions(+)
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index cc9eef4..d17c4bf 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1676,6 +1676,111 @@ base and stride for new array indices in @var{oldarray} data. A few
sample points are enough because @var{mapfunc} is linear.
@end deffn
+
+@deffn {Scheme Procedure} array-ref array idx @dots{}
+@deffnx {C Function} scm_array_ref (array, idxlist)
+Return the element at @code{(idx @dots{})} in @var{array}.
+@end deffn
+
+@deffn {Scheme Procedure} array-from array idx @dots{}
+@deffnx {C Function} scm_array_from (array, idxlist)
+If the length of @var{idxlist} equals the rank @math{n} of
+@var{array}, return the element at @code{(idx @dots{})}, just like
+@code{(array-ref array idx @dots{})}. If, however, the length @math{k}
+of @var{idxlist} is shorter than @math{n}, then return the shared
+@math{(n-k)}-rank prefix cell of @var{array} given by @var{idxlist}.
+
+For example:
+
+@example
+@lisp
+(array-from #2((a b) (c d)) 0) @result{} #(a b)
+(array-from #2((a b) (c d)) 1) @result{} #(c d)
+(array-from #2((a b) (c d)) 1 1) @result{} d
+(array-from #2((a b) (c d))) @result{} #2((a b) (c d))
+@end lisp
+@end example
+
+@code{(apply array-from array indices)} is equivalent to
+
+@lisp
+(let ((len (length indices)))
+ (if (= (array-rank a) len)
+ (apply array-ref a indices)
+ (apply make-shared-array a
+ (lambda t (append indices t))
+ (drop (array-dimensions a) len))))
+@end lisp
+
+The name `from' comes from the J language.
+@end deffn
+
+@deffn {Scheme Procedure} array-from* array idx @dots{}
+@deffnx {C Function} scm_array_from_s (array, idxlist)
+Like @code{(array-from array idx @dots{})}, but return a 0-rank shared
+array if the length of @var{idxlist} matches the rank of
+@var{array}. This can be useful when using @var{ARRAY} as destination
+of copies.
+
+Compare:
+
+@example
+@lisp
+(array-from #2((a b) (c d)) 1 1) @result{} d
+(array-from* #2((a b) (c d)) 1) @result{} #0(d)
+(define a (make-array 'a 2 2))
+(array-fill! (array-from* a 1 1) 'b)
+a @result{} #2((a a) (a b)).
+(array-fill! (array-from a 1 1) 'b) @result{} error: not an array
+@end lisp
+@end example
+
+@code{(apply array-from* array indices)} is equivalent to
+
+@lisp
+(apply make-shared-array a
+ (lambda t (append indices t))
+ (drop (array-dimensions a) (length indices)))
+@end lisp
+@end deffn
+
+
+@deffn {Scheme Procedure} array-amend! array x idx @dots{}
+@deffnx {C Function} scm_array_amend_x (array, x, idxlist)
+If the length of @var{idxlist} equals the rank @math{n} of
+@var{array}, set the element at @code{(idx @dots{})} of @var{array} to
+@var{x}, just like @code{(array-set! array x idx @dots{})}. If,
+however, the length @math{k} of @var{idxlist} is shorter than
+@math{n}, then copy the @math{(n-k)}-rank array @var{x}
+into @math{(n-k)}-rank prefix cell of @var{array} given by
+@var{idxlist}. In this case, the last @math{(n-k)} dimensions of
+@var{array} and the dimensions of @var{x} must match exactly.
+
+This function returns the modified @var{array}.
+
+For example:
+
+@example
+@lisp
+(array-amend! (make-array 'a 2 2) b 1 1) @result{} #2((a a) (a b))
+(array-amend! (make-array 'a 2 2) #(x y) 1) @result{} #2((a a) (x y))
+@end lisp
+@end example
+
+@code{(apply array-amend! array x indices)} is equivalent to
+
+@lisp
+(let ((len (length indices)))
+ (if (= (array-rank array) len)
+ (apply array-set! array x indices)
+ (array-copy! x (apply array-from array indices)))
+ array)
+@end lisp
+
+The name `amend' comes from the J language.
+@end deffn
+
+
@deffn {Scheme Procedure} shared-array-increments array
@deffnx {C Function} scm_shared_array_increments (array)
For each dimension, return the distance between elements in the root vector.
diff --git a/libguile/arrays.c b/libguile/arrays.c
index fb522e1..273c48b 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -416,6 +416,164 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
#undef FUNC_NAME
+#define ARRAY_FROM_POS(error_args) \
+ scm_t_array_handle handle; \
+ scm_t_array_dim * s; \
+ size_t ndim, k; \
+ ssize_t pos; \
+ SCM i; \
+ scm_array_get_handle (ra, &handle); \
+ s = scm_array_handle_dims (&handle); \
+ ndim = scm_array_handle_rank (&handle); \
+ k = ndim; \
+ pos = 0; \
+ i = indices; \
+ for (; k>0 && scm_is_pair (i); --k, ++s, i=scm_cdr (i)) \
+ { \
+ ssize_t ik = scm_to_ssize_t (scm_car (i)); \
+ if (ik<s->lbnd || ik>s->ubnd) \
+ { \
+ scm_array_handle_release (&handle); \
+ scm_misc_error (FUNC_NAME, "indices out of range", error_args); \
+ } \
+ pos += (ik-s->lbnd) * s->inc; \
+ }
+
+#define ARRAY_FROM_GET_O \
+ scm_t_array_dim * os; \
+ o = scm_i_make_array (k); \
+ SCM_I_ARRAY_SET_V (o, handle.vector); \
+ SCM_I_ARRAY_SET_BASE (o, pos + handle.base); \
+ os = SCM_I_ARRAY_DIMS (o); \
+ for (; k>0; --k, ++s, ++os) \
+ { \
+ os->ubnd = s->ubnd; \
+ os->lbnd = s->lbnd; \
+ os->inc = s->inc; \
+ }
+
+
+SCM_DEFINE (scm_array_from_s, "array-from*", 1, 0, 1,
+ (SCM ra, SCM indices),
+ "Return the array slice @var{ra}[@var{indices} ..., ...]\n"
+ "The rank of @var{ra} must equal to the number of indices or larger.\n\n"
+ "See also @code{array-ref}, @code{array-from}, @code{array-amend!}.\n\n"
+ "@code{array-from*} may return a rank-0 array. For example:\n"
+ "@lisp\n"
+ "(array-from* #2((1 2 3) (4 5 6)) 1 1) @result{} #0(5)\n"
+ "(array-from* #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n"
+ "(array-from* #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n"
+ "(array-from* #0(5) @result{} #0(5).\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_from_s
+{
+ SCM o;
+ ARRAY_FROM_POS(scm_list_2 (ra, indices))
+ if (k==ndim)
+ o = ra;
+ else if (scm_is_null (i))
+ { ARRAY_FROM_GET_O }
+ else
+ {
+ scm_array_handle_release (&handle);
+ scm_misc_error(FUNC_NAME, "too many indices", scm_list_2 (ra, indices));
+ }
+ scm_array_handle_release (&handle);
+ return o;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_array_from, "array-from", 1, 0, 1,
+ (SCM ra, SCM indices),
+ "Return the element at the @code{(@var{indices} ...)} position\n"
+ "in array @var{ra}, or the array slice @var{ra}[@var{indices} ..., ...]\n"
+ "if the rank of @var{ra} is larger than the number of indices.\n\n"
+ "See also @code{array-ref}, @code{array-from*}, @code{array-amend!}.\n\n"
+ "@code{array-from} never returns a rank 0 array. For example:\n"
+ "@lisp\n"
+ "(array-from #2((1 2 3) (4 5 6)) 1 1) @result{} 5\n"
+ "(array-from #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n"
+ "(array-from #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n"
+ "(array-from #0(5) @result{} 5.\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_from
+{
+ SCM o;
+ ARRAY_FROM_POS(scm_list_2 (ra, indices))
+ if (k>0)
+ {
+ if (k==ndim)
+ o = ra;
+ else
+ { ARRAY_FROM_GET_O }
+ }
+ else if (scm_is_null(i))
+ o = scm_array_handle_ref (&handle, pos);
+ else
+ {
+ scm_array_handle_release (&handle);
+ scm_misc_error(FUNC_NAME, "too many indices", scm_list_2 (ra, indices));
+ }
+ scm_array_handle_release (&handle);
+ return o;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
+ (SCM ra, SCM b, SCM indices),
+ "Set the array slice @var{ra}[@var{indices} ..., ...] to @var{b}\n."
+ "Equivalent to @code{(array-copy! @var{b} (apply array-from @var{ra} @var{indices}))}\n"
+ "if the number of indices is smaller than the rank of @var{ra}; otherwise\n"
+ "equivalent to @code{(apply array-set! @var{ra} @var{b} @var{indices})}.\n"
+ "This function returns the modified array @var{ra}.\n\n"
+ "See also @code{array-ref}, @code{array-from}, @code{array-from*}.\n\n"
+ "For example:\n"
+ "@lisp\n"
+ "(define A (list->array 2 '((1 2 3) (4 5 6))))\n"
+ "(array-amend! A #0(99) 1 1) @result{} #2((1 2 3) (4 #0(99) 6))\n"
+ "(array-amend! A 99 1 1) @result{} #2((1 2 3) (4 99 6))\n"
+ "(array-amend! A #(a b c) 0) @result{} #2((a b c) (4 99 6))\n"
+ "(array-amend! A #2((x y z) (9 8 7))) @result{} #2((x y z) (9 8 7))\n\n"
+ "(define B (make-array 0))\n"
+ "(array-amend! B 15) @result{} #0(15)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_amend_x
+{
+ SCM o;
+ ARRAY_FROM_POS(scm_list_3 (ra, b, indices))
+ if (k>0)
+ {
+ if (k==ndim)
+ o = ra;
+ else
+ { ARRAY_FROM_GET_O }
+ scm_array_handle_release(&handle);
+ /* an error is still possible here if o and b don't match. */
+ /* TODO copying like this wastes the handle, and the bounds matching
+ behavior of array-copy! is not strict. */
+ scm_array_copy_x(b, o);
+ }
+ else if (scm_is_null(i))
+ {
+ scm_array_handle_set (&handle, pos, b); /* ra may be non-ARRAYP */
+ scm_array_handle_release (&handle);
+ }
+ else
+ {
+ scm_array_handle_release (&handle);
+ scm_misc_error(FUNC_NAME, "too many indices", scm_list_3 (ra, b, indices));
+ }
+ return ra;
+}
+#undef FUNC_NAME
+
+
+#undef ARRAY_FROM_POS
+#undef ARRAY_FROM_GET_O
+
+
/* args are RA . DIMS */
SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
(SCM ra, SCM args),
diff --git a/libguile/arrays.h b/libguile/arrays.h
index d3e409f..9b7fd6c 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -41,12 +41,18 @@ 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_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_contents (SCM ra, SCM strict);
+SCM_API SCM scm_array_from_s (SCM ra, SCM indices);
+SCM_API SCM scm_array_from (SCM ra, SCM indices);
+SCM_API SCM scm_array_amend_x (SCM ra, SCM b, SCM indices);
+
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);
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index c40457b..9bd0676 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -296,6 +296,115 @@
(and (eqv? 5 (array-ref s2 1))
(eqv? 8 (array-ref s2 2))))))
+
+;;;
+;;; array-from*
+;;;
+
+(with-test-prefix/c&e "array-from*"
+
+ (pass-if "vector I"
+ (let ((v (vector 1 2 3)))
+ (array-fill! (array-from* v 1) 'a)
+ (array-equal? v #(1 a 3))))
+
+ (pass-if "vector II"
+ (let ((v (vector 1 2 3)))
+ (array-copy! #(a b c) (array-from* v))
+ (array-equal? v #(a b c))))
+
+ (pass-if "array I"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-fill! (array-from* a 1 1) 'a)
+ (array-equal? a #2((1 2 3) (4 a 6)))))
+
+ (pass-if "array II"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-copy! #(a b c) (array-from* a 1))
+ (array-equal? a #2((1 2 3) (a b c)))))
+
+ (pass-if "array III"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-copy! #2((a b c) (x y z)) (array-from* a))
+ (array-equal? a #2((a b c) (x y z)))))
+
+ (pass-if "rank 0 array"
+ (let ((a (make-array 77)))
+ (array-fill! (array-from* a) 'a)
+ (array-equal? a #0(a)))))
+
+
+;;;
+;;; array-from
+;;;
+
+(with-test-prefix/c&e "array-from"
+
+ (pass-if "vector I"
+ (let ((v (vector 1 2 3)))
+ (equal? 2 (array-from v 1))))
+
+ (pass-if "vector II"
+ (let ((v (vector 1 2 3)))
+ (array-copy! #(a b c) (array-from v))
+ (array-equal? v #(a b c))))
+
+ (pass-if "array I"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (equal? 5 (array-from a 1 1))))
+
+ (pass-if "array II"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-copy! #(a b c) (array-from a 1))
+ (array-equal? a #2((1 2 3) (a b c)))))
+
+ (pass-if "array III"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-copy! #2((a b c) (x y z)) (array-from a))
+ (array-equal? a #2((a b c) (x y z)))))
+
+ (pass-if "rank 0 array"
+ (let ((a (make-array 77)))
+ (equal? (array-from a) 77))))
+
+
+;;;
+;;; array-amend!
+;;;
+
+(with-test-prefix/c&e "array-amend!"
+
+ (pass-if "vector I"
+ (let ((v (vector 1 2 3)))
+ (and (eq? v (array-amend! v 'x 1))
+ (array-equal? v #(1 x 3)))))
+
+ (pass-if "vector II"
+ (let ((v (vector 1 2 3)))
+ (and (eq? v (array-amend! (array-from v) #(a b c)))
+ (array-equal? v #(a b c)))))
+
+ (pass-if "array I"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (and (eq? a (array-amend! a 'x 1 1))
+ (array-equal? a #2((1 2 3) (4 x 6))))))
+
+ (pass-if "array II"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (and (eq? a (array-amend! a #(a b c) 1))
+ (array-equal? a #2((1 2 3) (a b c))))))
+
+ (pass-if "array III"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (and (eq? a (array-amend! a #2((a b c) (x y z))))
+ (array-equal? a #2((a b c) (x y z))))))
+
+ (pass-if "rank 0 array"
+ (let ((a (make-array 77)))
+ (and (eq? a (array-amend! a 99))
+ (array-equal? a #0(99))))))
+
+
;;;
;;; array-contents
;;;
--
2.7.3
[-- Attachment #12: 0011-New-functions-array-for-each-cell-array-for-each-cel.patch --]
[-- Type: application/octet-stream, Size: 59239 bytes --]
From ed383e94e45557b40536853c0fd4545ba0dfba80 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Tue, 8 Sep 2015 16:57:30 +0200
Subject: [PATCH 11/11] New functions (array-for-each-cell,
array-for-each-cell-in-order)
* libguile/array-map.c (scm_i_array_rebase, scm_array_for_each_cell):
New functions. Export scm_array_for_each_cell() as
(array-for-each-cell).
(array-for-each-cell-in-order): Define additional export.
* libguile/array-map.h (scm_i_array_rebase, scm_array_for_each_cell):
Add prototypes.
* doc/ref/api-compound.texi: New section 'Arrays as arrays of
arrays'. Move the documentation for (array-from), (array-from*) and
(array-amend!) in here. Add documentation for (array-for-each-cell).
* test-suite/tests/array-map.test: Renamed from
test-suite/tests/ramap.test, fix module name. Add tests for
(array-for-each-cell).
* test-suite/Makefile.am: Apply rename array-map.test -> ramap.test.
* doc/ref/api-compound.texi: Minor documentation fixes.
---
doc/ref/api-compound.texi | 169 +++++++++----
libguile/array-map.c | 260 ++++++++++++++++++-
libguile/array-map.h | 4 +
libguile/arrays.c | 5 +-
test-suite/Makefile.am | 2 +-
test-suite/tests/array-map.test | 540 ++++++++++++++++++++++++++++++++++++++++
test-suite/tests/ramap.test | 509 -------------------------------------
7 files changed, 923 insertions(+), 566 deletions(-)
create mode 100644 test-suite/tests/array-map.test
delete mode 100644 test-suite/tests/ramap.test
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index d17c4bf..bc2c98b 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1203,6 +1203,7 @@ dimensional arrays.
* Array Syntax::
* Array Procedures::
* Shared Arrays::
+* Arrays as arrays of arrays::
* Accessing Arrays from C::
@end menu
@@ -1682,24 +1683,91 @@ sample points are enough because @var{mapfunc} is linear.
Return the element at @code{(idx @dots{})} in @var{array}.
@end deffn
+
+@deffn {Scheme Procedure} shared-array-increments array
+@deffnx {C Function} scm_shared_array_increments (array)
+For each dimension, return the distance between elements in the root vector.
+@end deffn
+
+@deffn {Scheme Procedure} shared-array-offset array
+@deffnx {C Function} scm_shared_array_offset (array)
+Return the root vector index of the first element in the array.
+@end deffn
+
+@deffn {Scheme Procedure} shared-array-root array
+@deffnx {C Function} scm_shared_array_root (array)
+Return the root vector of a shared array.
+@end deffn
+
+@deffn {Scheme Procedure} array-contents array [strict]
+@deffnx {C Function} scm_array_contents (array, strict)
+If @var{array} may be @dfn{unrolled} into a one dimensional shared array
+without changing their order (last subscript changing fastest), then
+@code{array-contents} returns that shared array, otherwise it returns
+@code{#f}. All arrays made by @code{make-array} and
+@code{make-typed-array} may be unrolled, some arrays made by
+@code{make-shared-array} may not be.
+
+If the optional argument @var{strict} is provided, a shared array will
+be returned only if its elements are stored internally contiguous in
+memory.
+@end deffn
+
+@deffn {Scheme Procedure} transpose-array array dim1 dim2 @dots{}
+@deffnx {C Function} scm_transpose_array (array, dimlist)
+Return an array sharing contents with @var{array}, but with
+dimensions arranged in a different order. There must be one
+@var{dim} argument for each dimension of @var{array}.
+@var{dim1}, @var{dim2}, @dots{} should be integers between 0
+and the rank of the array to be returned. Each integer in that
+range must appear at least once in the argument list.
+
+The values of @var{dim1}, @var{dim2}, @dots{} correspond to
+dimensions in the array to be returned, and their positions in the
+argument list to dimensions of @var{array}. Several @var{dim}s
+may have the same value, in which case the returned array will
+have smaller rank than @var{array}.
+
+@lisp
+(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))
+(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)
+(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}
+ #2((a 4) (b 5) (c 6))
+@end lisp
+@end deffn
+
+@node Arrays as arrays of arrays
+@subsubsection Arrays as arrays of arrays
+
+The functions in this section allow you to treat an array of rank
+@math{n} as an array of lower rank @math{n-k} where the elements are
+themselves arrays (`cells') of rank @math{k}. This replicates some of
+the functionality of `enclosed arrays', a feature of old Guile that was
+removed before @w{version 2.0}. However, these functions do not require
+a special type and operate on any array.
+
+When we operate on an array in this way, we speak of the first @math{k}
+dimensions of the array as the @math{k}-`frame' of the array, while the
+last @math{n-k} dimensions are the dimensions of the
+@math{n-k}-`cell'. For example, a 2D-array (a matrix) can be seen as a
+1D array of rows. In this case, the rows are the 1-cells of the array.
+
@deffn {Scheme Procedure} array-from array idx @dots{}
@deffnx {C Function} scm_array_from (array, idxlist)
If the length of @var{idxlist} equals the rank @math{n} of
@var{array}, return the element at @code{(idx @dots{})}, just like
@code{(array-ref array idx @dots{})}. If, however, the length @math{k}
of @var{idxlist} is shorter than @math{n}, then return the shared
-@math{(n-k)}-rank prefix cell of @var{array} given by @var{idxlist}.
+@math{(n-k)}-rank cell of @var{array} given by @var{idxlist}.
For example:
-@example
@lisp
(array-from #2((a b) (c d)) 0) @result{} #(a b)
(array-from #2((a b) (c d)) 1) @result{} #(c d)
(array-from #2((a b) (c d)) 1 1) @result{} d
(array-from #2((a b) (c d))) @result{} #2((a b) (c d))
@end lisp
-@end example
@code{(apply array-from array indices)} is equivalent to
@@ -1719,12 +1787,11 @@ The name `from' comes from the J language.
@deffnx {C Function} scm_array_from_s (array, idxlist)
Like @code{(array-from array idx @dots{})}, but return a 0-rank shared
array if the length of @var{idxlist} matches the rank of
-@var{array}. This can be useful when using @var{ARRAY} as destination
-of copies.
+@var{array}. This can be useful when using @var{ARRAY} as a place to
+write into.
Compare:
-@example
@lisp
(array-from #2((a b) (c d)) 1 1) @result{} d
(array-from* #2((a b) (c d)) 1) @result{} #0(d)
@@ -1733,7 +1800,6 @@ Compare:
a @result{} #2((a a) (a b)).
(array-fill! (array-from a 1 1) 'b) @result{} error: not an array
@end lisp
-@end example
@code{(apply array-from* array indices)} is equivalent to
@@ -1752,7 +1818,7 @@ If the length of @var{idxlist} equals the rank @math{n} of
@var{x}, just like @code{(array-set! array x idx @dots{})}. If,
however, the length @math{k} of @var{idxlist} is shorter than
@math{n}, then copy the @math{(n-k)}-rank array @var{x}
-into @math{(n-k)}-rank prefix cell of @var{array} given by
+into the @math{(n-k)}-cell of @var{array} given by
@var{idxlist}. In this case, the last @math{(n-k)} dimensions of
@var{array} and the dimensions of @var{x} must match exactly.
@@ -1760,12 +1826,19 @@ This function returns the modified @var{array}.
For example:
-@example
@lisp
(array-amend! (make-array 'a 2 2) b 1 1) @result{} #2((a a) (a b))
(array-amend! (make-array 'a 2 2) #(x y) 1) @result{} #2((a a) (x y))
@end lisp
-@end example
+
+Note that @code{array-amend!} will expect elements, not arrays, when the
+destination has rank 0. One can work around this using
+@code{array-from*} instead.
+
+@lisp
+(array-amend! (make-array 'a 2 2) #0(b) 1 1) @result{} #2((a a) (a #0(b)))
+(let ((a (make-array 'a 2 2))) (array-copy! #0(b) (array-from* a 1 1)) a) @result{} #2((a a) (a b))
+@end lisp
@code{(apply array-amend! array x indices)} is equivalent to
@@ -1781,58 +1854,52 @@ The name `amend' comes from the J language.
@end deffn
-@deffn {Scheme Procedure} shared-array-increments array
-@deffnx {C Function} scm_shared_array_increments (array)
-For each dimension, return the distance between elements in the root vector.
-@end deffn
+@deffn {Scheme Procedure} array-for-each-cell frame-rank op x @dots{}
+@deffnx {C Function} scm_array_for_each_cell (array, frame_rank, op, xlist)
+Each @var{x} must be an array of rank ≥ @var{frame-rank}, and
+the first @var{frame-rank} dimensions of each @var{x} must all be the
+same. @var{array-for-each-cell} calls @var{op} with each set of
+(rank(@var{x}) - @var{frame-rank})-cells from @var{x}, in unspecified order.
-@deffn {Scheme Procedure} shared-array-offset array
-@deffnx {C Function} scm_shared_array_offset (array)
-Return the root vector index of the first element in the array.
-@end deffn
+@var{array-for-each-cell} allows you to loop over cells of any rank
+without having to carry an index list or construct slices manually. The
+cells passed to @var{op} are shared arrays of @var{X} so it is possible
+to write to them.
-@deffn {Scheme Procedure} shared-array-root array
-@deffnx {C Function} scm_shared_array_root (array)
-Return the root vector of a shared array.
-@end deffn
+This function returns an unspecified value.
-@deffn {Scheme Procedure} array-contents array [strict]
-@deffnx {C Function} scm_array_contents (array, strict)
-If @var{array} may be @dfn{unrolled} into a one dimensional shared array
-without changing their order (last subscript changing fastest), then
-@code{array-contents} returns that shared array, otherwise it returns
-@code{#f}. All arrays made by @code{make-array} and
-@code{make-typed-array} may be unrolled, some arrays made by
-@code{make-shared-array} may not be.
+For example, to sort the rows of rank-2 array @code{a}:
-If the optional argument @var{strict} is provided, a shared array will
-be returned only if its elements are stored internally contiguous in
-memory.
-@end deffn
+@lisp
+(array-for-each-cell 1 (lambda (x) (sort! x <)) a)
+@end lisp
-@deffn {Scheme Procedure} transpose-array array dim1 dim2 @dots{}
-@deffnx {C Function} scm_transpose_array (array, dimlist)
-Return an array sharing contents with @var{array}, but with
-dimensions arranged in a different order. There must be one
-@var{dim} argument for each dimension of @var{array}.
-@var{dim1}, @var{dim2}, @dots{} should be integers between 0
-and the rank of the array to be returned. Each integer in that
-range must appear at least once in the argument list.
+As another example, let @code{a} be a rank-2 array where each row is a 2-vector @math{(x,y)}.
+Let's compute the arguments of these vectors and store them in rank-1 array @code{b}.
+@lisp
+(array-for-each-cell 1
+ (lambda (a b)
+ (array-set! b (atan (array-ref a 1) (array-ref a 0))))
+ a b)
+@end lisp
-The values of @var{dim1}, @var{dim2}, @dots{} correspond to
-dimensions in the array to be returned, and their positions in the
-argument list to dimensions of @var{array}. Several @var{dim}s
-may have the same value, in which case the returned array will
-have smaller rank than @var{array}.
+@code{(apply array-for-each-cell frame-rank op x)} is functionally
+equivalent to
@lisp
-(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))
-(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)
-(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}
- #2((a 4) (b 5) (c 6))
+(let ((frame (take (array-dimensions (car x)) frank)))
+ (unless (every (lambda (x)
+ (equal? frame (take (array-dimensions x) frank)))
+ (cdr x))
+ (error))
+ (array-index-map!
+ (apply make-shared-array (make-array #t) (const '()) frame)
+ (lambda i (apply op (map (lambda (x) (apply array-from* x i)) x)))))
@end lisp
+
@end deffn
+
@node Accessing Arrays from C
@subsubsection Accessing Arrays from C
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 01bebb8..f907786 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -42,7 +42,7 @@
#include "libguile/validate.h"
#include "libguile/array-map.h"
-\f
+#include <assert.h>
/* The WHAT argument for `scm_gc_malloc ()' et al. */
static const char vi_gc_hint[] = "array-indices";
@@ -629,7 +629,8 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
return SCM_BOOL_T;
while (!scm_is_null (rest))
- { if (scm_is_false (scm_array_equal_p (ra0, ra1)))
+ {
+ if (scm_is_false (scm_array_equal_p (ra0, ra1)))
return SCM_BOOL_F;
ra0 = ra1;
ra1 = scm_car (rest);
@@ -640,6 +641,261 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
#undef FUNC_NAME
+/* Copy array descriptor with different base. */
+SCM
+scm_i_array_rebase (SCM a, size_t base)
+{
+ size_t ndim = SCM_I_ARRAY_NDIM (a);
+ SCM b = scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3);
+ SCM_I_ARRAY_SET_V (b, SCM_I_ARRAY_V (a));
+/* FIXME do check base */
+ SCM_I_ARRAY_SET_BASE (b, base);
+ memcpy (SCM_I_ARRAY_DIMS (b), SCM_I_ARRAY_DIMS (a), sizeof (scm_t_array_dim)*ndim);
+ return b;
+}
+
+static inline size_t padtoptr(size_t d) { return (d + (sizeof (void *) - 1)) & ~(sizeof (void *) - 1); }
+
+SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1,
+ (SCM frame_rank, SCM op, SCM args),
+ "Apply @var{op} to each of the cells of rank rank(@var{arg})-@var{frame_rank}\n"
+ "of the arrays @var{args}, in unspecified order. The first\n"
+ "@var{frame_rank} dimensions of each @var{arg} must match.\n"
+ "Rank-0 cells are passed as rank-0 arrays.\n\n"
+ "The value returned is unspecified.\n\n"
+ "For example:\n"
+ "@lisp\n"
+ ";; Sort the rows of rank-2 array A.\n\n"
+ "(array-for-each-cell 1 (lambda (x) (sort! x <)) a)\n"
+ "\n"
+ ";; Compute the arguments of the (x y) vectors in the rows of rank-2\n"
+ ";; array XYS and store them in rank-1 array ANGLES. Inside OP,\n"
+ ";; XY is a rank-1 (2-1) array, and ANGLE is a rank-0 (1-1) array.\n\n"
+ "(array-for-each-cell 1 \n"
+ " (lambda (xy angle)\n"
+ " (array-set! angle (atan (array-ref xy 1) (array-ref xy 0))))\n"
+ " xys angles)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_for_each_cell
+{
+ int const N = scm_ilength (args);
+ int const frank = scm_to_int (frame_rank);
+ int ocd;
+ ssize_t step;
+ SCM dargs_ = SCM_EOL;
+ char const * msg;
+ scm_t_array_dim * ais;
+ int n, k;
+ ssize_t z;
+
+ /* to be allocated inside the pool */
+ scm_t_array_handle * ah;
+ SCM * args_;
+ scm_t_array_dim ** as;
+ int * rank;
+
+ ssize_t * s;
+ SCM * ai;
+ SCM ** dargs;
+ ssize_t * i;
+
+ int * order;
+ size_t * base;
+
+ /* size the pool */
+ char * pool;
+ char * pool0;
+ size_t pool_size = 0;
+ pool_size += padtoptr(N*sizeof (scm_t_array_handle));
+ pool_size += padtoptr(N*sizeof (SCM));
+ pool_size += padtoptr(N*sizeof (scm_t_array_dim *));
+ pool_size += padtoptr(N*sizeof (int));
+
+ pool_size += padtoptr(frank*sizeof (ssize_t));
+ pool_size += padtoptr(N*sizeof (SCM));
+ pool_size += padtoptr(N*sizeof (SCM *));
+ pool_size += padtoptr(frank*sizeof (ssize_t));
+
+ pool_size += padtoptr(frank*sizeof (int));
+ pool_size += padtoptr(N*sizeof (size_t));
+ pool = scm_gc_malloc (pool_size, "pool");
+
+ /* place the items in the pool */
+#define AFIC_ALLOC_ADVANCE(pool, count, type, name) \
+ name = (void *)pool; \
+ pool += padtoptr(count*sizeof (type));
+
+ pool0 = pool;
+ AFIC_ALLOC_ADVANCE (pool, N, scm_t_array_handle, ah);
+ AFIC_ALLOC_ADVANCE (pool, N, SCM, args_);
+ AFIC_ALLOC_ADVANCE (pool, N, scm_t_array_dim *, as);
+ AFIC_ALLOC_ADVANCE (pool, N, int, rank);
+
+ AFIC_ALLOC_ADVANCE (pool, frank, ssize_t, s);
+ AFIC_ALLOC_ADVANCE (pool, N, SCM, ai);
+ AFIC_ALLOC_ADVANCE (pool, N, SCM *, dargs);
+ AFIC_ALLOC_ADVANCE (pool, frank, ssize_t, i);
+
+ AFIC_ALLOC_ADVANCE (pool, frank, int, order);
+ AFIC_ALLOC_ADVANCE (pool, N, size_t, base);
+ assert((pool0+pool_size==pool) && "internal error");
+#undef AFIC_ALLOC_ADVANCE
+
+ for (n=0; scm_is_pair(args); args=scm_cdr(args), ++n)
+ {
+ args_[n] = scm_car(args);
+ scm_array_get_handle(args_[n], ah+n);
+ as[n] = scm_array_handle_dims(ah+n);
+ rank[n] = scm_array_handle_rank(ah+n);
+ }
+ /* checks */
+ msg = NULL;
+ if (frank<0)
+ msg = "bad frame rank";
+ else
+ {
+ for (n=0; n!=N; ++n)
+ {
+ if (rank[n]<frank)
+ {
+ msg = "frame too large for arguments";
+ goto check_msg;
+ }
+ for (k=0; k!=frank; ++k)
+ {
+ if (as[n][k].lbnd!=0)
+ {
+ msg = "non-zero base index is not supported";
+ goto check_msg;
+ }
+ if (as[0][k].ubnd!=as[n][k].ubnd)
+ {
+ msg = "mismatched frames";
+ goto check_msg;
+ }
+ s[k] = as[n][k].ubnd + 1;
+
+ /* this check is needed if the array cannot be entirely */
+ /* unrolled, because the unrolled subloop will be run before */
+ /* checking the dimensions of the frame. */
+ if (s[k]==0)
+ goto end;
+ }
+ }
+ }
+ check_msg: ;
+ if (msg!=NULL)
+ {
+ for (n=0; n!=N; ++n)
+ scm_array_handle_release(ah+n);
+ scm_misc_error("array-for-each-cell", msg, scm_cons_star(frame_rank, args));
+ }
+ /* prepare moving cells. */
+ for (n=0; n!=N; ++n)
+ {
+ ai[n] = scm_i_make_array(rank[n]-frank);
+ SCM_I_ARRAY_SET_V (ai[n], scm_shared_array_root(args_[n]));
+ /* FIXME scm_array_handle_base (ah+n) should be in Guile */
+ SCM_I_ARRAY_SET_BASE (ai[n], ah[n].base);
+ ais = SCM_I_ARRAY_DIMS(ai[n]);
+ for (k=frank; k!=rank[n]; ++k)
+ {
+ ais[k-frank] = as[n][k];
+ }
+ }
+ /* prepare rest list for callee. */
+ {
+ SCM *p = &dargs_;
+ for (n=0; n<N; ++n)
+ {
+ *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
+ dargs[n] = SCM_CARLOC (*p);
+ p = SCM_CDRLOC (*p);
+ }
+ }
+ /* special case for rank 0. */
+ if (frank==0)
+ {
+ for (n=0; n<N; ++n)
+ *dargs[n] = ai[n];
+ scm_apply_0(op, dargs_);
+ for (n=0; n<N; ++n)
+ scm_array_handle_release(ah+n);
+ return SCM_UNSPECIFIED;
+ }
+ /* FIXME determine best looping order. */
+ for (k=0; k!=frank; ++k)
+ {
+ i[k] = 0;
+ order[k] = frank-1-k;
+ }
+ /* find outermost compact dim. */
+ step = s[order[0]];
+ ocd = 1;
+ for (; ocd<frank; step *= s[order[ocd]], ++ocd)
+ for (n=0; n!=N; ++n)
+ if (step*as[n][order[0]].inc!=as[n][order[ocd]].inc)
+ goto ocd_reached;
+ ocd_reached: ;
+ /* rank loop. */
+ for (n=0; n!=N; ++n)
+ base[n] = SCM_I_ARRAY_BASE(ai[n]);
+ for (;;)
+ {
+ /* unrolled loop. */
+ for (z=0; z!=step; ++z)
+ {
+ /* we are forced to create fresh array descriptors for each */
+ /* call since we don't know whether the callee will keep them, */
+ /* and Guile offers no way to copy the descriptor (since */
+ /* descriptors are immutable). Yet another reason why this */
+ /* should be in Scheme. */
+ for (n=0; n<N; ++n)
+ {
+ *dargs[n] = scm_i_array_rebase(ai[n], base[n]);
+ base[n] += as[n][order[0]].inc;
+ }
+ scm_apply_0(op, dargs_);
+ }
+ for (n=0; n<N; ++n)
+ base[n] -= step*as[n][order[0]].inc;
+ for (k=ocd; ; ++k)
+ {
+ if (k==frank)
+ goto end;
+ else if (i[order[k]]<s[order[k]]-1)
+ {
+ ++i[order[k]];
+ for (n=0; n<N; ++n)
+ base[n] += as[n][order[k]].inc;
+ break;
+ }
+ else
+ {
+ i[order[k]] = 0;
+ for (n=0; n<N; ++n)
+ base[n] += as[n][order[k]].inc*(1-s[order[k]]);
+ }
+ }
+ }
+ end:;
+ for (n=0; n<N; ++n)
+ scm_array_handle_release(ah+n);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_array_for_each_cell_in_order, "array-for-each-cell-in-order", 2, 0, 1,
+ (SCM frank, SCM op, SCM a),
+ "Same as array-for-each-cell, but visit the cells sequentially\n"
+ "and in row-major order.\n")
+#define FUNC_NAME s_scm_array_for_each_cell_in_order
+{
+ return scm_array_for_each_cell (frank, op, a);
+}
+#undef FUNC_NAME
+
+
void
scm_init_array_map (void)
{
diff --git a/libguile/array-map.h b/libguile/array-map.h
index cb18a62..acfdd5e 100644
--- a/libguile/array-map.h
+++ b/libguile/array-map.h
@@ -37,6 +37,10 @@ SCM_API SCM scm_array_map_x (SCM ra0, SCM proc, SCM lra);
SCM_API SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra);
SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc);
SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1);
+SCM_API SCM scm_array_for_each_cell (SCM frank, SCM op, SCM args);
+SCM_API SCM scm_array_for_each_cell_in_order (SCM frank, SCM op, SCM args);
+
+SCM_INTERNAL SCM scm_i_array_rebase (SCM a, size_t base);
SCM_INTERNAL void scm_init_array_map (void);
#endif /* SCM_ARRAY_MAP_H */
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 273c48b..7622ea8 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -28,7 +28,6 @@
#include <stdio.h>
#include <errno.h>
#include <string.h>
-#include <assert.h>
#include "verify.h"
@@ -551,7 +550,7 @@ SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
{ ARRAY_FROM_GET_O }
scm_array_handle_release(&handle);
/* an error is still possible here if o and b don't match. */
- /* TODO copying like this wastes the handle, and the bounds matching
+ /* FIXME copying like this wastes the handle, and the bounds matching
behavior of array-copy! is not strict. */
scm_array_copy_x(b, o);
}
@@ -569,7 +568,6 @@ SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
}
#undef FUNC_NAME
-
#undef ARRAY_FROM_POS
#undef ARRAY_FROM_GET_O
@@ -948,6 +946,7 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
}
+
void
scm_init_arrays ()
{
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 473501e..49584b9 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -115,7 +115,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/r6rs-records-syntactic.test \
tests/r6rs-unicode.test \
tests/rnrs-libraries.test \
- tests/ramap.test \
+ tests/array-map.test \
tests/random.test \
tests/rdelim.test \
tests/reader.test \
diff --git a/test-suite/tests/array-map.test b/test-suite/tests/array-map.test
new file mode 100644
index 0000000..3095b78
--- /dev/null
+++ b/test-suite/tests/array-map.test
@@ -0,0 +1,540 @@
+;;;; array-map.test --- test array mapping functions -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2004, 2005, 2006, 2009, 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
+
+(define-module (test-suite test-array-map)
+ #:use-module (test-suite lib))
+
+(define exception:shape-mismatch
+ (cons 'misc-error ".*shape mismatch.*"))
+
+(define (array-row a i)
+ (make-shared-array a (lambda (j) (list i j))
+ (cadr (array-dimensions a))))
+
+(define (array-col a j)
+ (make-shared-array a (lambda (i) (list i j))
+ (car (array-dimensions a))))
+
+;;;
+;;; array-index-map!
+;;;
+
+(with-test-prefix "array-index-map!"
+
+ (pass-if "basic test"
+ (let ((nlst '()))
+ (array-index-map! (make-array #f '(1 1))
+ (lambda (n)
+ (set! nlst (cons n nlst))))
+ (equal? nlst '(1))))
+
+ (with-test-prefix "empty arrays"
+
+ (pass-if "all axes empty"
+ (array-index-map! (make-typed-array 'f64 0 0 0) (const 0))
+ (array-index-map! (make-typed-array 'b #t 0 0) (const #t))
+ (array-index-map! (make-typed-array #t 0 0 0) (const 0))
+ #t)
+
+ (pass-if "last axis empty"
+ (array-index-map! (make-typed-array 'f64 0 2 0) (const 0))
+ (array-index-map! (make-typed-array 'b #t 2 0) (const #t))
+ (array-index-map! (make-typed-array #t 0 2 0) (const 0))
+ #t)
+
+ ; the 'f64 cases fail in 2.0.9 with out-of-range.
+ (pass-if "axis empty, other than last"
+ (array-index-map! (make-typed-array 'f64 0 0 2) (const 0))
+ (array-index-map! (make-typed-array 'b #t 0 2) (const #t))
+ (array-index-map! (make-typed-array #t 0 0 2) (const 0))
+ #t))
+
+ (pass-if "rank 2"
+ (let ((a (make-array 0 2 2))
+ (b (make-array 0 2 2)))
+ (array-index-map! a (lambda (i j) i))
+ (array-index-map! b (lambda (i j) j))
+ (and (array-equal? a #2((0 0) (1 1)))
+ (array-equal? b #2((0 1) (0 1)))))))
+
+;;;
+;;; array-copy!
+;;;
+
+(with-test-prefix "array-copy!"
+
+ (with-test-prefix "empty arrays"
+
+ (pass-if "empty other than last, #t"
+ (let* ((b (make-array 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-copy! #2:0:2() c)
+ (array-equal? #2:0:2() c)))
+
+ (pass-if "empty other than last, 'f64"
+ (let* ((b (make-typed-array 'f64 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-copy! #2:0:2() c)
+ (array-equal? #2f64:0:2() c)))
+
+ ;; FIXME add empty, type 'b cases.
+
+ )
+
+ ;; note that it is the opposite of array-map!. This is, unfortunately,
+ ;; documented in the manual.
+
+ (pass-if "matching behavior I"
+ (let ((a #(1 2))
+ (b (make-array 0 3)))
+ (array-copy! a b)
+ (equal? b #(1 2 0))))
+
+ (pass-if-exception "matching behavior II" exception:shape-mismatch
+ (let ((a #(1 2 3))
+ (b (make-array 0 2)))
+ (array-copy! a b)
+ (equal? b #(1 2))))
+
+ ;; here both a & b are are unrollable down to the first axis, but the
+ ;; size mismatch limits unrolling to the last axis only.
+
+ (pass-if "matching behavior III"
+ (let ((a #3(((1 2) (3 4)) ((5 6) (7 8))))
+ (b (make-array 0 2 3 2)))
+ (array-copy! a b)
+ (array-equal? b #3(((1 2) (3 4) (0 0)) ((5 6) (7 8) (0 0))))))
+
+ (pass-if "rank 0"
+ (let ((a #0(99))
+ (b (make-array 0)))
+ (array-copy! a b)
+ (equal? b #0(99))))
+
+ (pass-if "rank 1"
+ (let* ((a #2((1 2) (3 4)))
+ (b (make-shared-array a (lambda (j) (list 1 j)) 2))
+ (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
+ (d (make-array 0 2))
+ (e (make-array 0 2)))
+ (array-copy! b d)
+ (array-copy! c e)
+ (and (equal? d #(3 4))
+ (equal? e #(4 2)))))
+
+ (pass-if "rank 2"
+ (let ((a #2((1 2) (3 4)))
+ (b (make-array 0 2 2))
+ (c (make-array 0 2 2))
+ (d (make-array 0 2 2))
+ (e (make-array 0 2 2)))
+ (array-copy! a b)
+ (array-copy! a (transpose-array c 1 0))
+ (array-copy! (transpose-array a 1 0) d)
+ (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
+ (and (equal? a #2((1 2) (3 4)))
+ (equal? b #2((1 2) (3 4)))
+ (equal? c #2((1 3) (2 4)))
+ (equal? d #2((1 3) (2 4)))
+ (equal? e #2((1 2) (3 4))))))
+
+ (pass-if "rank 2, discontinuous"
+ (let ((A #2((0 1) (2 3) (4 5)))
+ (B #2((10 11) (12 13) (14 15)))
+ (C #2((20) (21) (22)))
+ (X (make-array 0 3 5))
+ (piece (lambda (X w s)
+ (make-shared-array
+ X (lambda (i j) (list i (+ j s))) 3 w))))
+ (array-copy! A (piece X 2 0))
+ (array-copy! B (piece X 2 2))
+ (array-copy! C (piece X 1 4))
+ (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
+
+ (pass-if "null increments, not empty"
+ (let ((a (make-array 0 2 2)))
+ (array-copy! (make-shared-array #0(1) (lambda x '()) 2 2) a)
+ (array-equal? #2((1 1) (1 1))))))
+
+;;;
+;;; array-map!
+;;;
+
+(with-test-prefix "array-map!"
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (array-map!))
+
+ (pass-if-exception "one arg" exception:wrong-num-args
+ (array-map! (make-array #f 5)))
+
+ (with-test-prefix "no sources"
+
+ (pass-if "closure 0"
+ (array-map! (make-array #f 5) (lambda () #f))
+ #t)
+
+ (pass-if-exception "closure 1" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x) #f)))
+
+ (pass-if-exception "closure 2" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x y) #f)))
+
+ (pass-if-exception "subr_1" exception:wrong-num-args
+ (array-map! (make-array #f 5) length))
+
+ (pass-if-exception "subr_2" exception:wrong-num-args
+ (array-map! (make-array #f 5) logtest))
+
+ (pass-if-exception "subr_2o" exception:wrong-num-args
+ (array-map! (make-array #f 5) number->string))
+
+ (pass-if-exception "dsubr" exception:wrong-num-args
+ (array-map! (make-array #f 5) sqrt))
+
+ (pass-if "rpsubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a =)
+ (equal? a (make-array #t 5))))
+
+ (pass-if "asubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a +)
+ (equal? a (make-array 0 5))))
+
+ ;; in Guile 1.6.4 and earlier this resulted in a segv
+ (pass-if "noop"
+ (array-map! (make-array #f 5) noop)
+ #t))
+
+ (with-test-prefix "one source"
+
+ (pass-if-exception "closure 0" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda () #f)
+ (make-array #f 5)))
+
+ (pass-if "closure 1"
+ (let ((a (make-array #f 5)))
+ (array-map! a (lambda (x) 'foo) (make-array #f 5))
+ (equal? a (make-array 'foo 5))))
+
+ (pass-if-exception "closure 2" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x y) #f)
+ (make-array #f 5)))
+
+ (pass-if "subr_1"
+ (let ((a (make-array #f 5)))
+ (array-map! a length (make-array '(x y z) 5))
+ (equal? a (make-array 3 5))))
+
+ (pass-if-exception "subr_2" exception:wrong-num-args
+ (array-map! (make-array #f 5) logtest
+ (make-array 999 5)))
+
+ (pass-if "subr_2o"
+ (let ((a (make-array #f 5)))
+ (array-map! a number->string (make-array 99 5))
+ (equal? a (make-array "99" 5))))
+
+ (pass-if "dsubr"
+ (let ((a (make-array #f 5)))
+ (array-map! a sqrt (make-array 16.0 5))
+ (equal? a (make-array 4.0 5))))
+
+ (pass-if "rpsubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a = (make-array 0 5))
+ (equal? a (make-array #t 5))))
+
+ (pass-if "asubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a - (make-array 99 5))
+ (equal? a (make-array -99 5))))
+
+ ;; in Guile 1.6.5 and 1.6.6 this was an error
+ (pass-if "1+"
+ (let ((a (make-array #f 5)))
+ (array-map! a 1+ (make-array 123 5))
+ (equal? a (make-array 124 5))))
+
+ (pass-if "rank 0"
+ (let ((a #0(99))
+ (b (make-array 0)))
+ (array-map! b values a)
+ (equal? b #0(99))))
+
+ (pass-if "rank 2, discontinuous"
+ (let ((A #2((0 1) (2 3) (4 5)))
+ (B #2((10 11) (12 13) (14 15)))
+ (C #2((20) (21) (22)))
+ (X (make-array 0 3 5))
+ (piece (lambda (X w s)
+ (make-shared-array
+ X (lambda (i j) (list i (+ j s))) 3 w))))
+ (array-map! (piece X 2 0) values A)
+ (array-map! (piece X 2 2) values B)
+ (array-map! (piece X 1 4) values C)
+ (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
+
+ (pass-if "null increments, not empty"
+ (let ((a (make-array 0 2 2)))
+ (array-map! a values (make-shared-array #0(1) (lambda x '()) 2 2))
+ (array-equal? a #2((1 1) (1 1))))))
+
+ (with-test-prefix "two sources"
+
+ (pass-if-exception "closure 0" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda () #f)
+ (make-array #f 5) (make-array #f 5)))
+
+ (pass-if-exception "closure 1" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x) #f)
+ (make-array #f 5) (make-array #f 5)))
+
+ (pass-if "closure 2"
+ (let ((a (make-array #f 5)))
+ (array-map! a (lambda (x y) 'foo)
+ (make-array #f 5) (make-array #f 5))
+ (equal? a (make-array 'foo 5))))
+
+ (pass-if-exception "subr_1" exception:wrong-num-args
+ (array-map! (make-array #f 5) length
+ (make-array #f 5) (make-array #f 5)))
+
+ (pass-if "subr_2"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a logtest
+ (make-array 999 5) (make-array 999 5))
+ (equal? a (make-array #t 5))))
+
+ (pass-if "subr_2o"
+ (let ((a (make-array #f 5)))
+ (array-map! a number->string
+ (make-array 32 5) (make-array 16 5))
+ (equal? a (make-array "20" 5))))
+
+ (pass-if-exception "dsubr" exception:wrong-num-args
+ (let ((a (make-array #f 5)))
+ (array-map! a sqrt
+ (make-array 16.0 5) (make-array 16.0 5))
+ (equal? a (make-array 4.0 5))))
+
+ (pass-if "rpsubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a = (make-array 99 5) (make-array 77 5))
+ (equal? a (make-array #f 5))))
+
+ (pass-if "asubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a - (make-array 99 5) (make-array 11 5))
+ (equal? a (make-array 88 5))))
+
+ (pass-if "+"
+ (let ((a (make-array #f 4)))
+ (array-map! a + #(1 2 3 4) #(5 6 7 8))
+ (equal? a #(6 8 10 12))))
+
+ (pass-if "noncompact arrays 1"
+ (let ((a #2((0 1) (2 3)))
+ (c (make-array 0 2)))
+ (begin
+ (array-map! c + (array-row a 1) (array-row a 1))
+ (array-equal? c #(4 6)))))
+
+ (pass-if "noncompact arrays 2"
+ (let ((a #2((0 1) (2 3)))
+ (c (make-array 0 2)))
+ (begin
+ (array-map! c + (array-col a 1) (array-col a 1))
+ (array-equal? c #(2 6)))))
+
+ (pass-if "noncompact arrays 3"
+ (let ((a #2((0 1) (2 3)))
+ (c (make-array 0 2)))
+ (begin
+ (array-map! c + (array-col a 1) (array-row a 1))
+ (array-equal? c #(3 6)))))
+
+ (pass-if "noncompact arrays 4"
+ (let ((a #2((0 1) (2 3)))
+ (c (make-array 0 2)))
+ (begin
+ (array-map! c + (array-col a 1) (array-row a 1))
+ (array-equal? c #(3 6)))))
+
+ (pass-if "offset arrays 1"
+ (let ((a #2@1@-3((0 1) (2 3)))
+ (c (make-array 0 '(1 2) '(-3 -2))))
+ (begin
+ (array-map! c + a a)
+ (array-equal? c #2@1@-3((0 2) (4 6)))))))
+
+ ;; note that array-copy! has the opposite behavior.
+
+ (pass-if-exception "matching behavior I" exception:shape-mismatch
+ (let ((a #(1 2))
+ (b (make-array 0 3)))
+ (array-map! b values a)
+ (equal? b #(1 2 0))))
+
+ (pass-if "matching behavior II"
+ (let ((a #(1 2 3))
+ (b (make-array 0 2)))
+ (array-map! b values a)
+ (equal? b #(1 2))))
+
+ ;; here both a & b are are unrollable down to the first axis, but the
+ ;; size mismatch limits unrolling to the last axis only.
+
+ (pass-if "matching behavior III"
+ (let ((a #3(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12))))
+ (b (make-array 0 2 2 2)))
+ (array-map! b values a)
+ (array-equal? b #3(((1 2) (3 4)) ((7 8) (9 10)))))))
+
+;;;
+;;; array-for-each
+;;;
+
+(with-test-prefix "array-for-each"
+
+ (with-test-prefix "1 source"
+ (pass-if-equal "rank 0"
+ '(99)
+ (let* ((a #0(99))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
+ (pass-if-equal "noncompact array"
+ '(3 2 1 0)
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
+ (pass-if-equal "vector"
+ '(3 2 1 0)
+ (let* ((a #(0 1 2 3))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
+ (pass-if-equal "shared array"
+ '(3 2 1 0)
+ (let* ((a #2((0 1) (2 3)))
+ (a' (make-shared-array a
+ (lambda (x)
+ (list (quotient x 4)
+ (modulo x 4)))
+ 4))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a')
+ l)))
+
+ (with-test-prefix "3 sources"
+ (pass-if-equal "noncompact arrays 1"
+ '((3 1 3) (2 0 2))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1))
+ l))
+
+ (pass-if-equal "noncompact arrays 2"
+ '((3 3 3) (2 2 1))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
+ l))
+
+ (pass-if-equal "noncompact arrays 3"
+ '((3 3 3) (2 1 1))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
+ l))
+
+ (pass-if-equal "noncompact arrays 4"
+ '((3 2 3) (1 0 2))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
+ l)))
+
+ (with-test-prefix "empty arrays"
+
+ (pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
+ (let* ((a (list))
+ (b (make-array 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-for-each (lambda (c) (set! a (cons c a))) c)
+ (equal? a '())))
+
+ (pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
+ (let* ((a (list))
+ (b (make-typed-array 'f64 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-for-each (lambda (c) (set! a (cons c a))) c)
+ (equal? a '())))
+
+ ;; FIXME add type 'b cases.
+
+ (pass-if-exception "empty arrays shape check" exception:shape-mismatch
+ (let* ((a (list))
+ (b (make-typed-array 'f64 0 0 2))
+ (c (make-typed-array 'f64 0 2 0)))
+ (array-for-each (lambda (b c) (set! a (cons* b c a))) b c)))))
+
+;;;
+;;; array-for-each-cell
+;;;
+
+(with-test-prefix "array-for-each-cell"
+
+ (pass-if-equal "1 argument frame rank 1"
+ #2((1 3 9) (2 7 8))
+ (let* ((a (list->array 2 '((9 1 3) (7 8 2)))))
+ (array-for-each-cell 1 (lambda (a) (sort! a <)) a)
+ a))
+
+ (pass-if-equal "2 arguments frame rank 1"
+ #f64(8 -1)
+ (let* ((x (list->typed-array 'f64 2 '((9 1) (7 8))))
+ (y (f64vector 99 99)))
+ (array-for-each-cell 1 (lambda (y x) (array-set! y (- (array-ref x 0) (array-ref x 1)))) y x)
+ y))
+
+ (pass-if-equal "regression: zero-sized frame loop without unrolling"
+ 99
+ (let* ((x 99)
+ (o (make-array 0. 0 3 2)))
+ (array-for-each-cell 2
+ (lambda (o a0 a1)
+ (set! x 0))
+ o
+ (make-shared-array (make-array 1. 0 1) (const '(0 0)) 0 3)
+ (make-array 2. 0 3))
+ x)))
diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
deleted file mode 100644
index bd8a434..0000000
--- a/test-suite/tests/ramap.test
+++ /dev/null
@@ -1,509 +0,0 @@
-;;;; ramap.test --- test array mapping functions -*- scheme -*-
-;;;;
-;;;; Copyright (C) 2004, 2005, 2006, 2009, 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
-
-(define-module (test-suite test-ramap)
- #:use-module (test-suite lib))
-
-(define exception:shape-mismatch
- (cons 'misc-error ".*shape mismatch.*"))
-
-(define (array-row a i)
- (make-shared-array a (lambda (j) (list i j))
- (cadr (array-dimensions a))))
-
-(define (array-col a j)
- (make-shared-array a (lambda (i) (list i j))
- (car (array-dimensions a))))
-
-;;;
-;;; array-index-map!
-;;;
-
-(with-test-prefix "array-index-map!"
-
- (pass-if "basic test"
- (let ((nlst '()))
- (array-index-map! (make-array #f '(1 1))
- (lambda (n)
- (set! nlst (cons n nlst))))
- (equal? nlst '(1))))
-
- (with-test-prefix "empty arrays"
-
- (pass-if "all axes empty"
- (array-index-map! (make-typed-array 'f64 0 0 0) (const 0))
- (array-index-map! (make-typed-array 'b #t 0 0) (const #t))
- (array-index-map! (make-typed-array #t 0 0 0) (const 0))
- #t)
-
- (pass-if "last axis empty"
- (array-index-map! (make-typed-array 'f64 0 2 0) (const 0))
- (array-index-map! (make-typed-array 'b #t 2 0) (const #t))
- (array-index-map! (make-typed-array #t 0 2 0) (const 0))
- #t)
-
- ; the 'f64 cases fail in 2.0.9 with out-of-range.
- (pass-if "axis empty, other than last"
- (array-index-map! (make-typed-array 'f64 0 0 2) (const 0))
- (array-index-map! (make-typed-array 'b #t 0 2) (const #t))
- (array-index-map! (make-typed-array #t 0 0 2) (const 0))
- #t))
-
- (pass-if "rank 2"
- (let ((a (make-array 0 2 2))
- (b (make-array 0 2 2)))
- (array-index-map! a (lambda (i j) i))
- (array-index-map! b (lambda (i j) j))
- (and (array-equal? a #2((0 0) (1 1)))
- (array-equal? b #2((0 1) (0 1)))))))
-
-;;;
-;;; array-copy!
-;;;
-
-(with-test-prefix "array-copy!"
-
- (with-test-prefix "empty arrays"
-
- (pass-if "empty other than last, #t"
- (let* ((b (make-array 0 2 2))
- (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
- (array-copy! #2:0:2() c)
- (array-equal? #2:0:2() c)))
-
- (pass-if "empty other than last, 'f64"
- (let* ((b (make-typed-array 'f64 0 2 2))
- (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
- (array-copy! #2:0:2() c)
- (array-equal? #2f64:0:2() c)))
-
- ;; FIXME add empty, type 'b cases.
-
- )
-
- ;; note that it is the opposite of array-map!. This is, unfortunately,
- ;; documented in the manual.
-
- (pass-if "matching behavior I"
- (let ((a #(1 2))
- (b (make-array 0 3)))
- (array-copy! a b)
- (equal? b #(1 2 0))))
-
- (pass-if-exception "matching behavior II" exception:shape-mismatch
- (let ((a #(1 2 3))
- (b (make-array 0 2)))
- (array-copy! a b)
- (equal? b #(1 2))))
-
- ;; here both a & b are are unrollable down to the first axis, but the
- ;; size mismatch limits unrolling to the last axis only.
-
- (pass-if "matching behavior III"
- (let ((a #3(((1 2) (3 4)) ((5 6) (7 8))))
- (b (make-array 0 2 3 2)))
- (array-copy! a b)
- (array-equal? b #3(((1 2) (3 4) (0 0)) ((5 6) (7 8) (0 0))))))
-
- (pass-if "rank 0"
- (let ((a #0(99))
- (b (make-array 0)))
- (array-copy! a b)
- (equal? b #0(99))))
-
- (pass-if "rank 1"
- (let* ((a #2((1 2) (3 4)))
- (b (make-shared-array a (lambda (j) (list 1 j)) 2))
- (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
- (d (make-array 0 2))
- (e (make-array 0 2)))
- (array-copy! b d)
- (array-copy! c e)
- (and (equal? d #(3 4))
- (equal? e #(4 2)))))
-
- (pass-if "rank 2"
- (let ((a #2((1 2) (3 4)))
- (b (make-array 0 2 2))
- (c (make-array 0 2 2))
- (d (make-array 0 2 2))
- (e (make-array 0 2 2)))
- (array-copy! a b)
- (array-copy! a (transpose-array c 1 0))
- (array-copy! (transpose-array a 1 0) d)
- (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
- (and (equal? a #2((1 2) (3 4)))
- (equal? b #2((1 2) (3 4)))
- (equal? c #2((1 3) (2 4)))
- (equal? d #2((1 3) (2 4)))
- (equal? e #2((1 2) (3 4))))))
-
- (pass-if "rank 2, discontinuous"
- (let ((A #2((0 1) (2 3) (4 5)))
- (B #2((10 11) (12 13) (14 15)))
- (C #2((20) (21) (22)))
- (X (make-array 0 3 5))
- (piece (lambda (X w s)
- (make-shared-array
- X (lambda (i j) (list i (+ j s))) 3 w))))
- (array-copy! A (piece X 2 0))
- (array-copy! B (piece X 2 2))
- (array-copy! C (piece X 1 4))
- (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
-
- (pass-if "null increments, not empty"
- (let ((a (make-array 0 2 2)))
- (array-copy! (make-shared-array #0(1) (lambda x '()) 2 2) a)
- (array-equal? #2((1 1) (1 1))))))
-
-;;;
-;;; array-map!
-;;;
-
-(with-test-prefix "array-map!"
-
- (pass-if-exception "no args" exception:wrong-num-args
- (array-map!))
-
- (pass-if-exception "one arg" exception:wrong-num-args
- (array-map! (make-array #f 5)))
-
- (with-test-prefix "no sources"
-
- (pass-if "closure 0"
- (array-map! (make-array #f 5) (lambda () #f))
- #t)
-
- (pass-if-exception "closure 1" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda (x) #f)))
-
- (pass-if-exception "closure 2" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda (x y) #f)))
-
- (pass-if-exception "subr_1" exception:wrong-num-args
- (array-map! (make-array #f 5) length))
-
- (pass-if-exception "subr_2" exception:wrong-num-args
- (array-map! (make-array #f 5) logtest))
-
- (pass-if-exception "subr_2o" exception:wrong-num-args
- (array-map! (make-array #f 5) number->string))
-
- (pass-if-exception "dsubr" exception:wrong-num-args
- (array-map! (make-array #f 5) sqrt))
-
- (pass-if "rpsubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a =)
- (equal? a (make-array #t 5))))
-
- (pass-if "asubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a +)
- (equal? a (make-array 0 5))))
-
- ;; in Guile 1.6.4 and earlier this resulted in a segv
- (pass-if "noop"
- (array-map! (make-array #f 5) noop)
- #t))
-
- (with-test-prefix "one source"
-
- (pass-if-exception "closure 0" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda () #f)
- (make-array #f 5)))
-
- (pass-if "closure 1"
- (let ((a (make-array #f 5)))
- (array-map! a (lambda (x) 'foo) (make-array #f 5))
- (equal? a (make-array 'foo 5))))
-
- (pass-if-exception "closure 2" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda (x y) #f)
- (make-array #f 5)))
-
- (pass-if "subr_1"
- (let ((a (make-array #f 5)))
- (array-map! a length (make-array '(x y z) 5))
- (equal? a (make-array 3 5))))
-
- (pass-if-exception "subr_2" exception:wrong-num-args
- (array-map! (make-array #f 5) logtest
- (make-array 999 5)))
-
- (pass-if "subr_2o"
- (let ((a (make-array #f 5)))
- (array-map! a number->string (make-array 99 5))
- (equal? a (make-array "99" 5))))
-
- (pass-if "dsubr"
- (let ((a (make-array #f 5)))
- (array-map! a sqrt (make-array 16.0 5))
- (equal? a (make-array 4.0 5))))
-
- (pass-if "rpsubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a = (make-array 0 5))
- (equal? a (make-array #t 5))))
-
- (pass-if "asubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a - (make-array 99 5))
- (equal? a (make-array -99 5))))
-
- ;; in Guile 1.6.5 and 1.6.6 this was an error
- (pass-if "1+"
- (let ((a (make-array #f 5)))
- (array-map! a 1+ (make-array 123 5))
- (equal? a (make-array 124 5))))
-
- (pass-if "rank 0"
- (let ((a #0(99))
- (b (make-array 0)))
- (array-map! b values a)
- (equal? b #0(99))))
-
- (pass-if "rank 2, discontinuous"
- (let ((A #2((0 1) (2 3) (4 5)))
- (B #2((10 11) (12 13) (14 15)))
- (C #2((20) (21) (22)))
- (X (make-array 0 3 5))
- (piece (lambda (X w s)
- (make-shared-array
- X (lambda (i j) (list i (+ j s))) 3 w))))
- (array-map! (piece X 2 0) values A)
- (array-map! (piece X 2 2) values B)
- (array-map! (piece X 1 4) values C)
- (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
-
- (pass-if "null increments, not empty"
- (let ((a (make-array 0 2 2)))
- (array-map! a values (make-shared-array #0(1) (lambda x '()) 2 2))
- (array-equal? a #2((1 1) (1 1))))))
-
- (with-test-prefix "two sources"
-
- (pass-if-exception "closure 0" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda () #f)
- (make-array #f 5) (make-array #f 5)))
-
- (pass-if-exception "closure 1" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda (x) #f)
- (make-array #f 5) (make-array #f 5)))
-
- (pass-if "closure 2"
- (let ((a (make-array #f 5)))
- (array-map! a (lambda (x y) 'foo)
- (make-array #f 5) (make-array #f 5))
- (equal? a (make-array 'foo 5))))
-
- (pass-if-exception "subr_1" exception:wrong-num-args
- (array-map! (make-array #f 5) length
- (make-array #f 5) (make-array #f 5)))
-
- (pass-if "subr_2"
- (let ((a (make-array 'foo 5)))
- (array-map! a logtest
- (make-array 999 5) (make-array 999 5))
- (equal? a (make-array #t 5))))
-
- (pass-if "subr_2o"
- (let ((a (make-array #f 5)))
- (array-map! a number->string
- (make-array 32 5) (make-array 16 5))
- (equal? a (make-array "20" 5))))
-
- (pass-if-exception "dsubr" exception:wrong-num-args
- (let ((a (make-array #f 5)))
- (array-map! a sqrt
- (make-array 16.0 5) (make-array 16.0 5))
- (equal? a (make-array 4.0 5))))
-
- (pass-if "rpsubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a = (make-array 99 5) (make-array 77 5))
- (equal? a (make-array #f 5))))
-
- (pass-if "asubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a - (make-array 99 5) (make-array 11 5))
- (equal? a (make-array 88 5))))
-
- (pass-if "+"
- (let ((a (make-array #f 4)))
- (array-map! a + #(1 2 3 4) #(5 6 7 8))
- (equal? a #(6 8 10 12))))
-
- (pass-if "noncompact arrays 1"
- (let ((a #2((0 1) (2 3)))
- (c (make-array 0 2)))
- (begin
- (array-map! c + (array-row a 1) (array-row a 1))
- (array-equal? c #(4 6)))))
-
- (pass-if "noncompact arrays 2"
- (let ((a #2((0 1) (2 3)))
- (c (make-array 0 2)))
- (begin
- (array-map! c + (array-col a 1) (array-col a 1))
- (array-equal? c #(2 6)))))
-
- (pass-if "noncompact arrays 3"
- (let ((a #2((0 1) (2 3)))
- (c (make-array 0 2)))
- (begin
- (array-map! c + (array-col a 1) (array-row a 1))
- (array-equal? c #(3 6)))))
-
- (pass-if "noncompact arrays 4"
- (let ((a #2((0 1) (2 3)))
- (c (make-array 0 2)))
- (begin
- (array-map! c + (array-col a 1) (array-row a 1))
- (array-equal? c #(3 6)))))
-
- (pass-if "offset arrays 1"
- (let ((a #2@1@-3((0 1) (2 3)))
- (c (make-array 0 '(1 2) '(-3 -2))))
- (begin
- (array-map! c + a a)
- (array-equal? c #2@1@-3((0 2) (4 6)))))))
-
- ;; note that array-copy! has the opposite behavior.
-
- (pass-if-exception "matching behavior I" exception:shape-mismatch
- (let ((a #(1 2))
- (b (make-array 0 3)))
- (array-map! b values a)
- (equal? b #(1 2 0))))
-
- (pass-if "matching behavior II"
- (let ((a #(1 2 3))
- (b (make-array 0 2)))
- (array-map! b values a)
- (equal? b #(1 2))))
-
- ;; here both a & b are are unrollable down to the first axis, but the
- ;; size mismatch limits unrolling to the last axis only.
-
- (pass-if "matching behavior III"
- (let ((a #3(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12))))
- (b (make-array 0 2 2 2)))
- (array-map! b values a)
- (array-equal? b #3(((1 2) (3 4)) ((7 8) (9 10)))))))
-
-;;;
-;;; array-for-each
-;;;
-
-(with-test-prefix "array-for-each"
-
- (with-test-prefix "1 source"
- (pass-if-equal "rank 0"
- '(99)
- (let* ((a #0(99))
- (l '())
- (p (lambda (x) (set! l (cons x l)))))
- (array-for-each p a)
- l))
-
- (pass-if-equal "noncompact array"
- '(3 2 1 0)
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (p (lambda (x) (set! l (cons x l)))))
- (array-for-each p a)
- l))
-
- (pass-if-equal "vector"
- '(3 2 1 0)
- (let* ((a #(0 1 2 3))
- (l '())
- (p (lambda (x) (set! l (cons x l)))))
- (array-for-each p a)
- l))
-
- (pass-if-equal "shared array"
- '(3 2 1 0)
- (let* ((a #2((0 1) (2 3)))
- (a' (make-shared-array a
- (lambda (x)
- (list (quotient x 4)
- (modulo x 4)))
- 4))
- (l '())
- (p (lambda (x) (set! l (cons x l)))))
- (array-for-each p a')
- l)))
-
- (with-test-prefix "3 sources"
- (pass-if-equal "noncompact arrays 1"
- '((3 1 3) (2 0 2))
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1))
- l))
-
- (pass-if-equal "noncompact arrays 2"
- '((3 3 3) (2 2 1))
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
- l))
-
- (pass-if-equal "noncompact arrays 3"
- '((3 3 3) (2 1 1))
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
- l))
-
- (pass-if-equal "noncompact arrays 4"
- '((3 2 3) (1 0 2))
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
- l)))
-
- (with-test-prefix "empty arrays"
-
- (pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
- (let* ((a (list))
- (b (make-array 0 2 2))
- (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
- (array-for-each (lambda (c) (set! a (cons c a))) c)
- (equal? a '())))
-
- (pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
- (let* ((a (list))
- (b (make-typed-array 'f64 0 2 2))
- (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
- (array-for-each (lambda (c) (set! a (cons c a))) c)
- (equal? a '())))
-
- ;; FIXME add type 'b cases.
-
- (pass-if-exception "empty arrays shape check" exception:shape-mismatch
- (let* ((a (list))
- (b (make-typed-array 'f64 0 0 2))
- (c (make-typed-array 'f64 0 2 0)))
- (array-for-each (lambda (b c) (set! a (cons* b c a))) b c)))))
--
2.7.3
[-- Attachment #13: Type: text/plain, Size: 4 bytes --]
^ permalink raw reply related [flat|nested] 16+ messages in thread
* Re: [PATCH] Re: Patchset related to array functions
2016-07-14 15:41 ` [PATCH] " Daniel Llorens
@ 2016-07-14 18:20 ` Andy Wingo
2016-07-15 12:54 ` [PATCH] " Daniel Llorens
2016-08-31 9:28 ` [PATCH] " Andy Wingo
2016-07-15 10:52 ` Chris Vine
1 sibling, 2 replies; 16+ messages in thread
From: Andy Wingo @ 2016-07-14 18:20 UTC (permalink / raw)
To: Daniel Llorens; +Cc: guile-devel
On Thu 14 Jul 2016 17:41, Daniel Llorens <daniel.llorens@bluewin.ch> writes:
> On 14 Jul 2016, at 11:46, Andy Wingo <wingo@pobox.com> wrote:
>
>> (1) Can we support C99 on all targets we care about?
>
> Emacs
http://git.savannah.gnu.org/cgit/emacs.git/tree/configure.ac#n764
"Emacs needs C99". Sweet! We check this point off.
>> (2) Can we use C99 in our public interface, or just internally? If we
>> use it publically, what should we change? No more scm_t_uint8 I
>> hope, besides for back-compat? This patch set does not have to
>> include these changes, but we should have a plan.
>
> I think we'd want C89/C90 users to still be able to #include <libguile.h>. Dunno.
Really? I would *love* to be able to say "just use c99, or at least
something with stdint.h". Apparently gcc's default has been gnu11 for a
while...
>> (3) Most importantly, what is the impact on inlining? See the comment
>> in __scm.h around line 165.
>
> Apparently the standard practice in C99 is to put inline definition in
> the header and extern declaration in the .c, while with ‘Guile inline’
> both SCM_INLINE and SCM_INLINE_IMPLEMENTATION are in the header.
I believe that Guile tries to do this as well. By default the headers
define inline definitions and there is the extern inline declaration,
and then inline.c re-includes those headers with
SCM_INLINE_C_IMPLEMENTING_INLINES defined which reifies the definitions
so that the symbols end up in the .so. But this landscape is quite
gnarly. The specific implementation actually relies on the gnu_inline
attribute, so I guess we are using GNU extensions either way, at least
when compiled with GCC...
> I can try to fix Guile to follow the C99 practice and remove most of
> the #define guards. Would a patch doing this be accepted? I'd welcome
> advice on how to test such a patch. E.g. with both -O2 and -O0 or
> so. I'm mostly a C++ programmer and I don't want to mess anything up.
I think the concerns are:
(1) Do inlined definitions get inlined?
(2) Are external definitions reified as well?
(3) Do we avoid reifying definitions in each compilation unit?
(4) Can you dlsym() an inline function?
All these answers should be yes. No benchmarking needed, just
inspection of the build artifacts under different configurations.
>> If you want your patch set to depend on C99 that's fine, but you have to
>> answer these questions first for the project as a whole and get some
>> consensus.
>
> That is a very reasonable viewpoint. Since C99 was just a minor
> convenience to me, I withdraw that particular patch. I have rebased
> everything to avoid the C99 requirement. Revised patchset attached.
Tx, will review separately. In the future would you mind please
spamming the list with these patches as a thread of multiple mails, as
git-send-email would do? That makes it easy for me to review just one
patch, say LGTM or whatever on that patch, then work on other patches on
other days. But I will make an initial pass on this mail, later though
:)
Andy
^ permalink raw reply [flat|nested] 16+ messages in thread
* Re: [PATCH] Re: Patchset related to array functions
2016-07-14 15:41 ` [PATCH] " Daniel Llorens
2016-07-14 18:20 ` Andy Wingo
@ 2016-07-15 10:52 ` Chris Vine
2016-07-16 9:07 ` Andy Wingo
1 sibling, 1 reply; 16+ messages in thread
From: Chris Vine @ 2016-07-15 10:52 UTC (permalink / raw)
To: guile-devel
On Thu, 14 Jul 2016 17:41:45 +0200
Daniel Llorens <daniel.llorens@bluewin.ch> wrote:
[snip]
> I think we'd want C89/C90 users to still be able to #include
> <libguile.h>. Dunno.
libguile.h can also at present be included in C++89/03/11/14 code by
design - all the necessary "extern C" stuff is there. I would hope
that would continue, but some C99 things, such as variable length
arrays, designated initializers, the _Complex type, the restrict
qualifier and compound literals (except in C++11/14) are not available.
There is no problem with using these in libguile implementation
(*.c) code, but including them in headers will generally stop the
headers being usable in C++ code. Having said that, g++ happens to
accept some of these in C++ code as an extension.
Chris
^ permalink raw reply [flat|nested] 16+ messages in thread
* Re: [PATCH] Patchset related to array functions
2016-07-14 18:20 ` Andy Wingo
@ 2016-07-15 12:54 ` Daniel Llorens
2016-08-31 9:28 ` [PATCH] " Andy Wingo
1 sibling, 0 replies; 16+ messages in thread
From: Daniel Llorens @ 2016-07-15 12:54 UTC (permalink / raw)
To: Andy Wingo; +Cc: guile-devel
On 14 Jul 2016, at 20:20, Andy Wingo <wingo@pobox.com> wrote:
> I think the concerns are:
>
> (1) Do inlined definitions get inlined?
> (2) Are external definitions reified as well?
> (3) Do we avoid reifying definitions in each compilation unit?
> (4) Can you dlsym() an inline function?
>
> All these answers should be yes. No benchmarking needed, just
> inspection of the build artifacts under different configurations.
Right. I might give this a try. But IMO neither this inline issue nor the stdint issue nor other things that we might want to improve thanks to C99 are necessary to simply enable using C99 in the source. The SCM_INLINE_etc defines work as they are and everything else seems to be backwards compatible. The fixes are more likely to happen once the C99 switch has been flipped.
> Tx, will review separately. In the future would you mind please
> spamming the list with these patches as a thread of multiple mails, as
> git-send-email would do? That makes it easy for me to review just one
> patch, say LGTM or whatever on that patch, then work on other patches on
> other days. But I will make an initial pass on this mail, later though
> :)
I didn't know about git-send-mail, it's neat. It should be mentioned in HACKING! I can resend the patches in that format, just let me know.
^ permalink raw reply [flat|nested] 16+ messages in thread
* Re: Patchset related to array functions
2016-07-14 9:46 ` Andy Wingo
2016-07-14 15:41 ` [PATCH] " Daniel Llorens
@ 2016-07-15 17:41 ` Mark H Weaver
2016-07-16 8:30 ` Andy Wingo
1 sibling, 1 reply; 16+ messages in thread
From: Mark H Weaver @ 2016-07-15 17:41 UTC (permalink / raw)
To: Andy Wingo; +Cc: guile-devel, Daniel Llorens
Andy Wingo <wingo@pobox.com> writes:
> (2) Can we use C99 in our public interface, or just internally? If we
> use it publically, what should we change? No more scm_t_uint8 I
> hope, besides for back-compat? This patch set does not have to
> include these changes, but we should have a plan.
Good question! Since Emacs 25 requires C99, I think it's reasonable for
us to also require C99 *internally*, but whether we can reasonably
assume C99 in our public headers is far less clear. Existing programs
that include <libguile.h> might have conflicting requirements for the C
dialect options passed to the compiler. Even if there's no conflict,
developers may resent being asked to change their C dialect options.
Thoughts?
Mark
^ permalink raw reply [flat|nested] 16+ messages in thread
* Re: Patchset related to array functions
2016-07-15 17:41 ` Mark H Weaver
@ 2016-07-16 8:30 ` Andy Wingo
0 siblings, 0 replies; 16+ messages in thread
From: Andy Wingo @ 2016-07-16 8:30 UTC (permalink / raw)
To: Mark H Weaver; +Cc: guile-devel, Daniel Llorens
On Fri 15 Jul 2016 19:41, Mark H Weaver <mhw@netris.org> writes:
> Andy Wingo <wingo@pobox.com> writes:
>
>> (2) Can we use C99 in our public interface, or just internally? If we
>> use it publically, what should we change? No more scm_t_uint8 I
>> hope, besides for back-compat? This patch set does not have to
>> include these changes, but we should have a plan.
>
> Good question! Since Emacs 25 requires C99, I think it's reasonable for
> us to also require C99 *internally*, but whether we can reasonably
> assume C99 in our public headers is far less clear. Existing programs
> that include <libguile.h> might have conflicting requirements for the C
> dialect options passed to the compiler. Even if there's no conflict,
> developers may resent being asked to change their C dialect options.
>
> Thoughts?
Yeah I dunno :) I suppose requiring stdint.h would be possible though
without requiring support for new language features. So that's an
intermediate point.
Since building against Guile 2.2 is an opt-in thing (with parallel
installation and all), I think at some point it's reasonable to say "you
can stay with Guile 2.0, but if you upgrade you need to support a C
standard released within the last 20 years" :) That point may be now;
not sure.
Andy
^ permalink raw reply [flat|nested] 16+ messages in thread
* Re: [PATCH] Re: Patchset related to array functions
2016-07-15 10:52 ` Chris Vine
@ 2016-07-16 9:07 ` Andy Wingo
2016-07-16 10:34 ` Chris Vine
0 siblings, 1 reply; 16+ messages in thread
From: Andy Wingo @ 2016-07-16 9:07 UTC (permalink / raw)
To: Chris Vine; +Cc: guile-devel
On Fri 15 Jul 2016 12:52, Chris Vine <chris@cvine.freeserve.co.uk> writes:
> On Thu, 14 Jul 2016 17:41:45 +0200
> Daniel Llorens <daniel.llorens@bluewin.ch> wrote:
> [snip]
>> I think we'd want C89/C90 users to still be able to #include
>> <libguile.h>. Dunno.
>
> libguile.h can also at present be included in C++89/03/11/14 code by
> design - all the necessary "extern C" stuff is there. I would hope
> that would continue, but some C99 things, such as variable length
> arrays, designated initializers, the _Complex type, the restrict
> qualifier and compound literals (except in C++11/14) are not available.
>
> There is no problem with using these in libguile implementation
> (*.c) code, but including them in headers will generally stop the
> headers being usable in C++ code. Having said that, g++ happens to
> accept some of these in C++ code as an extension.
Good points, all. Thanks for this list Chris. I don't think we need
anything in your list at present. I would like stdint.h though :)
Andy
^ permalink raw reply [flat|nested] 16+ messages in thread
* Re: [PATCH] Re: Patchset related to array functions
2016-07-16 9:07 ` Andy Wingo
@ 2016-07-16 10:34 ` Chris Vine
0 siblings, 0 replies; 16+ messages in thread
From: Chris Vine @ 2016-07-16 10:34 UTC (permalink / raw)
To: guile-devel
On Sat, 16 Jul 2016 11:07:40 +0200
Andy Wingo <wingo@pobox.com> wrote:
[snip]
> I would like stdint.h though :)
I agree. stdint.h is required by C++11, Appendix D5, to be available
in C++11 and later, with the same meaning as in C99, but in practice it
was available before then. It is provided by gcc-4.4 with the
-std=c++0x or -std=c99 flags for example (gcc-4.4 is the oldest compiler
I have installed, which I keep for test purposes).
I think it is reasonable to assume these days that any reasonable
compiler implementation will have the C99 extended integer types
available to it, including the optional ones so far as the architecture
supports them.
Chris
^ permalink raw reply [flat|nested] 16+ messages in thread
* Re: [PATCH] Re: Patchset related to array functions
2016-07-14 18:20 ` Andy Wingo
2016-07-15 12:54 ` [PATCH] " Daniel Llorens
@ 2016-08-31 9:28 ` Andy Wingo
2016-08-31 9:46 ` Andy Wingo
1 sibling, 1 reply; 16+ messages in thread
From: Andy Wingo @ 2016-08-31 9:28 UTC (permalink / raw)
To: Daniel Llorens; +Cc: guile-devel
Hi :)
Hope you had a good holiday.
On Thu 14 Jul 2016 20:20, Andy Wingo <wingo@pobox.com> writes:
> I think the concerns are:
>
> (1) Do inlined definitions get inlined?
> (2) Are external definitions reified as well?
> (3) Do we avoid reifying definitions in each compilation unit?
> (4) Can you dlsym() an inline function?
>
> All these answers should be yes. No benchmarking needed, just
> inspection of the build artifacts under different configurations.
I want to be able to use C11 atomics in Guile, internally. I think
externally as far as the interface goes we can probably upgrade to C99
given that even Emacs uses it these days. I will try to answer these
four questions with GCC with C89 and C99, and if the answers are good I
will upgrade to C99 first, for the build.
Andy
^ permalink raw reply [flat|nested] 16+ messages in thread
* Re: [PATCH] Re: Patchset related to array functions
2016-08-31 9:28 ` [PATCH] " Andy Wingo
@ 2016-08-31 9:46 ` Andy Wingo
2016-08-31 11:36 ` [PATCH] " Daniel Llorens
2016-08-31 14:45 ` [PATCH] " Eli Zaretskii
0 siblings, 2 replies; 16+ messages in thread
From: Andy Wingo @ 2016-08-31 9:46 UTC (permalink / raw)
To: Daniel Llorens; +Cc: guile-devel
On Wed 31 Aug 2016 11:28, Andy Wingo <wingo@pobox.com> writes:
> On Thu 14 Jul 2016 20:20, Andy Wingo <wingo@pobox.com> writes:
>
>> I think the concerns are:
>>
>> (1) Do inlined definitions get inlined?
>> (2) Are external definitions reified as well?
>> (3) Do we avoid reifying definitions in each compilation unit?
>> (4) Can you dlsym() an inline function?
>>
>> All these answers should be yes. No benchmarking needed, just
>> inspection of the build artifacts under different configurations.
>
> I want to be able to use C11 atomics in Guile, internally. I think
> externally as far as the interface goes we can probably upgrade to C99
> given that even Emacs uses it these days. I will try to answer these
> four questions with GCC with C89 and C99, and if the answers are good I
> will upgrade to C99 first, for the build.
Hah! Turns out we have been compiling in GCC's default mode the whole
time, which is gnu11. I suspect many users have been doing that too.
We might as well go ahead and require C99 internally plus the C11
features we want. Again for the external interface (stdint.h et al) we
can also probably require C99 for Guile 2.2, so that we can use uint32_t
and not scm_t_uint32.
Andy
^ permalink raw reply [flat|nested] 16+ messages in thread
* Re: [PATCH] Patchset related to array functions
2016-08-31 9:46 ` Andy Wingo
@ 2016-08-31 11:36 ` Daniel Llorens
2016-08-31 14:45 ` [PATCH] " Eli Zaretskii
1 sibling, 0 replies; 16+ messages in thread
From: Daniel Llorens @ 2016-08-31 11:36 UTC (permalink / raw)
To: Andy Wingo; +Cc: guile-devel
On 31 Aug 2016, at 11:46, Andy Wingo <wingo@pobox.com> wrote:
> On Wed 31 Aug 2016 11:28, Andy Wingo <wingo@pobox.com> writes:
>
>> On Thu 14 Jul 2016 20:20, Andy Wingo <wingo@pobox.com> writes:
>>
>>> I think the concerns are:
>>>
>>> (1) Do inlined definitions get inlined?
>>> (2) Are external definitions reified as well?
>>> (3) Do we avoid reifying definitions in each compilation unit?
>>> (4) Can you dlsym() an inline function?
>>>
>>> All these answers should be yes. No benchmarking needed, just
>>> inspection of the build artifacts under different configurations.
>>
>> I want to be able to use C11 atomics in Guile, internally. I think
>> externally as far as the interface goes we can probably upgrade to C99
>> given that even Emacs uses it these days. I will try to answer these
>> four questions with GCC with C89 and C99, and if the answers are good I
>> will upgrade to C99 first, for the build.
>
> Hah! Turns out we have been compiling in GCC's default mode the whole
> time, which is gnu11. I suspect many users have been doing that too.
> We might as well go ahead and require C99 internally plus the C11
> features we want. Again for the external interface (stdint.h et al) we
> can also probably require C99 for Guile 2.2, so that we can use uint32_t
> and not scm_t_uint32.
>
> Andy
Hi,
I've sent a patch to use C99 inline in a separate email. It's kind of obvious, but let me know if it makes sense (or not) and I'll write a proper commit message.
Regards
Daniel
^ permalink raw reply [flat|nested] 16+ messages in thread
* Re: [PATCH] Re: Patchset related to array functions
2016-08-31 9:46 ` Andy Wingo
2016-08-31 11:36 ` [PATCH] " Daniel Llorens
@ 2016-08-31 14:45 ` Eli Zaretskii
1 sibling, 0 replies; 16+ messages in thread
From: Eli Zaretskii @ 2016-08-31 14:45 UTC (permalink / raw)
To: Andy Wingo; +Cc: guile-devel, daniel.llorens
> From: Andy Wingo <wingo@pobox.com>
> Date: Wed, 31 Aug 2016 11:46:19 +0200
> Cc: guile-devel <guile-devel@gnu.org>
>
> Hah! Turns out we have been compiling in GCC's default mode the whole
> time, which is gnu11.
The default is version-dependent. Only GCC 5.x switched to gnu11,
previous versions used gnu90, AFAIK.
^ permalink raw reply [flat|nested] 16+ messages in thread
end of thread, other threads:[~2016-08-31 14:45 UTC | newest]
Thread overview: 16+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2016-07-12 7:48 Patchset related to array functions Daniel Llorens
2016-07-12 14:11 ` Andy Wingo
2016-07-12 17:16 ` Daniel Llorens
2016-07-14 9:46 ` Andy Wingo
2016-07-14 15:41 ` [PATCH] " Daniel Llorens
2016-07-14 18:20 ` Andy Wingo
2016-07-15 12:54 ` [PATCH] " Daniel Llorens
2016-08-31 9:28 ` [PATCH] " Andy Wingo
2016-08-31 9:46 ` Andy Wingo
2016-08-31 11:36 ` [PATCH] " Daniel Llorens
2016-08-31 14:45 ` [PATCH] " Eli Zaretskii
2016-07-15 10:52 ` Chris Vine
2016-07-16 9:07 ` Andy Wingo
2016-07-16 10:34 ` Chris Vine
2016-07-15 17:41 ` Mark H Weaver
2016-07-16 8:30 ` Andy Wingo
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).