From: Daniel Llorens <daniel.llorens@bluewin.ch>
To: guile-devel <guile-devel@gnu.org>
Subject: Patchset related to array functions
Date: Tue, 12 Jul 2016 09:48:24 +0200 [thread overview]
Message-ID: <7EFBBC0B-FF29-418A-96DA-D1A323B66C95@bluewin.ch> (raw)
[-- 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
next reply other threads:[~2016-07-12 7:48 UTC|newest]
Thread overview: 16+ messages / expand[flat|nested] mbox.gz Atom feed top
2016-07-12 7:48 Daniel Llorens [this message]
2016-07-12 14:11 ` Patchset related to array functions 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
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=7EFBBC0B-FF29-418A-96DA-D1A323B66C95@bluewin.ch \
--to=daniel.llorens@bluewin.ch \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
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).