From: Daniel Llorens <daniel.llorens@bluewin.ch>
To: Andy Wingo <wingo@pobox.com>
Cc: guile-devel <guile-devel@gnu.org>
Subject: Re: Patchset related to array functions
Date: Tue, 12 Jul 2016 19:16:55 +0200 [thread overview]
Message-ID: <A1BFED22-3DF9-46F7-A3E0-08BC44E7C4D3@bluewin.ch> (raw)
In-Reply-To: <87twfv0wvm.fsf@pobox.com>
[-- Attachment #1: Type: text/plain, Size: 1145 bytes --]
On 12 Jul 2016, at 16:11, Andy Wingo <wingo@pobox.com> wrote:
> On Tue 12 Jul 2016 09:48, Daniel Llorens <daniel.llorens@bluewin.ch> writes:
>
>> @@ -175,19 +175,19 @@ dnl investigation of problems with "64" system and library calls on
>> dnl Darwin (MacOS X). The libguile code (_scm.h) assumes that if a
>> dnl system has stat64, it will have all the other 64 APIs too; but on
>> dnl Darwin, stat64 is there but other APIs are missing.
>> -dnl
>> +dnl
>> dnl It also appears, from the Darwin docs, that most system call APIs
>> dnl there (i.e. the traditional ones _without_ "64" in their names) have
>> dnl been 64-bit-capable for a long time now, so it isn't necessary to
>> dnl use "64" versions anyway. For example, Darwin's off_t is 64-bit.
>
> Can you please fix your editor to not strip whitespace in unrelated
> parts of patches, and revisit this patch set to remove unrelated
> whitespace changes?
>
> Thanks. I know it's irritating to you but it's also irritating to me :)
>
> Andy
Sorry about this. Fixed patchset attached. I've also pushed to lloda-squash0.
Regards,
Daniel
[-- Attachment #2: 0001-Compile-in-C99-mode.patch --]
[-- Type: application/octet-stream, Size: 1148 bytes --]
From 2ccb648420e4667e7da8d38b10e1f6a41642774a Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 11 Feb 2015 14:05:08 +0100
Subject: [PATCH 01/12] Compile in C99 mode
* configure.ac: Require C99 flags. Remove -Wdeclaration-after-statement.
---
configure.ac | 5 ++---
1 file changed, 2 insertions(+), 3 deletions(-)
diff --git a/configure.ac b/configure.ac
index 1735c56..8fdaa73 100644
--- a/configure.ac
+++ b/configure.ac
@@ -65,7 +65,7 @@ AC_CANONICAL_HOST
AC_LIBTOOL_WIN32_DLL
AC_PROG_INSTALL
-AC_PROG_CC
+AC_PROG_CC_C99
gl_EARLY
AC_PROG_CPP
AC_PROG_SED
@@ -1524,8 +1524,7 @@ case "$GCC" in
## <http://lists.gnu.org/archive/html/guile-devel/2012-01/msg00487.html>.
POTENTIAL_GCC_CFLAGS="-Wall -Wmissing-prototypes \
- -Wdeclaration-after-statement -Wpointer-arith \
- -Wswitch-enum -fno-strict-aliasing -fwrapv"
+ -Wpointer-arith -Wswitch-enum -fno-strict-aliasing -fwrapv"
# Do this here so we don't screw up any of the tests above that might
# not be "warning free"
if test "${GUILE_ERROR_ON_WARNING}" = yes
--
2.7.3
[-- Attachment #3: 0002-Fix-compilation-of-rank-0-typed-array-literals.patch --]
[-- Type: application/octet-stream, Size: 1768 bytes --]
From 9876c7d9a22be565f67fb2213303dda698ce3b08 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Thu, 12 Feb 2015 13:02:24 +0100
Subject: [PATCH 02/12] Fix compilation of rank 0 typed array literals
* module/system/vm/assembler.scm (simple-uniform-vector?): array-length
fails for rank 0 arrays; fix the shape condition.
* test-suite/tests/arrays.test: Test reading of #0f64(x) in compilation
context.
---
module/system/vm/assembler.scm | 4 +++-
test-suite/tests/arrays.test | 8 +++++++-
2 files changed, 10 insertions(+), 2 deletions(-)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 20a652c..f6b3caa 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -995,7 +995,9 @@ immediate, and @code{#f} otherwise."
(define (simple-uniform-vector? obj)
(and (array? obj)
(symbol? (array-type obj))
- (equal? (array-shape obj) (list (list 0 (1- (array-length obj)))))))
+ (match (array-shape obj)
+ (((0 n)) #t)
+ (else #f))))
(define (statically-allocatable? x)
"Return @code{#t} if a non-immediate constant can be allocated
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index e76c699..20cb78b 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -204,7 +204,13 @@
(with-test-prefix/c&e "array-equal?"
(pass-if "#s16(...)"
- (array-equal? #s16(1 2 3) #s16(1 2 3))))
+ (array-equal? #s16(1 2 3) #s16(1 2 3)))
+
+ (pass-if "#0f64(...)"
+ (array-equal? #0f64(99) (make-typed-array 'f64 99)))
+
+ (pass-if "#0(...)"
+ (array-equal? #0(99) (make-array 99))))
;;;
;;; make-shared-array
--
2.7.3
[-- Attachment #4: 0003-Remove-scm_from_contiguous_array-array-contiguous-fl.patch --]
[-- Type: application/octet-stream, Size: 8747 bytes --]
From 653463a873afb30f882323414b177c361131da4d Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Mon, 9 Feb 2015 17:27:33 +0100
Subject: [PATCH 03/12] Remove scm_from_contiguous_array, array 'contiguous'
flag
scm_from_contiguous_array() is undocumented, unused within Guile, and
can be trivially replaced by make-array + array-copy without requiring
contiguity.
The related SCM_I_ARRAY_FLAG_CONTIGUOUS (arrays.h) was set by all
array-creating functions (make-typed-array, transpose-array,
make-shared-array) but it was only used by array-contents, which needed
to traverse the dimensions anyway.
* libguile/arrays.h (scm_from_contiguous_array): Remove declaration.
* libguile/arrays.c (scm_from_contiguous_array): Remove.
(scm_make_typed_array, scm_from_contiguous_typed_array): Don't set the
contiguous flag.
(scm_transpose_array, scm_make_shared_array): Don't call
scm_i_ra_set_contp.
(scm_array_contents): Inline scm_i_ra_set_contp() here. Adopt uniform
type check order. Remove redundant comments.
(scm_i_ra_set_contp): Remove.
* test-suite/tests/arrays.test: Test array-contents with rank 0 array.
---
libguile/arrays.c | 112 +++++++++++--------------------------------
libguile/arrays.h | 4 +-
test-suite/tests/arrays.test | 6 +++
3 files changed, 36 insertions(+), 86 deletions(-)
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 52fe90a..3cb547f 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -188,7 +188,6 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
SCM ra;
ra = scm_i_shap2ra (bounds);
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
s = SCM_I_ARRAY_DIMS (ra);
k = SCM_I_ARRAY_NDIM (ra);
@@ -225,7 +224,6 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
size_t sz;
ra = scm_i_shap2ra (bounds);
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
s = SCM_I_ARRAY_DIMS (ra);
k = SCM_I_ARRAY_NDIM (ra);
@@ -270,41 +268,6 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
}
#undef FUNC_NAME
-SCM
-scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len)
-#define FUNC_NAME "scm_from_contiguous_array"
-{
- size_t k, rlen = 1;
- scm_t_array_dim *s;
- SCM ra;
- scm_t_array_handle h;
-
- ra = scm_i_shap2ra (bounds);
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
- s = SCM_I_ARRAY_DIMS (ra);
- k = SCM_I_ARRAY_NDIM (ra);
-
- while (k--)
- {
- s[k].inc = rlen;
- SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
- rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
- }
- if (rlen != len)
- SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL);
-
- SCM_I_ARRAY_SET_V (ra, scm_c_make_vector (rlen, SCM_UNDEFINED));
- scm_array_get_handle (ra, &h);
- memcpy (h.writable_elements, elts, rlen * sizeof(SCM));
- scm_array_handle_release (&h);
-
- if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
- if (0 == s->lbnd)
- return SCM_I_ARRAY_V (ra);
- return ra;
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
(SCM fill, SCM bounds),
"Create and return an array.")
@@ -314,27 +277,6 @@ SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
}
#undef FUNC_NAME
-static void
-scm_i_ra_set_contp (SCM ra)
-{
- size_t k = SCM_I_ARRAY_NDIM (ra);
- if (k)
- {
- ssize_t inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc;
- while (k--)
- {
- if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc)
- {
- SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
- return;
- }
- inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
- - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
- }
- }
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
-}
-
SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
(SCM oldra, SCM mapfunc, SCM dims),
@@ -448,7 +390,6 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0,
SCM_UNDEFINED);
}
- scm_i_ra_set_contp (ra);
return ra;
}
#undef FUNC_NAME
@@ -547,16 +488,12 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
}
if (ndim > 0)
SCM_MISC_ERROR ("bad argument list", SCM_EOL);
- scm_i_ra_set_contp (res);
return res;
}
}
#undef FUNC_NAME
-/* attempts to unroll an array into a one-dimensional array.
- returns the unrolled array or #f if it can't be done. */
-/* if strict is true, return #f if returned array
- wouldn't have contiguous elements. */
+
SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
(SCM ra, SCM strict),
"If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n"
@@ -566,31 +503,38 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
"@code{make-array} and @code{make-uniform-array} may be unrolled,\n"
"some arrays made by @code{make-shared-array} may not be. If\n"
"the optional argument @var{strict} is provided, a shared array\n"
- "will be returned only if its elements are stored internally\n"
- "contiguous in memory.")
+ "will be returned only if its elements are stored contiguously\n"
+ "in memory.")
#define FUNC_NAME s_scm_array_contents
{
- if (!scm_is_array (ra))
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
- else if (SCM_I_ARRAYP (ra))
+ if (SCM_I_ARRAYP (ra))
{
SCM v;
- size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
- if (!SCM_I_ARRAY_CONTP (ra))
- return SCM_BOOL_F;
- for (k = 0; k < ndim; k++)
- len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
+ size_t ndim = SCM_I_ARRAY_NDIM (ra);
+ scm_t_array_dim *s = SCM_I_ARRAY_DIMS (ra);
+ size_t k = ndim;
+ size_t len = 1;
+
+ if (k)
+ {
+ ssize_t last_inc = s[k - 1].inc;
+ while (k--)
+ {
+ if (len*last_inc != s[k].inc)
+ return SCM_BOOL_F;
+ len *= (s[k].ubnd - s[k].lbnd + 1);
+ }
+ }
+
if (!SCM_UNBNDP (strict) && scm_is_true (strict))
{
- if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc))
+ if (ndim && (1 != s[ndim - 1].inc))
return SCM_BOOL_F;
- if (scm_is_bitvector (SCM_I_ARRAY_V (ra)))
- {
- if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
- SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
- len % SCM_LONG_BIT)
- return SCM_BOOL_F;
- }
+ if (scm_is_bitvector (SCM_I_ARRAY_V (ra))
+ && (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
+ SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
+ len % SCM_LONG_BIT))
+ return SCM_BOOL_F;
}
v = SCM_I_ARRAY_V (ra);
@@ -607,8 +551,10 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
return sra;
}
}
- else
+ else if (scm_is_array (ra))
return ra;
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
}
#undef FUNC_NAME
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 5f40597..4baa51e 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -37,8 +37,6 @@
/** Arrays */
SCM_API SCM scm_make_array (SCM fill, SCM bounds);
-SCM_API SCM scm_from_contiguous_array (SCM bounds, const SCM *elts,
- size_t len);
SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds);
SCM_API SCM scm_from_contiguous_typed_array (SCM type, SCM bounds,
const void *bytes,
@@ -54,7 +52,7 @@ SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);
/* internal. */
-#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0)
+#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0) /* currently unused */
#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc7_array, a)
#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x)>>17))
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 20cb78b..6f37196 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -294,6 +294,12 @@
(with-test-prefix/c&e "array-contents"
+ (pass-if "0-rank array"
+ (let ((a (make-vector 1 77)))
+ (and
+ (eq? a (array-contents (make-shared-array a (const '(0)))))
+ (eq? a (array-contents (make-shared-array a (const '(0))) #t)))))
+
(pass-if "simple vector"
(let* ((a (make-array 0 4)))
(eq? a (array-contents a))))
--
2.7.3
[-- Attachment #5: 0004-Avoid-unneeded-internal-use-of-array-handles.patch --]
[-- Type: application/octet-stream, Size: 9393 bytes --]
From 55619d0e1953542449c5fc57b5f4889dfa99310f Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Mon, 9 Feb 2015 12:11:52 +0100
Subject: [PATCH 04/12] Avoid unneeded internal use of array handles
* libguile/arrays.c (scm_shared_array_root): Adopt uniform check order.
(scm_shared_array_offset, scm_shared_array_increments): Use the array
fields directly just as scm_shared_array_root does.
(scm_c_array_rank): Moved from libguile/generalized-arrays.c. Don't
use array handles, but follow the same type check sequence as the
other array functions (shared-array-root, etc).
(scm_array_rank): Moved from libguile/generalized-arrays.h.
* libguile/arrays.h: Move prototypes here.
* test-suite/tests/arrays.test: Tests for shared-array-offset,
shared-array-increments.
---
libguile/arrays.c | 65 +++++++++++++++++++++++-------------
libguile/arrays.h | 3 ++
libguile/generalized-arrays.c | 21 ------------
libguile/generalized-arrays.h | 3 --
test-suite/tests/arrays.test | 76 +++++++++++++++++++++++++++++++++++--------
5 files changed, 109 insertions(+), 59 deletions(-)
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 3cb547f..fb522e1 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -64,6 +64,27 @@
(SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
+size_t
+scm_c_array_rank (SCM array)
+{
+ if (SCM_I_ARRAYP (array))
+ return SCM_I_ARRAY_NDIM (array);
+ else if (scm_is_array (array))
+ return 1;
+ else
+ scm_wrong_type_arg_msg ("array-rank", SCM_ARG1, array, "array");
+}
+
+SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
+ (SCM array),
+ "Return the number of dimensions of the array @var{array.}\n")
+#define FUNC_NAME s_scm_array_rank
+{
+ return scm_from_size_t (scm_c_array_rank (array));
+}
+#undef FUNC_NAME
+
+
SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
(SCM ra),
"Return the root vector of a shared array.")
@@ -71,10 +92,10 @@ SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
{
if (SCM_I_ARRAYP (ra))
return SCM_I_ARRAY_V (ra);
- else if (!scm_is_array (ra))
- scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
- else
+ else if (scm_is_array (ra))
return ra;
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME
@@ -84,13 +105,12 @@ SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
"Return the root vector index of the first element in the array.")
#define FUNC_NAME s_scm_shared_array_offset
{
- scm_t_array_handle handle;
- SCM res;
-
- scm_array_get_handle (ra, &handle);
- res = scm_from_size_t (handle.base);
- scm_array_handle_release (&handle);
- return res;
+ if (SCM_I_ARRAYP (ra))
+ return scm_from_size_t (SCM_I_ARRAY_BASE (ra));
+ else if (scm_is_array (ra))
+ return scm_from_size_t (0);
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME
@@ -100,18 +120,19 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
"For each dimension, return the distance between elements in the root vector.")
#define FUNC_NAME s_scm_shared_array_increments
{
- scm_t_array_handle handle;
- SCM res = SCM_EOL;
- size_t k;
- scm_t_array_dim *s;
-
- scm_array_get_handle (ra, &handle);
- k = scm_array_handle_rank (&handle);
- s = scm_array_handle_dims (&handle);
- while (k--)
- res = scm_cons (scm_from_ssize_t (s[k].inc), res);
- scm_array_handle_release (&handle);
- return res;
+ if (SCM_I_ARRAYP (ra))
+ {
+ size_t k = SCM_I_ARRAY_NDIM (ra);
+ SCM res = SCM_EOL;
+ scm_t_array_dim *dims = SCM_I_ARRAY_DIMS (ra);
+ while (k--)
+ res = scm_cons (scm_from_ssize_t (dims[k].inc), res);
+ return res;
+ }
+ else if (scm_is_array (ra))
+ return scm_list_1 (scm_from_ssize_t (1));
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 4baa51e..d3e409f 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -50,6 +50,9 @@ SCM_API SCM scm_array_contents (SCM ra, SCM strict);
SCM_API SCM scm_list_to_array (SCM ndim, SCM lst);
SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);
+SCM_API size_t scm_c_array_rank (SCM ra);
+SCM_API SCM scm_array_rank (SCM ra);
+
/* internal. */
#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0) /* currently unused */
diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c
index 9a001eb..fdbdb4a 100644
--- a/libguile/generalized-arrays.c
+++ b/libguile/generalized-arrays.c
@@ -104,27 +104,6 @@ SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
}
#undef FUNC_NAME
-size_t
-scm_c_array_rank (SCM array)
-{
- scm_t_array_handle handle;
- size_t res;
-
- scm_array_get_handle (array, &handle);
- res = scm_array_handle_rank (&handle);
- scm_array_handle_release (&handle);
- return res;
-}
-
-SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
- (SCM array),
- "Return the number of dimensions of the array @var{array.}\n")
-#define FUNC_NAME s_scm_array_rank
-{
- return scm_from_size_t (scm_c_array_rank (array));
-}
-#undef FUNC_NAME
-
size_t
scm_c_array_length (SCM array)
diff --git a/libguile/generalized-arrays.h b/libguile/generalized-arrays.h
index dfdb8bd..cfa6905 100644
--- a/libguile/generalized-arrays.h
+++ b/libguile/generalized-arrays.h
@@ -41,9 +41,6 @@ SCM_INTERNAL SCM scm_array_p_2 (SCM);
SCM_API int scm_is_typed_array (SCM obj, SCM type);
SCM_API SCM scm_typed_array_p (SCM v, SCM type);
-SCM_API size_t scm_c_array_rank (SCM ra);
-SCM_API SCM scm_array_rank (SCM ra);
-
SCM_API size_t scm_c_array_length (SCM ra);
SCM_API SCM scm_array_length (SCM ra);
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 6f37196..c40457b 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -23,9 +23,13 @@
#:use-module (srfi srfi-4)
#:use-module (srfi srfi-4 gnu))
-;;;
-;;; array?
-;;;
+(define (array-row a i)
+ (make-shared-array a (lambda (j) (list i j))
+ (cadr (array-dimensions a))))
+
+(define (array-col a j)
+ (make-shared-array a (lambda (i) (list i j))
+ (car (array-dimensions a))))
(define exception:wrong-num-indices
(cons 'misc-error "^wrong number of indices.*"))
@@ -33,6 +37,15 @@
(define exception:length-non-negative
(cons 'read-error ".*array length must be non-negative.*"))
+(define exception:wrong-type-arg
+ (cons #t "Wrong type"))
+
+(define exception:mapping-out-of-range
+ (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
+
+;;;
+;;; array?
+;;;
(with-test-prefix "array?"
@@ -216,9 +229,6 @@
;;; make-shared-array
;;;
-(define exception:mapping-out-of-range
- (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
-
(with-test-prefix/c&e "make-shared-array"
;; this failed in guile 1.8.0
@@ -404,13 +414,57 @@
(eq? (shared-array-root a) (shared-array-root b) (array-contents a)))))
;;;
+;;; shared-array-offset
+;;;
+
+(with-test-prefix/c&e "shared-array-offset"
+
+ (pass-if "plain vector"
+ (zero? (shared-array-offset (make-vector 4 0))))
+
+ (pass-if "plain array rank 2"
+ (zero? (shared-array-offset (make-array 0 4 4))))
+
+ (pass-if "row of rank-2 array, I"
+ (= 0 (shared-array-offset (array-row (make-array 0 5 3) 0))))
+
+ (pass-if "row of rank-2 array, II"
+ (= 4 (shared-array-offset (array-row (make-array 0 6 4) 1))))
+
+ (pass-if "col of rank-2 array, I"
+ (= 0 (shared-array-offset (array-col (make-array 0 5 3) 0))))
+
+ (pass-if "col of rank-2 array, II"
+ (= 1 (shared-array-offset (array-col (make-array 0 6 4) 1)))))
+
+
+;;;
+;;; shared-array-increments
+;;;
+
+(with-test-prefix/c&e "shared-array-increments"
+
+ (pass-if "plain vector"
+ (equal? '(1) (shared-array-increments (make-vector 4 0))))
+
+ (pass-if "plain array rank 2"
+ (equal? '(4 1) (shared-array-increments (make-array 0 3 4))))
+
+ (pass-if "plain array rank 3"
+ (equal? '(20 5 1) (shared-array-increments (make-array 0 3 4 5))))
+
+ (pass-if "row of rank-2 array"
+ (equal? '(1) (shared-array-increments (array-row (make-array 0 5 3) 0))))
+
+ (pass-if "col of rank-2 array"
+ (equal? '(3) (shared-array-increments (array-col (make-array 0 5 3) 0)))))
+
+
+;;;
;;; transpose-array
;;;
; see strings.test.
-(define exception:wrong-type-arg
- (cons #t "Wrong type"))
-
(with-test-prefix/c&e "transpose-array"
(pass-if-exception "non array argument" exception:wrong-type-arg
@@ -821,10 +875,6 @@
;;; slices as generalized vectors
;;;
-(define (array-row a i)
- (make-shared-array a (lambda (j) (list i j))
- (cadr (array-dimensions a))))
-
(with-test-prefix/c&e "generalized vector slices"
(pass-if (equal? (array-row #2u32((0 1) (2 3)) 1)
#u32(2 3)))
--
2.7.3
[-- Attachment #6: 0005-Reuse-SCM_BYTEVECTOR_TYPED_LENGTH-in-scm_array_get_h.patch --]
[-- Type: application/octet-stream, Size: 2817 bytes --]
From 59500529bdf6f754f65092f020574b83f238b287 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 11 Feb 2015 12:58:01 +0100
Subject: [PATCH 05/12] Reuse SCM_BYTEVECTOR_TYPED_LENGTH in
scm_array_get_handle
* libguile/bytevectors.h (SCM_BYTEVECTOR_TYPE_SIZE,
SCM_BYTEVECTOR_TYPED_LENGTH): Moved from libguile/bytevectors.c.
* libguile/array-handle.c (scm_array_get_handle): Reuse
SCM_BYTEVECTOR_TYPED_LENGTH.
---
libguile/array-handle.c | 6 ++----
libguile/bytevectors.c | 5 -----
libguile/bytevectors.h | 5 +++++
3 files changed, 7 insertions(+), 9 deletions(-)
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 2252ecc..3595266 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -185,15 +185,13 @@ scm_array_get_handle (SCM array, scm_t_array_handle *h)
break;
case scm_tc7_bytevector:
{
- size_t byte_length, length, element_byte_size;
+ size_t length;
scm_t_array_element_type element_type;
scm_t_vector_ref vref;
scm_t_vector_set vset;
- byte_length = scm_c_bytevector_length (array);
element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (array);
- element_byte_size = scm_i_array_element_type_sizes[element_type] / 8;
- length = byte_length / element_byte_size;
+ length = SCM_BYTEVECTOR_TYPED_LENGTH (array);
switch (element_type)
{
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index e426ae3..cf247dc 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -192,11 +192,6 @@
#define SCM_BYTEVECTOR_SET_PARENT(_bv, _parent) \
SCM_SET_CELL_OBJECT_3 ((_bv), (_parent))
-#define SCM_BYTEVECTOR_TYPE_SIZE(var) \
- (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
-#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \
- (SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var))
-
/* The empty bytevector. */
SCM scm_null_bytevector = SCM_UNSPECIFIED;
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
index a5eeaea..af4ac1c 100644
--- a/libguile/bytevectors.h
+++ b/libguile/bytevectors.h
@@ -129,6 +129,11 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM);
#define SCM_BYTEVECTOR_CONTIGUOUS_P(_bv) \
(SCM_BYTEVECTOR_FLAGS (_bv) >> 8UL)
+#define SCM_BYTEVECTOR_TYPE_SIZE(var) \
+ (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
+#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \
+ (SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var))
+
/* Hint that is passed to `scm_gc_malloc ()' and friends. */
#define SCM_GC_BYTEVECTOR "bytevector"
--
2.7.3
[-- Attachment #7: 0006-New-functions-array-from-array-from-array-amend.patch --]
[-- Type: application/octet-stream, Size: 16076 bytes --]
From 1d15eaae496b7e4a9a72d1b16353d4b11b3c33dd Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 11 Feb 2015 16:44:21 +0100
Subject: [PATCH 06/12] New functions array-from, array-from*, array-amend!
* libguile/arrays.h (scm_array_from, scm_array_from_s,
scm_array_amend_x): New declarations.
* libguile/arrays.c (scm_array_from, scm_array_from_s,
scm_array_amend_x): New functions, export as array-from, array-from*,
array-amend!.
* test-suite/tests/arrays.test: Tests for array-from, array-from*,
array-amend!.
* doc/ref/api-compound.texi: Document array-from, array-from*,
array-amend!.
---
doc/ref/api-compound.texi | 105 +++++++++++++++++++++++++++++
libguile/arrays.c | 153 +++++++++++++++++++++++++++++++++++++++++++
libguile/arrays.h | 6 ++
test-suite/tests/arrays.test | 109 ++++++++++++++++++++++++++++++
4 files changed, 373 insertions(+)
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index b4ae79c..ccafa7a 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1709,6 +1709,111 @@ base and stride for new array indices in @var{oldarray} data. A few
sample points are enough because @var{mapfunc} is linear.
@end deffn
+
+@deffn {Scheme Procedure} array-ref array idx @dots{}
+@deffnx {C Function} scm_array_ref (array, idxlist)
+Return the element at @code{(idx @dots{})} in @var{array}.
+@end deffn
+
+@deffn {Scheme Procedure} array-from array idx @dots{}
+@deffnx {C Function} scm_array_from (array, idxlist)
+If the length of @var{idxlist} equals the rank @math{n} of
+@var{array}, return the element at @code{(idx @dots{})}, just like
+@code{(array-ref array idx @dots{})}. If, however, the length @math{k}
+of @var{idxlist} is shorter than @math{n}, then return the shared
+@math{(n-k)}-rank prefix cell of @var{array} given by @var{idxlist}.
+
+For example:
+
+@example
+@lisp
+(array-from #2((a b) (c d)) 0) @result{} #(a b)
+(array-from #2((a b) (c d)) 1) @result{} #(c d)
+(array-from #2((a b) (c d)) 1 1) @result{} d
+(array-from #2((a b) (c d))) @result{} #2((a b) (c d))
+@end lisp
+@end example
+
+@code{(apply array-from array indices)} is equivalent to
+
+@lisp
+(let ((len (length indices)))
+ (if (= (array-rank a) len)
+ (apply array-ref a indices)
+ (apply make-shared-array a
+ (lambda t (append indices t))
+ (drop (array-dimensions a) len))))
+@end lisp
+
+The name `from' comes from the J language.
+@end deffn
+
+@deffn {Scheme Procedure} array-from* array idx @dots{}
+@deffnx {C Function} scm_array_from_s (array, idxlist)
+Like @code{(array-from array idx @dots{})}, but return a 0-rank shared
+array if the length of @var{idxlist} matches the rank of
+@var{array}. This can be useful when using @var{ARRAY} as destination
+of copies.
+
+Compare:
+
+@example
+@lisp
+(array-from #2((a b) (c d)) 1 1) @result{} d
+(array-from* #2((a b) (c d)) 1) @result{} #0(d)
+(define a (make-array 'a 2 2))
+(array-fill! (array-from* a 1 1) 'b)
+a @result{} #2((a a) (a b)).
+(array-fill! (array-from a 1 1) 'b) @result{} error: not an array
+@end lisp
+@end example
+
+@code{(apply array-from* array indices)} is equivalent to
+
+@lisp
+(apply make-shared-array a
+ (lambda t (append indices t))
+ (drop (array-dimensions a) (length indices)))
+@end lisp
+@end deffn
+
+
+@deffn {Scheme Procedure} array-amend! array x idx @dots{}
+@deffnx {C Function} scm_array_amend_x (array, x, idxlist)
+If the length of @var{idxlist} equals the rank @math{n} of
+@var{array}, set the element at @code{(idx @dots{})} of @var{array} to
+@var{x}, just like @code{(array-set! array x idx @dots{})}. If,
+however, the length @math{k} of @var{idxlist} is shorter than
+@math{n}, then copy the @math{(n-k)}-rank array @var{x}
+into @math{(n-k)}-rank prefix cell of @var{array} given by
+@var{idxlist}. In this case, the last @math{(n-k)} dimensions of
+@var{array} and the dimensions of @var{x} must match exactly.
+
+This function returns the modified @var{array}.
+
+For example:
+
+@example
+@lisp
+(array-amend! (make-array 'a 2 2) b 1 1) @result{} #2((a a) (a b))
+(array-amend! (make-array 'a 2 2) #(x y) 1) @result{} #2((a a) (x y))
+@end lisp
+@end example
+
+@code{(apply array-amend! array x indices)} is equivalent to
+
+@lisp
+(let ((len (length indices)))
+ (if (= (array-rank array) len)
+ (apply array-set! array x indices)
+ (array-copy! x (apply array-from array indices)))
+ array)
+@end lisp
+
+The name `amend' comes from the J language.
+@end deffn
+
+
@deffn {Scheme Procedure} shared-array-increments array
@deffnx {C Function} scm_shared_array_increments (array)
For each dimension, return the distance between elements in the root vector.
diff --git a/libguile/arrays.c b/libguile/arrays.c
index fb522e1..26c4543 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -416,6 +416,159 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
#undef FUNC_NAME
+#define ARRAY_FROM_POS(error_args) \
+ scm_t_array_handle handle; \
+ scm_array_get_handle (ra, &handle); \
+ scm_t_array_dim * s = scm_array_handle_dims (&handle); \
+ size_t ndim = scm_array_handle_rank (&handle); \
+ size_t k = ndim; \
+ ssize_t pos = 0; \
+ SCM i = indices; \
+ for (; k>0 && scm_is_pair (i); --k, ++s, i=scm_cdr (i)) \
+ { \
+ ssize_t ik = scm_to_ssize_t (scm_car (i)); \
+ if (ik<s->lbnd || ik>s->ubnd) \
+ { \
+ scm_array_handle_release (&handle); \
+ scm_misc_error (FUNC_NAME, "indices out of range", error_args); \
+ } \
+ pos += (ik-s->lbnd) * s->inc; \
+ }
+
+#define ARRAY_FROM_GET_O \
+ o = scm_i_make_array (k); \
+ SCM_I_ARRAY_SET_V (o, handle.vector); \
+ SCM_I_ARRAY_SET_BASE (o, pos + handle.base); \
+ scm_t_array_dim * os = SCM_I_ARRAY_DIMS (o); \
+ for (; k>0; --k, ++s, ++os) \
+ { \
+ os->ubnd = s->ubnd; \
+ os->lbnd = s->lbnd; \
+ os->inc = s->inc; \
+ }
+
+
+SCM_DEFINE (scm_array_from_s, "array-from*", 1, 0, 1,
+ (SCM ra, SCM indices),
+ "Return the array slice @var{ra}[@var{indices} ..., ...]\n"
+ "The rank of @var{ra} must equal to the number of indices or larger.\n\n"
+ "See also @code{array-ref}, @code{array-from}, @code{array-amend!}.\n\n"
+ "@code{array-from*} may return a rank-0 array. For example:\n"
+ "@lisp\n"
+ "(array-from* #2((1 2 3) (4 5 6)) 1 1) @result{} #0(5)\n"
+ "(array-from* #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n"
+ "(array-from* #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n"
+ "(array-from* #0(5) @result{} #0(5).\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_from_s
+{
+ ARRAY_FROM_POS(scm_list_2 (ra, indices))
+ SCM o;
+ if (k==ndim)
+ o = ra;
+ else if (scm_is_null (i))
+ { ARRAY_FROM_GET_O }
+ else
+ {
+ scm_array_handle_release (&handle);
+ scm_misc_error(FUNC_NAME, "too many indices", scm_list_2 (ra, indices));
+ }
+ scm_array_handle_release (&handle);
+ return o;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_array_from, "array-from", 1, 0, 1,
+ (SCM ra, SCM indices),
+ "Return the element at the @code{(@var{indices} ...)} position\n"
+ "in array @var{ra}, or the array slice @var{ra}[@var{indices} ..., ...]\n"
+ "if the rank of @var{ra} is larger than the number of indices.\n\n"
+ "See also @code{array-ref}, @code{array-from*}, @code{array-amend!}.\n\n"
+ "@code{array-from} never returns a rank 0 array. For example:\n"
+ "@lisp\n"
+ "(array-from #2((1 2 3) (4 5 6)) 1 1) @result{} 5\n"
+ "(array-from #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n"
+ "(array-from #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n"
+ "(array-from #0(5) @result{} 5.\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_from
+{
+ ARRAY_FROM_POS(scm_list_2 (ra, indices))
+ SCM o;
+ if (k>0)
+ {
+ if (k==ndim)
+ o = ra;
+ else
+ { ARRAY_FROM_GET_O }
+ }
+ else if (scm_is_null(i))
+ o = scm_array_handle_ref (&handle, pos);
+ else
+ {
+ scm_array_handle_release (&handle);
+ scm_misc_error(FUNC_NAME, "too many indices", scm_list_2 (ra, indices));
+ }
+ scm_array_handle_release (&handle);
+ return o;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
+ (SCM ra, SCM b, SCM indices),
+ "Set the array slice @var{ra}[@var{indices} ..., ...] to @var{b}\n."
+ "Equivalent to @code{(array-copy! @var{b} (apply array-from @var{ra} @var{indices}))}\n"
+ "if the number of indices is smaller than the rank of @var{ra}; otherwise\n"
+ "equivalent to @code{(apply array-set! @var{ra} @var{b} @var{indices})}.\n"
+ "This function returns the modified array @var{ra}.\n\n"
+ "See also @code{array-ref}, @code{array-from}, @code{array-from*}.\n\n"
+ "For example:\n"
+ "@lisp\n"
+ "(define A (list->array 2 '((1 2 3) (4 5 6))))\n"
+ "(array-amend! A #0(99) 1 1) @result{} #2((1 2 3) (4 #0(99) 6))\n"
+ "(array-amend! A 99 1 1) @result{} #2((1 2 3) (4 99 6))\n"
+ "(array-amend! A #(a b c) 0) @result{} #2((a b c) (4 99 6))\n"
+ "(array-amend! A #2((x y z) (9 8 7))) @result{} #2((x y z) (9 8 7))\n\n"
+ "(define B (make-array 0))\n"
+ "(array-amend! B 15) @result{} #0(15)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_amend_x
+{
+ ARRAY_FROM_POS(scm_list_3 (ra, b, indices))
+ SCM o;
+ if (k>0)
+ {
+ if (k==ndim)
+ o = ra;
+ else
+ { ARRAY_FROM_GET_O }
+ scm_array_handle_release(&handle);
+ /* an error is still possible here if o and b don't match. */
+ /* TODO copying like this wastes the handle, and the bounds matching
+ behavior of array-copy! is not strict. */
+ scm_array_copy_x(b, o);
+ }
+ else if (scm_is_null(i))
+ {
+ scm_array_handle_set (&handle, pos, b); /* ra may be non-ARRAYP */
+ scm_array_handle_release (&handle);
+ }
+ else
+ {
+ scm_array_handle_release (&handle);
+ scm_misc_error(FUNC_NAME, "too many indices", scm_list_3 (ra, b, indices));
+ }
+ return ra;
+}
+#undef FUNC_NAME
+
+
+#undef ARRAY_FROM_POS
+#undef ARRAY_FROM_GET_O
+
+
/* args are RA . DIMS */
SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
(SCM ra, SCM args),
diff --git a/libguile/arrays.h b/libguile/arrays.h
index d3e409f..9b7fd6c 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -41,12 +41,18 @@ SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds);
SCM_API SCM scm_from_contiguous_typed_array (SCM type, SCM bounds,
const void *bytes,
size_t byte_len);
+
SCM_API SCM scm_shared_array_root (SCM ra);
SCM_API SCM scm_shared_array_offset (SCM ra);
SCM_API SCM scm_shared_array_increments (SCM ra);
+
SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims);
SCM_API SCM scm_transpose_array (SCM ra, SCM args);
SCM_API SCM scm_array_contents (SCM ra, SCM strict);
+SCM_API SCM scm_array_from_s (SCM ra, SCM indices);
+SCM_API SCM scm_array_from (SCM ra, SCM indices);
+SCM_API SCM scm_array_amend_x (SCM ra, SCM b, SCM indices);
+
SCM_API SCM scm_list_to_array (SCM ndim, SCM lst);
SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index c40457b..9bd0676 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -296,6 +296,115 @@
(and (eqv? 5 (array-ref s2 1))
(eqv? 8 (array-ref s2 2))))))
+
+;;;
+;;; array-from*
+;;;
+
+(with-test-prefix/c&e "array-from*"
+
+ (pass-if "vector I"
+ (let ((v (vector 1 2 3)))
+ (array-fill! (array-from* v 1) 'a)
+ (array-equal? v #(1 a 3))))
+
+ (pass-if "vector II"
+ (let ((v (vector 1 2 3)))
+ (array-copy! #(a b c) (array-from* v))
+ (array-equal? v #(a b c))))
+
+ (pass-if "array I"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-fill! (array-from* a 1 1) 'a)
+ (array-equal? a #2((1 2 3) (4 a 6)))))
+
+ (pass-if "array II"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-copy! #(a b c) (array-from* a 1))
+ (array-equal? a #2((1 2 3) (a b c)))))
+
+ (pass-if "array III"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-copy! #2((a b c) (x y z)) (array-from* a))
+ (array-equal? a #2((a b c) (x y z)))))
+
+ (pass-if "rank 0 array"
+ (let ((a (make-array 77)))
+ (array-fill! (array-from* a) 'a)
+ (array-equal? a #0(a)))))
+
+
+;;;
+;;; array-from
+;;;
+
+(with-test-prefix/c&e "array-from"
+
+ (pass-if "vector I"
+ (let ((v (vector 1 2 3)))
+ (equal? 2 (array-from v 1))))
+
+ (pass-if "vector II"
+ (let ((v (vector 1 2 3)))
+ (array-copy! #(a b c) (array-from v))
+ (array-equal? v #(a b c))))
+
+ (pass-if "array I"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (equal? 5 (array-from a 1 1))))
+
+ (pass-if "array II"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-copy! #(a b c) (array-from a 1))
+ (array-equal? a #2((1 2 3) (a b c)))))
+
+ (pass-if "array III"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (array-copy! #2((a b c) (x y z)) (array-from a))
+ (array-equal? a #2((a b c) (x y z)))))
+
+ (pass-if "rank 0 array"
+ (let ((a (make-array 77)))
+ (equal? (array-from a) 77))))
+
+
+;;;
+;;; array-amend!
+;;;
+
+(with-test-prefix/c&e "array-amend!"
+
+ (pass-if "vector I"
+ (let ((v (vector 1 2 3)))
+ (and (eq? v (array-amend! v 'x 1))
+ (array-equal? v #(1 x 3)))))
+
+ (pass-if "vector II"
+ (let ((v (vector 1 2 3)))
+ (and (eq? v (array-amend! (array-from v) #(a b c)))
+ (array-equal? v #(a b c)))))
+
+ (pass-if "array I"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (and (eq? a (array-amend! a 'x 1 1))
+ (array-equal? a #2((1 2 3) (4 x 6))))))
+
+ (pass-if "array II"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (and (eq? a (array-amend! a #(a b c) 1))
+ (array-equal? a #2((1 2 3) (a b c))))))
+
+ (pass-if "array III"
+ (let ((a (list->array 2 '((1 2 3) (4 5 6)))))
+ (and (eq? a (array-amend! a #2((a b c) (x y z))))
+ (array-equal? a #2((a b c) (x y z))))))
+
+ (pass-if "rank 0 array"
+ (let ((a (make-array 77)))
+ (and (eq? a (array-amend! a 99))
+ (array-equal? a #0(99))))))
+
+
;;;
;;; array-contents
;;;
--
2.7.3
[-- Attachment #8: 0007-Remove-deprecated-array-functions.patch --]
[-- Type: application/octet-stream, Size: 10734 bytes --]
From 2f2a098bef85d350198ce4a0ff0d25c18a3cf598 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Fri, 13 Feb 2015 16:45:21 +0100
Subject: [PATCH 07/12] Remove deprecated array functions
* libguile/array-map.c (scm_array_fill_int, scm_array_fill_int,
scm_ra_eqp, scm_ra_lessp scm_ra_leqp, scm_ra_grp, scm_ra_greqp,
scm_ra_sum, scm_ra_difference, scm_ra_product, scm_ra_divide,
scm_array_identity): Remove deprecated functions.
* libguile/array-map.h: Remove declaration of deprecated functions.
* libguile/generalized-vectors.h, libguile/generalized-vectors.c
(scm_is_generalized_vector, scm_c_generalized_vector_length,
scm_c_generalized_vector_ref, scm_c_generalized_vector_set_x): These
functions were deprecated in 2.0.9. Remove.
---
libguile/array-map.c | 261 -----------------------------------------
libguile/array-map.h | 16 ---
libguile/generalized-vectors.c | 31 -----
libguile/generalized-vectors.h | 4 -
4 files changed, 312 deletions(-)
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 938f0a7..587df02 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -307,267 +307,6 @@ SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
#undef FUNC_NAME
-#if SCM_ENABLE_DEPRECATED == 1
-
-/* to be used as cproc in scm_ramapc to fill an array dimension with
- "fill". */
-int
-scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
-{
- unsigned long i;
- unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
- long inc = SCM_I_ARRAY_DIMS (ra)->inc;
- unsigned long base = SCM_I_ARRAY_BASE (ra);
-
- ra = SCM_I_ARRAY_V (ra);
-
- for (i = base; n--; i += inc)
- ASET (ra, i, fill);
-
- return 1;
-}
-
-/* Functions callable by ARRAY-MAP! */
-
-int
-scm_ra_eqp (SCM ra0, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
- scm_t_array_handle ra0_handle;
- scm_t_array_dim *ra0_dims;
- size_t n;
- ssize_t inc0;
- size_t i0 = 0;
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- ra2 = SCM_I_ARRAY_V (ra2);
-
- scm_array_get_handle (ra0, &ra0_handle);
- ra0_dims = scm_array_handle_dims (&ra0_handle);
- n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
- inc0 = ra0_dims[0].inc;
-
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
- if (!scm_is_eq (AREF (ra1, i1), AREF (ra2, i2)))
- scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
- }
-
- scm_array_handle_release (&ra0_handle);
- return 1;
-}
-
-/* opt 0 means <, nonzero means >= */
-
-static int
-ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
-{
- scm_t_array_handle ra0_handle;
- scm_t_array_dim *ra0_dims;
- size_t n;
- ssize_t inc0;
- size_t i0 = 0;
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- ra2 = SCM_I_ARRAY_V (ra2);
-
- scm_array_get_handle (ra0, &ra0_handle);
- ra0_dims = scm_array_handle_dims (&ra0_handle);
- n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
- inc0 = ra0_dims[0].inc;
-
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
- if (opt ?
- scm_is_true (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))) :
- scm_is_false (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))))
- scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
- }
-
- scm_array_handle_release (&ra0_handle);
- return 1;
-}
-
-
-
-int
-scm_ra_lessp (SCM ra0, SCM ras)
-{
- return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
-}
-
-
-int
-scm_ra_leqp (SCM ra0, SCM ras)
-{
- return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
-}
-
-
-int
-scm_ra_grp (SCM ra0, SCM ras)
-{
- return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
-}
-
-
-int
-scm_ra_greqp (SCM ra0, SCM ras)
-{
- return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
-}
-
-
-int
-scm_ra_sum (SCM ra0, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (!scm_is_null(ras))
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- ASET (ra0, i0, scm_sum (AREF(ra0, i0), AREF(ra1, i1)));
- break;
- }
- }
- }
- return 1;
-}
-
-
-
-int
-scm_ra_difference (SCM ra0, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (scm_is_null (ras))
- {
- switch (SCM_TYP7 (ra0))
- {
- default:
- {
- for (; n-- > 0; i0 += inc0)
- ASET (ra0, i0, scm_difference (AREF(ra0, i0), SCM_UNDEFINED));
- break;
- }
- }
- }
- else
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- ASET (ra0, i0, scm_difference (AREF (ra0, i0), AREF (ra1, i1)));
- break;
- }
- }
- }
- return 1;
-}
-
-
-
-int
-scm_ra_product (SCM ra0, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (!scm_is_null (ras))
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- ASET (ra0, i0, scm_product (AREF (ra0, i0), AREF (ra1, i1)));
- }
- }
- }
- return 1;
-}
-
-
-int
-scm_ra_divide (SCM ra0, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (scm_is_null (ras))
- {
- switch (SCM_TYP7 (ra0))
- {
- default:
- {
- for (; n-- > 0; i0 += inc0)
- ASET (ra0, i0, scm_divide (AREF (ra0, i0), SCM_UNDEFINED));
- break;
- }
- }
- }
- else
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- {
- SCM res = scm_divide (AREF (ra0, i0), AREF (ra1, i1));
- ASET (ra0, i0, res);
- }
- break;
- }
- }
- }
- return 1;
-}
-
-
-int
-scm_array_identity (SCM dst, SCM src)
-{
- return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
-}
-
-#endif /* SCM_ENABLE_DEPRECATED */
-
static int
ramap (SCM ra0, SCM proc, SCM ras)
{
diff --git a/libguile/array-map.h b/libguile/array-map.h
index b0592d8..e7431b1 100644
--- a/libguile/array-map.h
+++ b/libguile/array-map.h
@@ -39,22 +39,6 @@ SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc);
SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1);
SCM_INTERNAL void scm_init_array_map (void);
-#if SCM_ENABLE_DEPRECATED == 1
-
-SCM_DEPRECATED int scm_array_fill_int (SCM ra, SCM fill, SCM ignore);
-SCM_DEPRECATED int scm_ra_eqp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_lessp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_leqp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_grp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_greqp (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_sum (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_difference (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_product (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_ra_divide (SCM ra0, SCM ras);
-SCM_DEPRECATED int scm_array_identity (SCM src, SCM dst);
-
-#endif /* SCM_ENABLE_DEPRECATED == 1 */
-
#endif /* SCM_ARRAY_MAP_H */
/*
diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c
index fc493bc..0fe8b89 100644
--- a/libguile/generalized-vectors.c
+++ b/libguile/generalized-vectors.c
@@ -69,19 +69,6 @@ SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0,
}
#undef FUNC_NAME
-int
-scm_is_generalized_vector (SCM obj)
-{
- int ret = 0;
- if (scm_is_array (obj))
- {
- scm_t_array_handle h;
- scm_array_get_handle (obj, &h);
- ret = scm_array_handle_rank (&h) == 1;
- scm_array_handle_release (&h);
- }
- return ret;
-}
#define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \
scm_generalized_vector_get_handle (val, handle)
@@ -98,24 +85,6 @@ scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h)
}
}
-size_t
-scm_c_generalized_vector_length (SCM v)
-{
- return scm_c_array_length (v);
-}
-
-SCM
-scm_c_generalized_vector_ref (SCM v, ssize_t idx)
-{
- return scm_c_array_ref_1 (v, idx);
-}
-
-void
-scm_c_generalized_vector_set_x (SCM v, ssize_t idx, SCM val)
-{
- scm_c_array_set_1_x (v, val, idx);
-}
-
void
scm_init_generalized_vectors ()
{
diff --git a/libguile/generalized-vectors.h b/libguile/generalized-vectors.h
index 876537a..77d6272 100644
--- a/libguile/generalized-vectors.h
+++ b/libguile/generalized-vectors.h
@@ -30,10 +30,6 @@
/* Generalized vectors */
-SCM_API int scm_is_generalized_vector (SCM obj);
-SCM_API size_t scm_c_generalized_vector_length (SCM v);
-SCM_API SCM scm_c_generalized_vector_ref (SCM v, ssize_t idx);
-SCM_API void scm_c_generalized_vector_set_x (SCM v, ssize_t idx, SCM val);
SCM_API void scm_generalized_vector_get_handle (SCM vec,
scm_t_array_handle *h);
--
2.7.3
[-- Attachment #9: 0008-Do-not-use-array-handles-in-scm_vector.patch --]
[-- Type: application/octet-stream, Size: 3542 bytes --]
From 83c4f1882858feea508cacf6d77b15155a2eb2ea Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 25 Feb 2015 09:47:40 +0100
Subject: [PATCH 08/12] Do not use array handles in scm_vector
* libguile/vectors.c (scm_vector): Use SCM_I_VECTOR_WELTS on new vector
instead of generic scm_vector_elements; cf. scm_vector_copy().
(scm_vector_elements): Forward to scm_vector_writable_elements().
(scm_vector_writable_elements): Remove special error message for weak
vector arg.
* libguile/generalized-vectors.c (SCM_VALIDATE_VECTOR_WITH_HANDLE):
Remove unused macro.
* libguile/array-handle.c (scm_array_handle_elements): Forward to
scm_array_handle_writable_elements().
---
libguile/array-handle.c | 4 +---
libguile/generalized-vectors.c | 5 -----
libguile/vectors.c | 20 ++------------------
3 files changed, 3 insertions(+), 26 deletions(-)
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 3595266..89277d9 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -320,9 +320,7 @@ scm_array_handle_release (scm_t_array_handle *h)
const SCM *
scm_array_handle_elements (scm_t_array_handle *h)
{
- if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
- scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
- return ((const SCM*)h->elements) + h->base;
+ return scm_array_handle_writable_elements (h);
}
SCM *
diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c
index 0fe8b89..276b9d8 100644
--- a/libguile/generalized-vectors.c
+++ b/libguile/generalized-vectors.c
@@ -69,11 +69,6 @@ SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0,
}
#undef FUNC_NAME
-
-#define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \
- scm_generalized_vector_get_handle (val, handle)
-
-
void
scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h)
{
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 5dab545..6dcc7eb 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -59,26 +59,13 @@ const SCM *
scm_vector_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
- if (SCM_I_WVECTP (vec))
- scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
-
- scm_generalized_vector_get_handle (vec, h);
- if (lenp)
- {
- scm_t_array_dim *dim = scm_array_handle_dims (h);
- *lenp = dim->ubnd - dim->lbnd + 1;
- *incp = dim->inc;
- }
- return scm_array_handle_elements (h);
+ return scm_vector_writable_elements (vec, h, lenp, incp);
}
SCM *
scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
- if (SCM_I_WVECTP (vec))
- scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
-
scm_generalized_vector_get_handle (vec, h);
if (lenp)
{
@@ -141,12 +128,11 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
SCM res;
SCM *data;
long i, len;
- scm_t_array_handle handle;
SCM_VALIDATE_LIST_COPYLEN (1, l, len);
res = scm_c_make_vector (len, SCM_UNSPECIFIED);
- data = scm_vector_writable_elements (res, &handle, NULL, NULL);
+ data = SCM_I_VECTOR_WELTS (res);
i = 0;
while (scm_is_pair (l) && i < len)
{
@@ -155,8 +141,6 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
i += 1;
}
- scm_array_handle_release (&handle);
-
return res;
}
#undef FUNC_NAME
--
2.7.3
[-- Attachment #10: 0009-Speed-up-for-multi-arg-cases-of-scm_ramap-functions.patch --]
[-- Type: application/octet-stream, Size: 11938 bytes --]
From e9f0ee4e1235097f656d281aa2e384b08253a3e6 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Fri, 13 Feb 2015 18:42:27 +0100
Subject: [PATCH 09/12] Speed up for multi-arg cases of scm_ramap functions
This patch results in a 20%-40% speedup in the > 1 argument cases of
the following microbenchmarks:
(define A (make-shared-array #0(1) (const '()) #e1e7))
; 1, 2, 3 arguments.
(define a 0) ,time (array-for-each (lambda (b) (set! a (+ a b))) A)
(define a 0) ,time (array-for-each (lambda (b c) (set! a (+ a b c))) A A)
(define a 0) ,time (array-for-each (lambda (b c d) (set! a (+ a b c d))) A A A)
(define A (make-shared-array (make-array 1) (const '()) #e1e7))
(define B (make-shared-array #0(1) (const '()) #e1e7))
; 1, 2, 3 arguments.
,time (array-map! A + B)
,time (array-map! A + B B)
,time (array-map! A + B B B)
* libguile/array-map.c (scm_ramap): Note on cproc arguments.
(rafill): Assume that dst's lbnd is 0.
(racp): Assume that src's lbnd is 0.
(ramap): Assume that ra0's lbnd is 0. When there're more than two
arguments, compute the array handles before the loop. Allocate the arg
list once and reuse it in the loop.
(rafe): Do as in ramap(), when there's more than one argument.
(AREF, ASET): Remove.
---
libguile/array-map.c | 151 +++++++++++++++++++++++---------------------
libguile/array-map.h | 2 +-
test-suite/tests/ramap.test | 4 +-
3 files changed, 83 insertions(+), 74 deletions(-)
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 587df02..058b6fe 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
- * 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+ * 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -48,18 +48,6 @@
static const char vi_gc_hint[] = "array-indices";
static SCM
-AREF (SCM v, size_t pos)
-{
- return scm_c_array_ref_1 (v, pos);
-}
-
-static void
-ASET (SCM v, size_t pos, SCM val)
-{
- scm_c_array_set_1_x (v, val, pos);
-}
-
-static SCM
make1array (SCM v, ssize_t inc)
{
SCM a = scm_i_make_array (1);
@@ -99,6 +87,10 @@ cindk (SCM ra, ssize_t *ve, int kend)
#define LBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].lbnd
#define UBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].ubnd
+
+/* scm_ramapc() always calls cproc with rank-1 arrays created by
+ make1array. cproc (rafe, ramap, rafill, racp) can assume that the
+ dims[0].lbnd of these arrays is always 0. */
int
scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
{
@@ -167,7 +159,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
va1 = make1array (ra1, 1);
- if (LBND (ra0, 0) < LBND (va1, 0) || UBND (ra0, 0) > UBND (va1, 0))
+ if (LBND (ra0, 0) < 0 /* LBND (va1, 0) */ || UBND (ra0, 0) > UBND (va1, 0))
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
}
*plva = scm_cons (va1, SCM_EOL);
@@ -224,14 +216,12 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
static int
rafill (SCM dst, SCM fill)
{
- scm_t_array_handle h;
- size_t n, i;
- ssize_t inc;
- scm_array_get_handle (SCM_I_ARRAY_V (dst), &h);
- i = SCM_I_ARRAY_BASE (dst);
- inc = SCM_I_ARRAY_DIMS (dst)->inc;
- n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1);
+ size_t n = SCM_I_ARRAY_DIMS (dst)->ubnd + 1;
+ size_t i = SCM_I_ARRAY_BASE (dst);
+ ssize_t inc = SCM_I_ARRAY_DIMS (dst)->inc;
dst = SCM_I_ARRAY_V (dst);
+ scm_t_array_handle h;
+ scm_array_get_handle (dst, &h);
for (; n-- > 0; i += inc)
h.vset (h.vector, i, fill);
@@ -255,19 +245,15 @@ SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
static int
racp (SCM src, SCM dst)
{
- scm_t_array_handle h_s, h_d;
- size_t n, i_s, i_d;
- ssize_t inc_s, inc_d;
-
dst = SCM_CAR (dst);
- i_s = SCM_I_ARRAY_BASE (src);
- i_d = SCM_I_ARRAY_BASE (dst);
- inc_s = SCM_I_ARRAY_DIMS (src)->inc;
- inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
- n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
+ size_t i_s = SCM_I_ARRAY_BASE (src);
+ size_t i_d = SCM_I_ARRAY_BASE (dst);
+ size_t n = (SCM_I_ARRAY_DIMS (src)->ubnd + 1);
+ ssize_t inc_s = SCM_I_ARRAY_DIMS (src)->inc;
+ ssize_t inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
src = SCM_I_ARRAY_V (src);
dst = SCM_I_ARRAY_V (dst);
-
+ scm_t_array_handle h_s, h_d;
scm_array_get_handle (src, &h_s);
scm_array_get_handle (dst, &h_d);
@@ -310,44 +296,56 @@ SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
static int
ramap (SCM ra0, SCM proc, SCM ras)
{
- scm_t_array_handle h0;
- size_t n, i0;
- ssize_t i, inc0;
- i0 = SCM_I_ARRAY_BASE (ra0);
- inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
- n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
+ size_t i0 = SCM_I_ARRAY_BASE (ra0);
+ ssize_t inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd + 1;
ra0 = SCM_I_ARRAY_V (ra0);
+ scm_t_array_handle h0;
scm_array_get_handle (ra0, &h0);
+
if (scm_is_null (ras))
for (; n--; i0 += inc0)
h0.vset (h0.vector, i0, scm_call_0 (proc));
else
{
SCM ra1 = SCM_CAR (ras);
- scm_t_array_handle h1;
- size_t i1;
- ssize_t inc1;
- i1 = SCM_I_ARRAY_BASE (ra1);
- inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
ras = SCM_CDR (ras);
+ size_t i1 = SCM_I_ARRAY_BASE (ra1);
+ ssize_t inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
ra1 = SCM_I_ARRAY_V (ra1);
+ scm_t_array_handle h1;
scm_array_get_handle (ra1, &h1);
if (scm_is_null (ras))
for (; n--; i0 += inc0, i1 += inc1)
h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1)));
else
{
- ras = scm_vector (ras);
- for (; n--; i0 += inc0, i1 += inc1, ++i)
+ size_t restn = scm_ilength (ras);
+
+ SCM args = SCM_EOL;
+ SCM *p = &args;
+ SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k)
+ {
+ *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
+ sa[k] = SCM_CARLOC (*p);
+ p = SCM_CDRLOC (*p);
+ }
+
+ scm_t_array_handle *hs = scm_gc_malloc
+ (sizeof(scm_t_array_handle) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k, ras = scm_cdr (ras))
+ scm_array_get_handle (scm_car (ras), hs+k);
+
+ for (ssize_t i = 0; n--; i0 += inc0, i1 += inc1, ++i)
{
- SCM args = SCM_EOL;
- unsigned long k;
- for (k = scm_c_vector_length (ras); k--;)
- args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
- h0.vset (h0.vector, i0,
- scm_apply_1 (proc, h1.vref (h1.vector, i1), args));
+ for (size_t k = 0; k < restn; ++k)
+ *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc);
+ h0.vset (h0.vector, i0, scm_apply_1 (proc, h1.vref (h1.vector, i1), args));
}
+
+ for (size_t k = 0; k < restn; ++k)
+ scm_array_handle_release (hs+k);
}
scm_array_handle_release (&h1);
}
@@ -384,30 +382,44 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
static int
rafe (SCM ra0, SCM proc, SCM ras)
{
- ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
- size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
-
- scm_t_array_handle h0;
- size_t i0;
- ssize_t inc0;
- i0 = SCM_I_ARRAY_BASE (ra0);
- inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ size_t i0 = SCM_I_ARRAY_BASE (ra0);
+ ssize_t inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd + 1;
ra0 = SCM_I_ARRAY_V (ra0);
+ scm_t_array_handle h0;
scm_array_get_handle (ra0, &h0);
+
if (scm_is_null (ras))
for (; n--; i0 += inc0)
scm_call_1 (proc, h0.vref (h0.vector, i0));
else
{
- ras = scm_vector (ras);
- for (; n--; i0 += inc0, ++i)
+ size_t restn = scm_ilength (ras);
+
+ SCM args = SCM_EOL;
+ SCM *p = &args;
+ SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k)
{
- SCM args = SCM_EOL;
- unsigned long k;
- for (k = scm_c_vector_length (ras); k--;)
- args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
+ *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
+ sa[k] = SCM_CARLOC (*p);
+ p = SCM_CDRLOC (*p);
+ }
+
+ scm_t_array_handle *hs = scm_gc_malloc
+ (sizeof(scm_t_array_handle) * restn, vi_gc_hint);
+ for (size_t k = 0; k < restn; ++k, ras = scm_cdr (ras))
+ scm_array_get_handle (scm_car (ras), hs+k);
+
+ for (ssize_t i = 0; n--; i0 += inc0, ++i)
+ {
+ for (size_t k = 0; k < restn; ++k)
+ *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc);
scm_apply_1 (proc, h0.vref (h0.vector, i0), args);
}
+
+ for (size_t k = 0; k < restn; ++k)
+ scm_array_handle_release (hs+k);
}
scm_array_handle_release (&h0);
return 1;
@@ -445,15 +457,12 @@ static void
array_index_map_n (SCM ra, SCM proc)
{
scm_t_array_handle h;
- size_t i;
int k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
- ssize_t *vi;
- SCM **si;
SCM args = SCM_EOL;
SCM *p = &args;
- vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * (kmax + 1), vi_gc_hint);
- si = scm_gc_malloc_pointerless (sizeof(SCM *) * (kmax + 1), vi_gc_hint);
+ ssize_t *vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * (kmax + 1), vi_gc_hint);
+ SCM **si = scm_gc_malloc_pointerless (sizeof(SCM *) * (kmax + 1), vi_gc_hint);
for (k = 0; k <= kmax; k++)
{
@@ -472,7 +481,7 @@ array_index_map_n (SCM ra, SCM proc)
if (k == kmax)
{
vi[kmax] = SCM_I_ARRAY_DIMS (ra)[kmax].lbnd;
- i = cindk (ra, vi, kmax+1);
+ size_t i = cindk (ra, vi, kmax+1);
for (; vi[kmax] <= SCM_I_ARRAY_DIMS (ra)[kmax].ubnd; ++vi[kmax])
{
*(si[kmax]) = scm_from_ssize_t (vi[kmax]);
diff --git a/libguile/array-map.h b/libguile/array-map.h
index e7431b1..cb18a62 100644
--- a/libguile/array-map.h
+++ b/libguile/array-map.h
@@ -4,7 +4,7 @@
#define SCM_ARRAY_MAP_H
/* Copyright (C) 1995, 1996, 1997, 2000, 2006, 2008, 2009, 2010,
- * 2011, 2013 Free Software Foundation, Inc.
+ * 2011, 2013, 2015 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
index c8eaf96..bd8a434 100644
--- a/test-suite/tests/ramap.test
+++ b/test-suite/tests/ramap.test
@@ -453,11 +453,11 @@
(with-test-prefix "3 sources"
(pass-if-equal "noncompact arrays 1"
- '((3 3 3) (2 2 2))
+ '((3 1 3) (2 0 2))
(let* ((a #2((0 1) (2 3)))
(l '())
(rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-row a 1) (array-row a 1) (array-row a 1))
+ (array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1))
l))
(pass-if-equal "noncompact arrays 2"
--
2.7.3
[-- Attachment #11: 0010-Remove-uniform-array-read-uniform-array-write-from-t.patch --]
[-- Type: application/octet-stream, Size: 2167 bytes --]
From a96b4984c30c8e2f44abec1aeeeeafa55e15d6f0 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Thu, 23 Jun 2016 12:15:31 +0200
Subject: [PATCH 10/12] Remove uniform-array-read!, uniform-array-write from
the manual
These procedures where removed in
fc7bd367ab4b5027a7f80686b1e229c62e43c90b (2011-05-12).
* doc/ref/api-compound.texi: Ditto.
---
doc/ref/api-compound.texi | 33 ---------------------------------
1 file changed, 33 deletions(-)
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index ccafa7a..d17c4bf 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1568,39 +1568,6 @@ $\left(\matrix{%
@end example
@end deffn
-@deffn {Scheme Procedure} uniform-array-read! ra [port_or_fd [start [end]]]
-@deffnx {C Function} scm_uniform_array_read_x (ra, port_or_fd, start, end)
-Attempt to read all elements of array @var{ra}, in lexicographic order, as
-binary objects from @var{port_or_fd}.
-If an end of file is encountered,
-the objects up to that point are put into @var{ra}
-(starting at the beginning) and the remainder of the array is
-unchanged.
-
-The optional arguments @var{start} and @var{end} allow
-a specified region of a vector (or linearized array) to be read,
-leaving the remainder of the vector unchanged.
-
-@code{uniform-array-read!} returns the number of objects read.
-@var{port_or_fd} may be omitted, in which case it defaults to the value
-returned by @code{(current-input-port)}.
-@end deffn
-
-@deffn {Scheme Procedure} uniform-array-write ra [port_or_fd [start [end]]]
-@deffnx {C Function} scm_uniform_array_write (ra, port_or_fd, start, end)
-Writes all elements of @var{ra} as binary objects to
-@var{port_or_fd}.
-
-The optional arguments @var{start}
-and @var{end} allow
-a specified region of a vector (or linearized array) to be written.
-
-The number of objects actually written is returned.
-@var{port_or_fd} may be
-omitted, in which case it defaults to the value returned by
-@code{(current-output-port)}.
-@end deffn
-
@node Shared Arrays
@subsubsection Shared Arrays
--
2.7.3
[-- Attachment #12: 0011-Support-typed-arrays-in-some-sort-functions.patch --]
[-- Type: application/octet-stream, Size: 13591 bytes --]
From c338fd7e027e3257fc79715a88de31ac9cf6e835 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Tue, 12 Jul 2016 18:43:03 +0200
Subject: [PATCH 11/12] Support typed arrays in some sort functions
* libguile/sort.c (sort!, sort, restricted-vector-sort!, sorted?):
Support arrays of rank 1, whatever the type.
* libguile/quicksort.i.c: Fix accessors to handle typed arrays.
* test-suite/tests/sort.test: Test also with typed arrays.
---
libguile/quicksort.i.c | 45 ++++++++--------
libguile/sort.c | 126 ++++++++++++++++++++++++++++++---------------
test-suite/tests/sort.test | 32 +++++++++++-
3 files changed, 136 insertions(+), 67 deletions(-)
diff --git a/libguile/quicksort.i.c b/libguile/quicksort.i.c
index 4e39f82..cf1742e 100644
--- a/libguile/quicksort.i.c
+++ b/libguile/quicksort.i.c
@@ -11,7 +11,7 @@
version but doesn't consume extra memory.
*/
-#define SWAP(a, b) do { const SCM _tmp = a; a = b; b = _tmp; } while (0)
+#define SWAP(a, b) do { const SCM _tmp = GET(a); SET(a, GET(b)); SET(b, _tmp); } while (0)
/* Order using quicksort. This implementation incorporates four
@@ -54,8 +54,7 @@
#define STACK_NOT_EMPTY (stack < top)
static void
-NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
- SCM less)
+NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
{
/* Stack node declarations used to store unfulfilled partition obligations. */
typedef struct {
@@ -65,8 +64,6 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
static const char s_buggy_less[] = "buggy less predicate used when sorting";
-#define ELT(i) base_ptr[(i)*INC]
-
if (nr_elems == 0)
/* Avoid lossage with unsigned arithmetic below. */
return;
@@ -93,17 +90,17 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
SCM_TICK;
- if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo))))
- SWAP (ELT(mid), ELT(lo));
- if (scm_is_true (scm_call_2 (less, ELT(hi), ELT(mid))))
- SWAP (ELT(mid), ELT(hi));
+ if (scm_is_true (scm_call_2 (less, GET(mid), GET(lo))))
+ SWAP (mid, lo);
+ if (scm_is_true (scm_call_2 (less, GET(hi), GET(mid))))
+ SWAP (mid, hi);
else
goto jump_over;
- if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo))))
- SWAP (ELT(mid), ELT(lo));
+ if (scm_is_true (scm_call_2 (less, GET(mid), GET(lo))))
+ SWAP (mid, lo);
jump_over:;
- pivot = ELT(mid);
+ pivot = GET(mid);
left = lo + 1;
right = hi - 1;
@@ -112,7 +109,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
that this algorithm runs much faster than others. */
do
{
- while (scm_is_true (scm_call_2 (less, ELT(left), pivot)))
+ while (scm_is_true (scm_call_2 (less, GET(left), pivot)))
{
left += 1;
/* The comparison predicate may be buggy */
@@ -120,7 +117,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
scm_misc_error (NULL, s_buggy_less, SCM_EOL);
}
- while (scm_is_true (scm_call_2 (less, pivot, ELT(right))))
+ while (scm_is_true (scm_call_2 (less, pivot, GET(right))))
{
right -= 1;
/* The comparison predicate may be buggy */
@@ -130,7 +127,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
if (left < right)
{
- SWAP (ELT(left), ELT(right));
+ SWAP (left, right);
left += 1;
right -= 1;
}
@@ -192,11 +189,11 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
and the operation speeds up insertion sort's inner loop. */
for (run = tmp + 1; run <= thresh; run += 1)
- if (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp))))
+ if (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
tmp = run;
if (tmp != 0)
- SWAP (ELT(tmp), ELT(0));
+ SWAP (tmp, 0);
/* Insertion sort, running from left-hand-side up to right-hand-side. */
@@ -206,7 +203,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
SCM_TICK;
tmp = run - 1;
- while (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp))))
+ while (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
{
/* The comparison predicate may be buggy */
if (tmp == 0)
@@ -218,12 +215,12 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
tmp += 1;
if (tmp != run)
{
- SCM to_insert = ELT(run);
+ SCM to_insert = GET(run);
size_t hi, lo;
for (hi = lo = run; --lo >= tmp; hi = lo)
- ELT(hi) = ELT(lo);
- ELT(hi) = to_insert;
+ SET(hi, GET(lo));
+ SET(hi, to_insert);
}
}
}
@@ -235,9 +232,9 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
#undef PUSH
#undef POP
#undef STACK_NOT_EMPTY
-#undef ELT
+#undef GET
+#undef SET
#undef NAME
#undef INC_PARAM
-#undef INC
-
+#undef VEC_PARAM
diff --git a/libguile/sort.c b/libguile/sort.c
index 9373fb8..c3cc103 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -51,21 +51,23 @@
#include "libguile/validate.h"
#include "libguile/sort.h"
-/* We have two quicksort variants: one for contigous vectors and one
- for vectors with arbitrary increments between elements. Note that
- increments can be negative.
+/* We have two quicksort variants: one for SCM (#t) arrays and one for
+ typed arrays.
*/
-#define NAME quicksort1
-#define INC_PARAM /* empty */
-#define INC 1
-#include "libguile/quicksort.i.c"
-
#define NAME quicksort
#define INC_PARAM ssize_t inc,
-#define INC inc
+#define VEC_PARAM SCM * ra,
+#define GET(i) ra[(i)*inc]
+#define SET(i, val) ra[(i)*inc] = val
#include "libguile/quicksort.i.c"
+#define NAME quicksorta
+#define INC_PARAM
+#define VEC_PARAM scm_t_array_handle * const ra,
+#define GET(i) scm_array_handle_ref (ra, scm_array_handle_pos_1 (ra, i))
+#define SET(i, val) scm_array_handle_set (ra, scm_array_handle_pos_1 (ra, i), val)
+#include "libguile/quicksort.i.c"
SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
(SCM vec, SCM less, SCM startpos, SCM endpos),
@@ -76,22 +78,38 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
"is not specified.")
#define FUNC_NAME s_scm_restricted_vector_sort_x
{
- size_t vlen, spos, len;
- ssize_t vinc;
+ ssize_t spos = scm_to_ssize_t (startpos);
+ size_t epos = scm_to_ssize_t (endpos);
+
scm_t_array_handle handle;
- SCM *velts;
+ scm_array_get_handle (vec, &handle);
+ scm_t_array_dim const * dims = scm_array_handle_dims (&handle);
- velts = scm_vector_writable_elements (vec, &handle, &vlen, &vinc);
- spos = scm_to_unsigned_integer (startpos, 0, vlen);
- len = scm_to_unsigned_integer (endpos, spos, vlen) - spos;
+ if (scm_array_handle_rank(&handle) != 1)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", vec, SCM_EOL);
+ }
+ if (spos < dims[0].lbnd)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_out_of_range_key, FUNC_NAME, "startpos out of range",
+ vec, scm_list_1(startpos));
+ }
+ if (epos > dims[0].ubnd+1)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_out_of_range_key, FUNC_NAME, "endpos out of range",
+ vec, scm_list_1(endpos));
+ }
- if (vinc == 1)
- quicksort1 (velts + spos*vinc, len, less);
+ if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
+ quicksort (scm_array_handle_writable_elements (&handle) + (spos-dims[0].lbnd) * dims[0].inc,
+ epos-spos, dims[0].inc, less);
else
- quicksort (velts + spos*vinc, len, vinc, less);
+ quicksorta (&handle, epos-spos, less);
scm_array_handle_release (&handle);
-
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -140,29 +158,48 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
}
else
{
- scm_t_array_handle handle;
- size_t i, len;
- ssize_t inc;
- const SCM *elts;
SCM result = SCM_BOOL_T;
- elts = scm_vector_elements (items, &handle, &len, &inc);
-
- for (i = 1; i < len; i++, elts += inc)
- {
- if (scm_is_true (scm_call_2 (less, elts[inc], elts[0])))
- {
- result = SCM_BOOL_F;
- break;
- }
- }
+ scm_t_array_handle handle;
+ scm_array_get_handle (items, &handle);
+ scm_t_array_dim const * dims = scm_array_handle_dims (&handle);
+
+ if (scm_array_handle_rank(&handle) != 1)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items, SCM_EOL);
+ }
+
+ if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
+ {
+ ssize_t inc = dims[0].inc;
+ const SCM *elts = scm_array_handle_elements (&handle);
+ for (ssize_t i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i, elts += inc)
+ {
+ if (scm_is_true (scm_call_2 (less, elts[inc], elts[0])))
+ {
+ result = SCM_BOOL_F;
+ break;
+ }
+ }
+ }
+ else
+ {
+ for (ssize_t i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i)
+ {
+ if (scm_is_true (scm_call_2 (less,
+ scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i)),
+ scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i-1)))))
+ {
+ result = SCM_BOOL_F;
+ break;
+ }
+ }
+ }
scm_array_handle_release (&handle);
-
return result;
}
-
- return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -404,7 +441,13 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
if (scm_is_pair (items))
return scm_sort_x (scm_list_copy (items), less);
else if (scm_is_array (items) && scm_c_array_rank (items) == 1)
- return scm_sort_x (scm_vector_copy (items), less);
+ {
+ if (scm_c_array_rank (items) != 1)
+ scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items, SCM_EOL);
+ SCM copy = scm_make_typed_array (scm_array_type (items), SCM_UNSPECIFIED, scm_array_dimensions (items));
+ scm_array_copy_x (items, copy);
+ return scm_sort_x (copy, less);
+ }
else
SCM_WRONG_TYPE_ARG (1, items);
}
@@ -498,10 +541,11 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
vec_elts = scm_vector_writable_elements (items, &vec_handle,
&len, &inc);
- if (len == 0) {
- scm_array_handle_release (&vec_handle);
- return items;
- }
+ if (len == 0)
+ {
+ scm_array_handle_release (&vec_handle);
+ return items;
+ }
temp = scm_c_make_vector (len, SCM_UNDEFINED);
temp_elts = scm_vector_writable_elements (temp, &temp_handle,
diff --git a/test-suite/tests/sort.test b/test-suite/tests/sort.test
index 9209b53..249f890 100644
--- a/test-suite/tests/sort.test
+++ b/test-suite/tests/sort.test
@@ -31,22 +31,51 @@
exception:wrong-num-args
(sort '(1 2) (lambda (x y z) z)))
- (pass-if "sort!"
+ (pass-if "sort of vector"
+ (let* ((v (randomize-vector! (make-vector 1000) 1000))
+ (w (vector-copy v)))
+ (and (sorted? (sort v <) <)
+ (equal? w v))))
+
+ (pass-if "sort of typed array"
+ (let* ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99))
+ (w (make-typed-array 'f64 *unspecified* 99)))
+ (array-copy! v w)
+ (and (sorted? (sort v <) <)
+ (equal? w v))))
+
+ (pass-if "sort! of vector"
(let ((v (randomize-vector! (make-vector 1000) 1000)))
(sorted? (sort! v <) <)))
+ (pass-if "sort! of typed array"
+ (let ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99)))
+ (sorted? (sort! v <) <)))
+
(pass-if "sort! of non-contigous vector"
(let* ((a (make-array 0 1000 3))
(v (make-shared-array a (lambda (i) (list i 0)) 1000)))
(randomize-vector! v 1000)
(sorted? (sort! v <) <)))
+ (pass-if "sort! of non-contigous typed array"
+ (let* ((a (make-typed-array 'f64 0 99 3))
+ (v (make-shared-array a (lambda (i) (list i 0)) 99)))
+ (randomize-vector! v 99)
+ (sorted? (sort! v <) <)))
+
(pass-if "sort! of negative-increment vector"
(let* ((a (make-array 0 1000 3))
(v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000)))
(randomize-vector! v 1000)
(sorted? (sort! v <) <)))
+ (pass-if "sort! of negative-increment typed array"
+ (let* ((a (make-typed-array 'f64 0 99 3))
+ (v (make-shared-array a (lambda (i) (list (- 98 i) 0)) 99)))
+ (randomize-vector! v 99)
+ (sorted? (sort! v <) <)))
+
(pass-if "stable-sort!"
(let ((v (randomize-vector! (make-vector 1000) 1000)))
(sorted? (stable-sort! v <) <)))
@@ -79,4 +108,3 @@
;; behavior (integer underflow) leading to crashes.
(pass-if "empty vector"
(equal? '#() (stable-sort '#() <))))
-
--
2.7.3
[-- Attachment #13: 0012-New-functions-array-for-each-cell-array-for-each-cel.patch --]
[-- Type: application/octet-stream, Size: 59458 bytes --]
From 2bea30576ed2f9b3c2f50efac4b46f7492b664fe Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Tue, 8 Sep 2015 16:57:30 +0200
Subject: [PATCH 12/12] New functions (array-for-each-cell,
array-for-each-cell-in-order)
* libguile/array-map.c (scm_i_array_rebase, scm_array_for_each_cell):
New functions. Export scm_array_for_each_cell() as
(array-for-each-cell).
(array-for-each-cell-in-order): Define additional export.
* libguile/array-map.h (scm_i_array_rebase, scm_array_for_each_cell):
Add prototypes.
* doc/ref/api-compound.texi: New section 'Arrays as arrays of
arrays'. Move the documentation for (array-from), (array-from*) and
(array-amend!) in here. Add documentation for (array-for-each-cell).
* test-suite/tests/array-map.test: Renamed from
test-suite/tests/ramap.test, fix module name. Add tests for
(array-for-each-cell).
* test-suite/Makefile.am: Apply rename array-map.test -> ramap.test.
* doc/ref/api-compound.texi: Minor documentation fixes.
---
doc/ref/api-compound.texi | 169 +++++++++----
libguile/array-map.c | 265 +++++++++++++++++++-
libguile/array-map.h | 4 +
libguile/arrays.c | 5 +-
test-suite/Makefile.am | 2 +-
test-suite/tests/array-map.test | 540 ++++++++++++++++++++++++++++++++++++++++
test-suite/tests/ramap.test | 509 -------------------------------------
7 files changed, 928 insertions(+), 566 deletions(-)
create mode 100644 test-suite/tests/array-map.test
delete mode 100644 test-suite/tests/ramap.test
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index d17c4bf..bc2c98b 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1203,6 +1203,7 @@ dimensional arrays.
* Array Syntax::
* Array Procedures::
* Shared Arrays::
+* Arrays as arrays of arrays::
* Accessing Arrays from C::
@end menu
@@ -1682,24 +1683,91 @@ sample points are enough because @var{mapfunc} is linear.
Return the element at @code{(idx @dots{})} in @var{array}.
@end deffn
+
+@deffn {Scheme Procedure} shared-array-increments array
+@deffnx {C Function} scm_shared_array_increments (array)
+For each dimension, return the distance between elements in the root vector.
+@end deffn
+
+@deffn {Scheme Procedure} shared-array-offset array
+@deffnx {C Function} scm_shared_array_offset (array)
+Return the root vector index of the first element in the array.
+@end deffn
+
+@deffn {Scheme Procedure} shared-array-root array
+@deffnx {C Function} scm_shared_array_root (array)
+Return the root vector of a shared array.
+@end deffn
+
+@deffn {Scheme Procedure} array-contents array [strict]
+@deffnx {C Function} scm_array_contents (array, strict)
+If @var{array} may be @dfn{unrolled} into a one dimensional shared array
+without changing their order (last subscript changing fastest), then
+@code{array-contents} returns that shared array, otherwise it returns
+@code{#f}. All arrays made by @code{make-array} and
+@code{make-typed-array} may be unrolled, some arrays made by
+@code{make-shared-array} may not be.
+
+If the optional argument @var{strict} is provided, a shared array will
+be returned only if its elements are stored internally contiguous in
+memory.
+@end deffn
+
+@deffn {Scheme Procedure} transpose-array array dim1 dim2 @dots{}
+@deffnx {C Function} scm_transpose_array (array, dimlist)
+Return an array sharing contents with @var{array}, but with
+dimensions arranged in a different order. There must be one
+@var{dim} argument for each dimension of @var{array}.
+@var{dim1}, @var{dim2}, @dots{} should be integers between 0
+and the rank of the array to be returned. Each integer in that
+range must appear at least once in the argument list.
+
+The values of @var{dim1}, @var{dim2}, @dots{} correspond to
+dimensions in the array to be returned, and their positions in the
+argument list to dimensions of @var{array}. Several @var{dim}s
+may have the same value, in which case the returned array will
+have smaller rank than @var{array}.
+
+@lisp
+(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))
+(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)
+(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}
+ #2((a 4) (b 5) (c 6))
+@end lisp
+@end deffn
+
+@node Arrays as arrays of arrays
+@subsubsection Arrays as arrays of arrays
+
+The functions in this section allow you to treat an array of rank
+@math{n} as an array of lower rank @math{n-k} where the elements are
+themselves arrays (`cells') of rank @math{k}. This replicates some of
+the functionality of `enclosed arrays', a feature of old Guile that was
+removed before @w{version 2.0}. However, these functions do not require
+a special type and operate on any array.
+
+When we operate on an array in this way, we speak of the first @math{k}
+dimensions of the array as the @math{k}-`frame' of the array, while the
+last @math{n-k} dimensions are the dimensions of the
+@math{n-k}-`cell'. For example, a 2D-array (a matrix) can be seen as a
+1D array of rows. In this case, the rows are the 1-cells of the array.
+
@deffn {Scheme Procedure} array-from array idx @dots{}
@deffnx {C Function} scm_array_from (array, idxlist)
If the length of @var{idxlist} equals the rank @math{n} of
@var{array}, return the element at @code{(idx @dots{})}, just like
@code{(array-ref array idx @dots{})}. If, however, the length @math{k}
of @var{idxlist} is shorter than @math{n}, then return the shared
-@math{(n-k)}-rank prefix cell of @var{array} given by @var{idxlist}.
+@math{(n-k)}-rank cell of @var{array} given by @var{idxlist}.
For example:
-@example
@lisp
(array-from #2((a b) (c d)) 0) @result{} #(a b)
(array-from #2((a b) (c d)) 1) @result{} #(c d)
(array-from #2((a b) (c d)) 1 1) @result{} d
(array-from #2((a b) (c d))) @result{} #2((a b) (c d))
@end lisp
-@end example
@code{(apply array-from array indices)} is equivalent to
@@ -1719,12 +1787,11 @@ The name `from' comes from the J language.
@deffnx {C Function} scm_array_from_s (array, idxlist)
Like @code{(array-from array idx @dots{})}, but return a 0-rank shared
array if the length of @var{idxlist} matches the rank of
-@var{array}. This can be useful when using @var{ARRAY} as destination
-of copies.
+@var{array}. This can be useful when using @var{ARRAY} as a place to
+write into.
Compare:
-@example
@lisp
(array-from #2((a b) (c d)) 1 1) @result{} d
(array-from* #2((a b) (c d)) 1) @result{} #0(d)
@@ -1733,7 +1800,6 @@ Compare:
a @result{} #2((a a) (a b)).
(array-fill! (array-from a 1 1) 'b) @result{} error: not an array
@end lisp
-@end example
@code{(apply array-from* array indices)} is equivalent to
@@ -1752,7 +1818,7 @@ If the length of @var{idxlist} equals the rank @math{n} of
@var{x}, just like @code{(array-set! array x idx @dots{})}. If,
however, the length @math{k} of @var{idxlist} is shorter than
@math{n}, then copy the @math{(n-k)}-rank array @var{x}
-into @math{(n-k)}-rank prefix cell of @var{array} given by
+into the @math{(n-k)}-cell of @var{array} given by
@var{idxlist}. In this case, the last @math{(n-k)} dimensions of
@var{array} and the dimensions of @var{x} must match exactly.
@@ -1760,12 +1826,19 @@ This function returns the modified @var{array}.
For example:
-@example
@lisp
(array-amend! (make-array 'a 2 2) b 1 1) @result{} #2((a a) (a b))
(array-amend! (make-array 'a 2 2) #(x y) 1) @result{} #2((a a) (x y))
@end lisp
-@end example
+
+Note that @code{array-amend!} will expect elements, not arrays, when the
+destination has rank 0. One can work around this using
+@code{array-from*} instead.
+
+@lisp
+(array-amend! (make-array 'a 2 2) #0(b) 1 1) @result{} #2((a a) (a #0(b)))
+(let ((a (make-array 'a 2 2))) (array-copy! #0(b) (array-from* a 1 1)) a) @result{} #2((a a) (a b))
+@end lisp
@code{(apply array-amend! array x indices)} is equivalent to
@@ -1781,58 +1854,52 @@ The name `amend' comes from the J language.
@end deffn
-@deffn {Scheme Procedure} shared-array-increments array
-@deffnx {C Function} scm_shared_array_increments (array)
-For each dimension, return the distance between elements in the root vector.
-@end deffn
+@deffn {Scheme Procedure} array-for-each-cell frame-rank op x @dots{}
+@deffnx {C Function} scm_array_for_each_cell (array, frame_rank, op, xlist)
+Each @var{x} must be an array of rank ≥ @var{frame-rank}, and
+the first @var{frame-rank} dimensions of each @var{x} must all be the
+same. @var{array-for-each-cell} calls @var{op} with each set of
+(rank(@var{x}) - @var{frame-rank})-cells from @var{x}, in unspecified order.
-@deffn {Scheme Procedure} shared-array-offset array
-@deffnx {C Function} scm_shared_array_offset (array)
-Return the root vector index of the first element in the array.
-@end deffn
+@var{array-for-each-cell} allows you to loop over cells of any rank
+without having to carry an index list or construct slices manually. The
+cells passed to @var{op} are shared arrays of @var{X} so it is possible
+to write to them.
-@deffn {Scheme Procedure} shared-array-root array
-@deffnx {C Function} scm_shared_array_root (array)
-Return the root vector of a shared array.
-@end deffn
+This function returns an unspecified value.
-@deffn {Scheme Procedure} array-contents array [strict]
-@deffnx {C Function} scm_array_contents (array, strict)
-If @var{array} may be @dfn{unrolled} into a one dimensional shared array
-without changing their order (last subscript changing fastest), then
-@code{array-contents} returns that shared array, otherwise it returns
-@code{#f}. All arrays made by @code{make-array} and
-@code{make-typed-array} may be unrolled, some arrays made by
-@code{make-shared-array} may not be.
+For example, to sort the rows of rank-2 array @code{a}:
-If the optional argument @var{strict} is provided, a shared array will
-be returned only if its elements are stored internally contiguous in
-memory.
-@end deffn
+@lisp
+(array-for-each-cell 1 (lambda (x) (sort! x <)) a)
+@end lisp
-@deffn {Scheme Procedure} transpose-array array dim1 dim2 @dots{}
-@deffnx {C Function} scm_transpose_array (array, dimlist)
-Return an array sharing contents with @var{array}, but with
-dimensions arranged in a different order. There must be one
-@var{dim} argument for each dimension of @var{array}.
-@var{dim1}, @var{dim2}, @dots{} should be integers between 0
-and the rank of the array to be returned. Each integer in that
-range must appear at least once in the argument list.
+As another example, let @code{a} be a rank-2 array where each row is a 2-vector @math{(x,y)}.
+Let's compute the arguments of these vectors and store them in rank-1 array @code{b}.
+@lisp
+(array-for-each-cell 1
+ (lambda (a b)
+ (array-set! b (atan (array-ref a 1) (array-ref a 0))))
+ a b)
+@end lisp
-The values of @var{dim1}, @var{dim2}, @dots{} correspond to
-dimensions in the array to be returned, and their positions in the
-argument list to dimensions of @var{array}. Several @var{dim}s
-may have the same value, in which case the returned array will
-have smaller rank than @var{array}.
+@code{(apply array-for-each-cell frame-rank op x)} is functionally
+equivalent to
@lisp
-(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))
-(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)
-(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}
- #2((a 4) (b 5) (c 6))
+(let ((frame (take (array-dimensions (car x)) frank)))
+ (unless (every (lambda (x)
+ (equal? frame (take (array-dimensions x) frank)))
+ (cdr x))
+ (error))
+ (array-index-map!
+ (apply make-shared-array (make-array #t) (const '()) frame)
+ (lambda i (apply op (map (lambda (x) (apply array-from* x i)) x)))))
@end lisp
+
@end deffn
+
@node Accessing Arrays from C
@subsubsection Accessing Arrays from C
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 058b6fe..396aafe 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -42,7 +42,7 @@
#include "libguile/validate.h"
#include "libguile/array-map.h"
-\f
+#include <assert.h>
/* The WHAT argument for `scm_gc_malloc ()' et al. */
static const char vi_gc_hint[] = "array-indices";
@@ -610,7 +610,8 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
return SCM_BOOL_T;
while (!scm_is_null (rest))
- { if (scm_is_false (scm_array_equal_p (ra0, ra1)))
+ {
+ if (scm_is_false (scm_array_equal_p (ra0, ra1)))
return SCM_BOOL_F;
ra0 = ra1;
ra1 = scm_car (rest);
@@ -621,6 +622,265 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
#undef FUNC_NAME
+// Copy array descriptor with different base.
+SCM
+scm_i_array_rebase (SCM a, size_t base)
+{
+ size_t ndim = SCM_I_ARRAY_NDIM (a);
+ SCM b = scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3);
+ SCM_I_ARRAY_SET_V (b, SCM_I_ARRAY_V (a));
+// FIXME do check base
+ SCM_I_ARRAY_SET_BASE (b, base);
+ memcpy (SCM_I_ARRAY_DIMS (b), SCM_I_ARRAY_DIMS (a), sizeof (scm_t_array_dim)*ndim);
+ return b;
+}
+
+static inline size_t padtoptr(size_t d) { return (d + (sizeof (void *) - 1)) & ~(sizeof (void *) - 1); }
+
+SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1,
+ (SCM frame_rank, SCM op, SCM args),
+ "Apply @var{op} to each of the cells of rank rank(@var{arg})-@var{frame_rank}\n"
+ "of the arrays @var{args}, in unspecified order. The first\n"
+ "@var{frame_rank} dimensions of each @var{arg} must match.\n"
+ "Rank-0 cells are passed as rank-0 arrays.\n\n"
+ "The value returned is unspecified.\n\n"
+ "For example:\n"
+ "@lisp\n"
+ ";; Sort the rows of rank-2 array A.\n\n"
+ "(array-for-each-cell 1 (lambda (x) (sort! x <)) a)\n"
+ "\n"
+ ";; Compute the arguments of the (x y) vectors in the rows of rank-2\n"
+ ";; array XYS and store them in rank-1 array ANGLES. Inside OP,\n"
+ ";; XY is a rank-1 (2-1) array, and ANGLE is a rank-0 (1-1) array.\n\n"
+ "(array-for-each-cell 1 \n"
+ " (lambda (xy angle)\n"
+ " (array-set! angle (atan (array-ref xy 1) (array-ref xy 0))))\n"
+ " xys angles)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_for_each_cell
+{
+ int const N = scm_ilength (args);
+ int const frank = scm_to_int (frame_rank);
+ SCM dargs_ = SCM_EOL;
+
+ size_t stack_size = 0;
+ stack_size += padtoptr(N*sizeof (scm_t_array_handle));
+ stack_size += padtoptr(N*sizeof (SCM));
+ stack_size += padtoptr(N*sizeof (scm_t_array_dim *));
+ stack_size += padtoptr(N*sizeof (int));
+
+ stack_size += padtoptr(frank*sizeof (ssize_t));
+ stack_size += padtoptr(N*sizeof (SCM));
+ stack_size += padtoptr(N*sizeof (SCM *));
+ stack_size += padtoptr(frank*sizeof (ssize_t));
+
+ stack_size += padtoptr(frank*sizeof (int));
+ stack_size += padtoptr(N*sizeof (size_t));
+ char * stack = scm_gc_malloc (stack_size, "stack");
+
+#define AFIC_ALLOC_ADVANCE(stack, count, type, name) \
+ type * name = (void *)stack; \
+ stack += padtoptr(count*sizeof (type));
+
+ char * stack0 = stack;
+ AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_handle, ah);
+ AFIC_ALLOC_ADVANCE (stack, N, SCM, args_);
+ AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_dim *, as);
+ AFIC_ALLOC_ADVANCE (stack, N, int, rank);
+
+ AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, s);
+ AFIC_ALLOC_ADVANCE (stack, N, SCM, ai);
+ AFIC_ALLOC_ADVANCE (stack, N, SCM *, dargs);
+ AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, i);
+
+ AFIC_ALLOC_ADVANCE (stack, frank, int, order);
+ AFIC_ALLOC_ADVANCE (stack, N, size_t, base);
+ assert((stack0+stack_size==stack) && "internal error");
+#undef AFIC_ALLOC_ADVANCE
+
+ for (int n=0; scm_is_pair(args); args=scm_cdr(args), ++n)
+ {
+ args_[n] = scm_car(args);
+ scm_array_get_handle(args_[n], ah+n);
+ as[n] = scm_array_handle_dims(ah+n);
+ rank[n] = scm_array_handle_rank(ah+n);
+ }
+ // checks.
+ char const * msg = NULL;
+ if (frank<0)
+ {
+ msg = "bad frame rank";
+ }
+ else
+ {
+ for (int n=0; n!=N; ++n)
+ {
+ if (rank[n]<frank)
+ {
+ msg = "frame too large for arguments";
+ goto check_msg;
+ }
+ for (int k=0; k!=frank; ++k)
+ {
+ if (as[n][k].lbnd!=0)
+ {
+ msg = "non-zero base index is not supported";
+ goto check_msg;
+ }
+ if (as[0][k].ubnd!=as[n][k].ubnd)
+ {
+ msg = "mismatched frames";
+ goto check_msg;
+ }
+ s[k] = as[n][k].ubnd + 1;
+
+ // this check is needed if the array cannot be entirely
+ // unrolled, because the unrolled subloop will be run before
+ // checking the dimensions of the frame.
+ if (s[k]==0)
+ {
+ goto end;
+ }
+ }
+ }
+ }
+ check_msg: ;
+ if (msg!=NULL)
+ {
+ for (int n=0; n!=N; ++n)
+ {
+ scm_array_handle_release(ah+n);
+ }
+ scm_misc_error("array-for-each-cell", msg, scm_cons_star(frame_rank, args));
+ }
+ // prepare moving cells.
+ for (int n=0; n!=N; ++n)
+ {
+ ai[n] = scm_i_make_array(rank[n]-frank);
+ SCM_I_ARRAY_SET_V (ai[n], scm_shared_array_root(args_[n]));
+ // FIXME scm_array_handle_base (ah+n) should be in Guile
+ SCM_I_ARRAY_SET_BASE (ai[n], ah[n].base);
+ scm_t_array_dim * ais = SCM_I_ARRAY_DIMS(ai[n]);
+ for (int k=frank; k!=rank[n]; ++k)
+ {
+ ais[k-frank] = as[n][k];
+ }
+ }
+ // prepare rest list for callee.
+ {
+ SCM *p = &dargs_;
+ for (int n=0; n<N; ++n)
+ {
+ *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
+ dargs[n] = SCM_CARLOC (*p);
+ p = SCM_CDRLOC (*p);
+ }
+ }
+ // special case for rank 0.
+ if (frank==0)
+ {
+ for (int n=0; n<N; ++n)
+ {
+ *dargs[n] = ai[n];
+ }
+ scm_apply_0(op, dargs_);
+ for (int n=0; n<N; ++n)
+ {
+ scm_array_handle_release(ah+n);
+ }
+ return SCM_UNSPECIFIED;
+ }
+ // FIXME determine best looping order.
+ for (int k=0; k!=frank; ++k)
+ {
+ i[k] = 0;
+ order[k] = frank-1-k;
+ }
+ // find outermost compact dim.
+ ssize_t step = s[order[0]];
+ int ocd = 1;
+ for (; ocd<frank; step *= s[order[ocd]], ++ocd)
+ {
+ for (int n=0; n!=N; ++n)
+ {
+ if (step*as[n][order[0]].inc!=as[n][order[ocd]].inc)
+ {
+ goto ocd_reached;
+ }
+ }
+ }
+ ocd_reached: ;
+ // rank loop.
+ for (int n=0; n!=N; ++n)
+ {
+ base[n] = SCM_I_ARRAY_BASE(ai[n]);
+ }
+ for (;;)
+ {
+ // unrolled loop.
+ for (ssize_t z=0; z!=step; ++z)
+ {
+ // we are forced to create fresh array descriptors for each
+ // call since we don't know whether the callee will keep them,
+ // and Guile offers no way to copy the descriptor (since
+ // descriptors are immutable). Yet another reason why this
+ // should be in Scheme.
+ for (int n=0; n<N; ++n)
+ {
+ *dargs[n] = scm_i_array_rebase(ai[n], base[n]);
+ base[n] += as[n][order[0]].inc;
+ }
+ scm_apply_0(op, dargs_);
+ }
+ for (int n=0; n<N; ++n)
+ {
+ base[n] -= step*as[n][order[0]].inc;
+ }
+ for (int k=ocd; ; ++k)
+ {
+ if (k==frank)
+ {
+ goto end;
+ }
+ else if (i[order[k]]<s[order[k]]-1)
+ {
+ ++i[order[k]];
+ for (int n=0; n<N; ++n)
+ {
+ base[n] += as[n][order[k]].inc;
+ }
+ break;
+ }
+ else
+ {
+ i[order[k]] = 0;
+ for (int n=0; n<N; ++n)
+ {
+ base[n] += as[n][order[k]].inc*(1-s[order[k]]);
+ }
+ }
+ }
+ }
+ end:;
+ for (int n=0; n<N; ++n)
+ {
+ scm_array_handle_release(ah+n);
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_array_for_each_cell_in_order, "array-for-each-cell-in-order", 2, 0, 1,
+ (SCM frank, SCM op, SCM a),
+ "Same as array-for-each-cell, but visit the cells sequentially\n"
+ "and in row-major order.\n")
+#define FUNC_NAME s_scm_array_for_each_cell_in_order
+{
+ return scm_array_for_each_cell (frank, op, a);
+}
+#undef FUNC_NAME
+
+
void
scm_init_array_map (void)
{
@@ -628,6 +888,7 @@ scm_init_array_map (void)
scm_add_feature (s_scm_array_for_each);
}
+
/*
Local Variables:
c-file-style: "gnu"
diff --git a/libguile/array-map.h b/libguile/array-map.h
index cb18a62..acfdd5e 100644
--- a/libguile/array-map.h
+++ b/libguile/array-map.h
@@ -37,6 +37,10 @@ SCM_API SCM scm_array_map_x (SCM ra0, SCM proc, SCM lra);
SCM_API SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra);
SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc);
SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1);
+SCM_API SCM scm_array_for_each_cell (SCM frank, SCM op, SCM args);
+SCM_API SCM scm_array_for_each_cell_in_order (SCM frank, SCM op, SCM args);
+
+SCM_INTERNAL SCM scm_i_array_rebase (SCM a, size_t base);
SCM_INTERNAL void scm_init_array_map (void);
#endif /* SCM_ARRAY_MAP_H */
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 26c4543..d360cda 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -28,7 +28,6 @@
#include <stdio.h>
#include <errno.h>
#include <string.h>
-#include <assert.h>
#include "verify.h"
@@ -546,7 +545,7 @@ SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
{ ARRAY_FROM_GET_O }
scm_array_handle_release(&handle);
/* an error is still possible here if o and b don't match. */
- /* TODO copying like this wastes the handle, and the bounds matching
+ /* FIXME copying like this wastes the handle, and the bounds matching
behavior of array-copy! is not strict. */
scm_array_copy_x(b, o);
}
@@ -564,7 +563,6 @@ SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1,
}
#undef FUNC_NAME
-
#undef ARRAY_FROM_POS
#undef ARRAY_FROM_GET_O
@@ -943,6 +941,7 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
}
+
void
scm_init_arrays ()
{
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 473501e..49584b9 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -115,7 +115,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/r6rs-records-syntactic.test \
tests/r6rs-unicode.test \
tests/rnrs-libraries.test \
- tests/ramap.test \
+ tests/array-map.test \
tests/random.test \
tests/rdelim.test \
tests/reader.test \
diff --git a/test-suite/tests/array-map.test b/test-suite/tests/array-map.test
new file mode 100644
index 0000000..3095b78
--- /dev/null
+++ b/test-suite/tests/array-map.test
@@ -0,0 +1,540 @@
+;;;; array-map.test --- test array mapping functions -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2004, 2005, 2006, 2009, 2013 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-array-map)
+ #:use-module (test-suite lib))
+
+(define exception:shape-mismatch
+ (cons 'misc-error ".*shape mismatch.*"))
+
+(define (array-row a i)
+ (make-shared-array a (lambda (j) (list i j))
+ (cadr (array-dimensions a))))
+
+(define (array-col a j)
+ (make-shared-array a (lambda (i) (list i j))
+ (car (array-dimensions a))))
+
+;;;
+;;; array-index-map!
+;;;
+
+(with-test-prefix "array-index-map!"
+
+ (pass-if "basic test"
+ (let ((nlst '()))
+ (array-index-map! (make-array #f '(1 1))
+ (lambda (n)
+ (set! nlst (cons n nlst))))
+ (equal? nlst '(1))))
+
+ (with-test-prefix "empty arrays"
+
+ (pass-if "all axes empty"
+ (array-index-map! (make-typed-array 'f64 0 0 0) (const 0))
+ (array-index-map! (make-typed-array 'b #t 0 0) (const #t))
+ (array-index-map! (make-typed-array #t 0 0 0) (const 0))
+ #t)
+
+ (pass-if "last axis empty"
+ (array-index-map! (make-typed-array 'f64 0 2 0) (const 0))
+ (array-index-map! (make-typed-array 'b #t 2 0) (const #t))
+ (array-index-map! (make-typed-array #t 0 2 0) (const 0))
+ #t)
+
+ ; the 'f64 cases fail in 2.0.9 with out-of-range.
+ (pass-if "axis empty, other than last"
+ (array-index-map! (make-typed-array 'f64 0 0 2) (const 0))
+ (array-index-map! (make-typed-array 'b #t 0 2) (const #t))
+ (array-index-map! (make-typed-array #t 0 0 2) (const 0))
+ #t))
+
+ (pass-if "rank 2"
+ (let ((a (make-array 0 2 2))
+ (b (make-array 0 2 2)))
+ (array-index-map! a (lambda (i j) i))
+ (array-index-map! b (lambda (i j) j))
+ (and (array-equal? a #2((0 0) (1 1)))
+ (array-equal? b #2((0 1) (0 1)))))))
+
+;;;
+;;; array-copy!
+;;;
+
+(with-test-prefix "array-copy!"
+
+ (with-test-prefix "empty arrays"
+
+ (pass-if "empty other than last, #t"
+ (let* ((b (make-array 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-copy! #2:0:2() c)
+ (array-equal? #2:0:2() c)))
+
+ (pass-if "empty other than last, 'f64"
+ (let* ((b (make-typed-array 'f64 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-copy! #2:0:2() c)
+ (array-equal? #2f64:0:2() c)))
+
+ ;; FIXME add empty, type 'b cases.
+
+ )
+
+ ;; note that it is the opposite of array-map!. This is, unfortunately,
+ ;; documented in the manual.
+
+ (pass-if "matching behavior I"
+ (let ((a #(1 2))
+ (b (make-array 0 3)))
+ (array-copy! a b)
+ (equal? b #(1 2 0))))
+
+ (pass-if-exception "matching behavior II" exception:shape-mismatch
+ (let ((a #(1 2 3))
+ (b (make-array 0 2)))
+ (array-copy! a b)
+ (equal? b #(1 2))))
+
+ ;; here both a & b are are unrollable down to the first axis, but the
+ ;; size mismatch limits unrolling to the last axis only.
+
+ (pass-if "matching behavior III"
+ (let ((a #3(((1 2) (3 4)) ((5 6) (7 8))))
+ (b (make-array 0 2 3 2)))
+ (array-copy! a b)
+ (array-equal? b #3(((1 2) (3 4) (0 0)) ((5 6) (7 8) (0 0))))))
+
+ (pass-if "rank 0"
+ (let ((a #0(99))
+ (b (make-array 0)))
+ (array-copy! a b)
+ (equal? b #0(99))))
+
+ (pass-if "rank 1"
+ (let* ((a #2((1 2) (3 4)))
+ (b (make-shared-array a (lambda (j) (list 1 j)) 2))
+ (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
+ (d (make-array 0 2))
+ (e (make-array 0 2)))
+ (array-copy! b d)
+ (array-copy! c e)
+ (and (equal? d #(3 4))
+ (equal? e #(4 2)))))
+
+ (pass-if "rank 2"
+ (let ((a #2((1 2) (3 4)))
+ (b (make-array 0 2 2))
+ (c (make-array 0 2 2))
+ (d (make-array 0 2 2))
+ (e (make-array 0 2 2)))
+ (array-copy! a b)
+ (array-copy! a (transpose-array c 1 0))
+ (array-copy! (transpose-array a 1 0) d)
+ (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
+ (and (equal? a #2((1 2) (3 4)))
+ (equal? b #2((1 2) (3 4)))
+ (equal? c #2((1 3) (2 4)))
+ (equal? d #2((1 3) (2 4)))
+ (equal? e #2((1 2) (3 4))))))
+
+ (pass-if "rank 2, discontinuous"
+ (let ((A #2((0 1) (2 3) (4 5)))
+ (B #2((10 11) (12 13) (14 15)))
+ (C #2((20) (21) (22)))
+ (X (make-array 0 3 5))
+ (piece (lambda (X w s)
+ (make-shared-array
+ X (lambda (i j) (list i (+ j s))) 3 w))))
+ (array-copy! A (piece X 2 0))
+ (array-copy! B (piece X 2 2))
+ (array-copy! C (piece X 1 4))
+ (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
+
+ (pass-if "null increments, not empty"
+ (let ((a (make-array 0 2 2)))
+ (array-copy! (make-shared-array #0(1) (lambda x '()) 2 2) a)
+ (array-equal? #2((1 1) (1 1))))))
+
+;;;
+;;; array-map!
+;;;
+
+(with-test-prefix "array-map!"
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (array-map!))
+
+ (pass-if-exception "one arg" exception:wrong-num-args
+ (array-map! (make-array #f 5)))
+
+ (with-test-prefix "no sources"
+
+ (pass-if "closure 0"
+ (array-map! (make-array #f 5) (lambda () #f))
+ #t)
+
+ (pass-if-exception "closure 1" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x) #f)))
+
+ (pass-if-exception "closure 2" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x y) #f)))
+
+ (pass-if-exception "subr_1" exception:wrong-num-args
+ (array-map! (make-array #f 5) length))
+
+ (pass-if-exception "subr_2" exception:wrong-num-args
+ (array-map! (make-array #f 5) logtest))
+
+ (pass-if-exception "subr_2o" exception:wrong-num-args
+ (array-map! (make-array #f 5) number->string))
+
+ (pass-if-exception "dsubr" exception:wrong-num-args
+ (array-map! (make-array #f 5) sqrt))
+
+ (pass-if "rpsubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a =)
+ (equal? a (make-array #t 5))))
+
+ (pass-if "asubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a +)
+ (equal? a (make-array 0 5))))
+
+ ;; in Guile 1.6.4 and earlier this resulted in a segv
+ (pass-if "noop"
+ (array-map! (make-array #f 5) noop)
+ #t))
+
+ (with-test-prefix "one source"
+
+ (pass-if-exception "closure 0" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda () #f)
+ (make-array #f 5)))
+
+ (pass-if "closure 1"
+ (let ((a (make-array #f 5)))
+ (array-map! a (lambda (x) 'foo) (make-array #f 5))
+ (equal? a (make-array 'foo 5))))
+
+ (pass-if-exception "closure 2" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x y) #f)
+ (make-array #f 5)))
+
+ (pass-if "subr_1"
+ (let ((a (make-array #f 5)))
+ (array-map! a length (make-array '(x y z) 5))
+ (equal? a (make-array 3 5))))
+
+ (pass-if-exception "subr_2" exception:wrong-num-args
+ (array-map! (make-array #f 5) logtest
+ (make-array 999 5)))
+
+ (pass-if "subr_2o"
+ (let ((a (make-array #f 5)))
+ (array-map! a number->string (make-array 99 5))
+ (equal? a (make-array "99" 5))))
+
+ (pass-if "dsubr"
+ (let ((a (make-array #f 5)))
+ (array-map! a sqrt (make-array 16.0 5))
+ (equal? a (make-array 4.0 5))))
+
+ (pass-if "rpsubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a = (make-array 0 5))
+ (equal? a (make-array #t 5))))
+
+ (pass-if "asubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a - (make-array 99 5))
+ (equal? a (make-array -99 5))))
+
+ ;; in Guile 1.6.5 and 1.6.6 this was an error
+ (pass-if "1+"
+ (let ((a (make-array #f 5)))
+ (array-map! a 1+ (make-array 123 5))
+ (equal? a (make-array 124 5))))
+
+ (pass-if "rank 0"
+ (let ((a #0(99))
+ (b (make-array 0)))
+ (array-map! b values a)
+ (equal? b #0(99))))
+
+ (pass-if "rank 2, discontinuous"
+ (let ((A #2((0 1) (2 3) (4 5)))
+ (B #2((10 11) (12 13) (14 15)))
+ (C #2((20) (21) (22)))
+ (X (make-array 0 3 5))
+ (piece (lambda (X w s)
+ (make-shared-array
+ X (lambda (i j) (list i (+ j s))) 3 w))))
+ (array-map! (piece X 2 0) values A)
+ (array-map! (piece X 2 2) values B)
+ (array-map! (piece X 1 4) values C)
+ (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
+
+ (pass-if "null increments, not empty"
+ (let ((a (make-array 0 2 2)))
+ (array-map! a values (make-shared-array #0(1) (lambda x '()) 2 2))
+ (array-equal? a #2((1 1) (1 1))))))
+
+ (with-test-prefix "two sources"
+
+ (pass-if-exception "closure 0" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda () #f)
+ (make-array #f 5) (make-array #f 5)))
+
+ (pass-if-exception "closure 1" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x) #f)
+ (make-array #f 5) (make-array #f 5)))
+
+ (pass-if "closure 2"
+ (let ((a (make-array #f 5)))
+ (array-map! a (lambda (x y) 'foo)
+ (make-array #f 5) (make-array #f 5))
+ (equal? a (make-array 'foo 5))))
+
+ (pass-if-exception "subr_1" exception:wrong-num-args
+ (array-map! (make-array #f 5) length
+ (make-array #f 5) (make-array #f 5)))
+
+ (pass-if "subr_2"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a logtest
+ (make-array 999 5) (make-array 999 5))
+ (equal? a (make-array #t 5))))
+
+ (pass-if "subr_2o"
+ (let ((a (make-array #f 5)))
+ (array-map! a number->string
+ (make-array 32 5) (make-array 16 5))
+ (equal? a (make-array "20" 5))))
+
+ (pass-if-exception "dsubr" exception:wrong-num-args
+ (let ((a (make-array #f 5)))
+ (array-map! a sqrt
+ (make-array 16.0 5) (make-array 16.0 5))
+ (equal? a (make-array 4.0 5))))
+
+ (pass-if "rpsubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a = (make-array 99 5) (make-array 77 5))
+ (equal? a (make-array #f 5))))
+
+ (pass-if "asubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a - (make-array 99 5) (make-array 11 5))
+ (equal? a (make-array 88 5))))
+
+ (pass-if "+"
+ (let ((a (make-array #f 4)))
+ (array-map! a + #(1 2 3 4) #(5 6 7 8))
+ (equal? a #(6 8 10 12))))
+
+ (pass-if "noncompact arrays 1"
+ (let ((a #2((0 1) (2 3)))
+ (c (make-array 0 2)))
+ (begin
+ (array-map! c + (array-row a 1) (array-row a 1))
+ (array-equal? c #(4 6)))))
+
+ (pass-if "noncompact arrays 2"
+ (let ((a #2((0 1) (2 3)))
+ (c (make-array 0 2)))
+ (begin
+ (array-map! c + (array-col a 1) (array-col a 1))
+ (array-equal? c #(2 6)))))
+
+ (pass-if "noncompact arrays 3"
+ (let ((a #2((0 1) (2 3)))
+ (c (make-array 0 2)))
+ (begin
+ (array-map! c + (array-col a 1) (array-row a 1))
+ (array-equal? c #(3 6)))))
+
+ (pass-if "noncompact arrays 4"
+ (let ((a #2((0 1) (2 3)))
+ (c (make-array 0 2)))
+ (begin
+ (array-map! c + (array-col a 1) (array-row a 1))
+ (array-equal? c #(3 6)))))
+
+ (pass-if "offset arrays 1"
+ (let ((a #2@1@-3((0 1) (2 3)))
+ (c (make-array 0 '(1 2) '(-3 -2))))
+ (begin
+ (array-map! c + a a)
+ (array-equal? c #2@1@-3((0 2) (4 6)))))))
+
+ ;; note that array-copy! has the opposite behavior.
+
+ (pass-if-exception "matching behavior I" exception:shape-mismatch
+ (let ((a #(1 2))
+ (b (make-array 0 3)))
+ (array-map! b values a)
+ (equal? b #(1 2 0))))
+
+ (pass-if "matching behavior II"
+ (let ((a #(1 2 3))
+ (b (make-array 0 2)))
+ (array-map! b values a)
+ (equal? b #(1 2))))
+
+ ;; here both a & b are are unrollable down to the first axis, but the
+ ;; size mismatch limits unrolling to the last axis only.
+
+ (pass-if "matching behavior III"
+ (let ((a #3(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12))))
+ (b (make-array 0 2 2 2)))
+ (array-map! b values a)
+ (array-equal? b #3(((1 2) (3 4)) ((7 8) (9 10)))))))
+
+;;;
+;;; array-for-each
+;;;
+
+(with-test-prefix "array-for-each"
+
+ (with-test-prefix "1 source"
+ (pass-if-equal "rank 0"
+ '(99)
+ (let* ((a #0(99))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
+ (pass-if-equal "noncompact array"
+ '(3 2 1 0)
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
+ (pass-if-equal "vector"
+ '(3 2 1 0)
+ (let* ((a #(0 1 2 3))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
+ (pass-if-equal "shared array"
+ '(3 2 1 0)
+ (let* ((a #2((0 1) (2 3)))
+ (a' (make-shared-array a
+ (lambda (x)
+ (list (quotient x 4)
+ (modulo x 4)))
+ 4))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a')
+ l)))
+
+ (with-test-prefix "3 sources"
+ (pass-if-equal "noncompact arrays 1"
+ '((3 1 3) (2 0 2))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1))
+ l))
+
+ (pass-if-equal "noncompact arrays 2"
+ '((3 3 3) (2 2 1))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
+ l))
+
+ (pass-if-equal "noncompact arrays 3"
+ '((3 3 3) (2 1 1))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
+ l))
+
+ (pass-if-equal "noncompact arrays 4"
+ '((3 2 3) (1 0 2))
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (rec (lambda args (set! l (cons args l)))))
+ (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
+ l)))
+
+ (with-test-prefix "empty arrays"
+
+ (pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
+ (let* ((a (list))
+ (b (make-array 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-for-each (lambda (c) (set! a (cons c a))) c)
+ (equal? a '())))
+
+ (pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
+ (let* ((a (list))
+ (b (make-typed-array 'f64 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-for-each (lambda (c) (set! a (cons c a))) c)
+ (equal? a '())))
+
+ ;; FIXME add type 'b cases.
+
+ (pass-if-exception "empty arrays shape check" exception:shape-mismatch
+ (let* ((a (list))
+ (b (make-typed-array 'f64 0 0 2))
+ (c (make-typed-array 'f64 0 2 0)))
+ (array-for-each (lambda (b c) (set! a (cons* b c a))) b c)))))
+
+;;;
+;;; array-for-each-cell
+;;;
+
+(with-test-prefix "array-for-each-cell"
+
+ (pass-if-equal "1 argument frame rank 1"
+ #2((1 3 9) (2 7 8))
+ (let* ((a (list->array 2 '((9 1 3) (7 8 2)))))
+ (array-for-each-cell 1 (lambda (a) (sort! a <)) a)
+ a))
+
+ (pass-if-equal "2 arguments frame rank 1"
+ #f64(8 -1)
+ (let* ((x (list->typed-array 'f64 2 '((9 1) (7 8))))
+ (y (f64vector 99 99)))
+ (array-for-each-cell 1 (lambda (y x) (array-set! y (- (array-ref x 0) (array-ref x 1)))) y x)
+ y))
+
+ (pass-if-equal "regression: zero-sized frame loop without unrolling"
+ 99
+ (let* ((x 99)
+ (o (make-array 0. 0 3 2)))
+ (array-for-each-cell 2
+ (lambda (o a0 a1)
+ (set! x 0))
+ o
+ (make-shared-array (make-array 1. 0 1) (const '(0 0)) 0 3)
+ (make-array 2. 0 3))
+ x)))
diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
deleted file mode 100644
index bd8a434..0000000
--- a/test-suite/tests/ramap.test
+++ /dev/null
@@ -1,509 +0,0 @@
-;;;; ramap.test --- test array mapping functions -*- scheme -*-
-;;;;
-;;;; Copyright (C) 2004, 2005, 2006, 2009, 2013 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-(define-module (test-suite test-ramap)
- #:use-module (test-suite lib))
-
-(define exception:shape-mismatch
- (cons 'misc-error ".*shape mismatch.*"))
-
-(define (array-row a i)
- (make-shared-array a (lambda (j) (list i j))
- (cadr (array-dimensions a))))
-
-(define (array-col a j)
- (make-shared-array a (lambda (i) (list i j))
- (car (array-dimensions a))))
-
-;;;
-;;; array-index-map!
-;;;
-
-(with-test-prefix "array-index-map!"
-
- (pass-if "basic test"
- (let ((nlst '()))
- (array-index-map! (make-array #f '(1 1))
- (lambda (n)
- (set! nlst (cons n nlst))))
- (equal? nlst '(1))))
-
- (with-test-prefix "empty arrays"
-
- (pass-if "all axes empty"
- (array-index-map! (make-typed-array 'f64 0 0 0) (const 0))
- (array-index-map! (make-typed-array 'b #t 0 0) (const #t))
- (array-index-map! (make-typed-array #t 0 0 0) (const 0))
- #t)
-
- (pass-if "last axis empty"
- (array-index-map! (make-typed-array 'f64 0 2 0) (const 0))
- (array-index-map! (make-typed-array 'b #t 2 0) (const #t))
- (array-index-map! (make-typed-array #t 0 2 0) (const 0))
- #t)
-
- ; the 'f64 cases fail in 2.0.9 with out-of-range.
- (pass-if "axis empty, other than last"
- (array-index-map! (make-typed-array 'f64 0 0 2) (const 0))
- (array-index-map! (make-typed-array 'b #t 0 2) (const #t))
- (array-index-map! (make-typed-array #t 0 0 2) (const 0))
- #t))
-
- (pass-if "rank 2"
- (let ((a (make-array 0 2 2))
- (b (make-array 0 2 2)))
- (array-index-map! a (lambda (i j) i))
- (array-index-map! b (lambda (i j) j))
- (and (array-equal? a #2((0 0) (1 1)))
- (array-equal? b #2((0 1) (0 1)))))))
-
-;;;
-;;; array-copy!
-;;;
-
-(with-test-prefix "array-copy!"
-
- (with-test-prefix "empty arrays"
-
- (pass-if "empty other than last, #t"
- (let* ((b (make-array 0 2 2))
- (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
- (array-copy! #2:0:2() c)
- (array-equal? #2:0:2() c)))
-
- (pass-if "empty other than last, 'f64"
- (let* ((b (make-typed-array 'f64 0 2 2))
- (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
- (array-copy! #2:0:2() c)
- (array-equal? #2f64:0:2() c)))
-
- ;; FIXME add empty, type 'b cases.
-
- )
-
- ;; note that it is the opposite of array-map!. This is, unfortunately,
- ;; documented in the manual.
-
- (pass-if "matching behavior I"
- (let ((a #(1 2))
- (b (make-array 0 3)))
- (array-copy! a b)
- (equal? b #(1 2 0))))
-
- (pass-if-exception "matching behavior II" exception:shape-mismatch
- (let ((a #(1 2 3))
- (b (make-array 0 2)))
- (array-copy! a b)
- (equal? b #(1 2))))
-
- ;; here both a & b are are unrollable down to the first axis, but the
- ;; size mismatch limits unrolling to the last axis only.
-
- (pass-if "matching behavior III"
- (let ((a #3(((1 2) (3 4)) ((5 6) (7 8))))
- (b (make-array 0 2 3 2)))
- (array-copy! a b)
- (array-equal? b #3(((1 2) (3 4) (0 0)) ((5 6) (7 8) (0 0))))))
-
- (pass-if "rank 0"
- (let ((a #0(99))
- (b (make-array 0)))
- (array-copy! a b)
- (equal? b #0(99))))
-
- (pass-if "rank 1"
- (let* ((a #2((1 2) (3 4)))
- (b (make-shared-array a (lambda (j) (list 1 j)) 2))
- (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
- (d (make-array 0 2))
- (e (make-array 0 2)))
- (array-copy! b d)
- (array-copy! c e)
- (and (equal? d #(3 4))
- (equal? e #(4 2)))))
-
- (pass-if "rank 2"
- (let ((a #2((1 2) (3 4)))
- (b (make-array 0 2 2))
- (c (make-array 0 2 2))
- (d (make-array 0 2 2))
- (e (make-array 0 2 2)))
- (array-copy! a b)
- (array-copy! a (transpose-array c 1 0))
- (array-copy! (transpose-array a 1 0) d)
- (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
- (and (equal? a #2((1 2) (3 4)))
- (equal? b #2((1 2) (3 4)))
- (equal? c #2((1 3) (2 4)))
- (equal? d #2((1 3) (2 4)))
- (equal? e #2((1 2) (3 4))))))
-
- (pass-if "rank 2, discontinuous"
- (let ((A #2((0 1) (2 3) (4 5)))
- (B #2((10 11) (12 13) (14 15)))
- (C #2((20) (21) (22)))
- (X (make-array 0 3 5))
- (piece (lambda (X w s)
- (make-shared-array
- X (lambda (i j) (list i (+ j s))) 3 w))))
- (array-copy! A (piece X 2 0))
- (array-copy! B (piece X 2 2))
- (array-copy! C (piece X 1 4))
- (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
-
- (pass-if "null increments, not empty"
- (let ((a (make-array 0 2 2)))
- (array-copy! (make-shared-array #0(1) (lambda x '()) 2 2) a)
- (array-equal? #2((1 1) (1 1))))))
-
-;;;
-;;; array-map!
-;;;
-
-(with-test-prefix "array-map!"
-
- (pass-if-exception "no args" exception:wrong-num-args
- (array-map!))
-
- (pass-if-exception "one arg" exception:wrong-num-args
- (array-map! (make-array #f 5)))
-
- (with-test-prefix "no sources"
-
- (pass-if "closure 0"
- (array-map! (make-array #f 5) (lambda () #f))
- #t)
-
- (pass-if-exception "closure 1" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda (x) #f)))
-
- (pass-if-exception "closure 2" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda (x y) #f)))
-
- (pass-if-exception "subr_1" exception:wrong-num-args
- (array-map! (make-array #f 5) length))
-
- (pass-if-exception "subr_2" exception:wrong-num-args
- (array-map! (make-array #f 5) logtest))
-
- (pass-if-exception "subr_2o" exception:wrong-num-args
- (array-map! (make-array #f 5) number->string))
-
- (pass-if-exception "dsubr" exception:wrong-num-args
- (array-map! (make-array #f 5) sqrt))
-
- (pass-if "rpsubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a =)
- (equal? a (make-array #t 5))))
-
- (pass-if "asubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a +)
- (equal? a (make-array 0 5))))
-
- ;; in Guile 1.6.4 and earlier this resulted in a segv
- (pass-if "noop"
- (array-map! (make-array #f 5) noop)
- #t))
-
- (with-test-prefix "one source"
-
- (pass-if-exception "closure 0" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda () #f)
- (make-array #f 5)))
-
- (pass-if "closure 1"
- (let ((a (make-array #f 5)))
- (array-map! a (lambda (x) 'foo) (make-array #f 5))
- (equal? a (make-array 'foo 5))))
-
- (pass-if-exception "closure 2" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda (x y) #f)
- (make-array #f 5)))
-
- (pass-if "subr_1"
- (let ((a (make-array #f 5)))
- (array-map! a length (make-array '(x y z) 5))
- (equal? a (make-array 3 5))))
-
- (pass-if-exception "subr_2" exception:wrong-num-args
- (array-map! (make-array #f 5) logtest
- (make-array 999 5)))
-
- (pass-if "subr_2o"
- (let ((a (make-array #f 5)))
- (array-map! a number->string (make-array 99 5))
- (equal? a (make-array "99" 5))))
-
- (pass-if "dsubr"
- (let ((a (make-array #f 5)))
- (array-map! a sqrt (make-array 16.0 5))
- (equal? a (make-array 4.0 5))))
-
- (pass-if "rpsubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a = (make-array 0 5))
- (equal? a (make-array #t 5))))
-
- (pass-if "asubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a - (make-array 99 5))
- (equal? a (make-array -99 5))))
-
- ;; in Guile 1.6.5 and 1.6.6 this was an error
- (pass-if "1+"
- (let ((a (make-array #f 5)))
- (array-map! a 1+ (make-array 123 5))
- (equal? a (make-array 124 5))))
-
- (pass-if "rank 0"
- (let ((a #0(99))
- (b (make-array 0)))
- (array-map! b values a)
- (equal? b #0(99))))
-
- (pass-if "rank 2, discontinuous"
- (let ((A #2((0 1) (2 3) (4 5)))
- (B #2((10 11) (12 13) (14 15)))
- (C #2((20) (21) (22)))
- (X (make-array 0 3 5))
- (piece (lambda (X w s)
- (make-shared-array
- X (lambda (i j) (list i (+ j s))) 3 w))))
- (array-map! (piece X 2 0) values A)
- (array-map! (piece X 2 2) values B)
- (array-map! (piece X 1 4) values C)
- (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
-
- (pass-if "null increments, not empty"
- (let ((a (make-array 0 2 2)))
- (array-map! a values (make-shared-array #0(1) (lambda x '()) 2 2))
- (array-equal? a #2((1 1) (1 1))))))
-
- (with-test-prefix "two sources"
-
- (pass-if-exception "closure 0" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda () #f)
- (make-array #f 5) (make-array #f 5)))
-
- (pass-if-exception "closure 1" exception:wrong-num-args
- (array-map! (make-array #f 5) (lambda (x) #f)
- (make-array #f 5) (make-array #f 5)))
-
- (pass-if "closure 2"
- (let ((a (make-array #f 5)))
- (array-map! a (lambda (x y) 'foo)
- (make-array #f 5) (make-array #f 5))
- (equal? a (make-array 'foo 5))))
-
- (pass-if-exception "subr_1" exception:wrong-num-args
- (array-map! (make-array #f 5) length
- (make-array #f 5) (make-array #f 5)))
-
- (pass-if "subr_2"
- (let ((a (make-array 'foo 5)))
- (array-map! a logtest
- (make-array 999 5) (make-array 999 5))
- (equal? a (make-array #t 5))))
-
- (pass-if "subr_2o"
- (let ((a (make-array #f 5)))
- (array-map! a number->string
- (make-array 32 5) (make-array 16 5))
- (equal? a (make-array "20" 5))))
-
- (pass-if-exception "dsubr" exception:wrong-num-args
- (let ((a (make-array #f 5)))
- (array-map! a sqrt
- (make-array 16.0 5) (make-array 16.0 5))
- (equal? a (make-array 4.0 5))))
-
- (pass-if "rpsubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a = (make-array 99 5) (make-array 77 5))
- (equal? a (make-array #f 5))))
-
- (pass-if "asubr"
- (let ((a (make-array 'foo 5)))
- (array-map! a - (make-array 99 5) (make-array 11 5))
- (equal? a (make-array 88 5))))
-
- (pass-if "+"
- (let ((a (make-array #f 4)))
- (array-map! a + #(1 2 3 4) #(5 6 7 8))
- (equal? a #(6 8 10 12))))
-
- (pass-if "noncompact arrays 1"
- (let ((a #2((0 1) (2 3)))
- (c (make-array 0 2)))
- (begin
- (array-map! c + (array-row a 1) (array-row a 1))
- (array-equal? c #(4 6)))))
-
- (pass-if "noncompact arrays 2"
- (let ((a #2((0 1) (2 3)))
- (c (make-array 0 2)))
- (begin
- (array-map! c + (array-col a 1) (array-col a 1))
- (array-equal? c #(2 6)))))
-
- (pass-if "noncompact arrays 3"
- (let ((a #2((0 1) (2 3)))
- (c (make-array 0 2)))
- (begin
- (array-map! c + (array-col a 1) (array-row a 1))
- (array-equal? c #(3 6)))))
-
- (pass-if "noncompact arrays 4"
- (let ((a #2((0 1) (2 3)))
- (c (make-array 0 2)))
- (begin
- (array-map! c + (array-col a 1) (array-row a 1))
- (array-equal? c #(3 6)))))
-
- (pass-if "offset arrays 1"
- (let ((a #2@1@-3((0 1) (2 3)))
- (c (make-array 0 '(1 2) '(-3 -2))))
- (begin
- (array-map! c + a a)
- (array-equal? c #2@1@-3((0 2) (4 6)))))))
-
- ;; note that array-copy! has the opposite behavior.
-
- (pass-if-exception "matching behavior I" exception:shape-mismatch
- (let ((a #(1 2))
- (b (make-array 0 3)))
- (array-map! b values a)
- (equal? b #(1 2 0))))
-
- (pass-if "matching behavior II"
- (let ((a #(1 2 3))
- (b (make-array 0 2)))
- (array-map! b values a)
- (equal? b #(1 2))))
-
- ;; here both a & b are are unrollable down to the first axis, but the
- ;; size mismatch limits unrolling to the last axis only.
-
- (pass-if "matching behavior III"
- (let ((a #3(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12))))
- (b (make-array 0 2 2 2)))
- (array-map! b values a)
- (array-equal? b #3(((1 2) (3 4)) ((7 8) (9 10)))))))
-
-;;;
-;;; array-for-each
-;;;
-
-(with-test-prefix "array-for-each"
-
- (with-test-prefix "1 source"
- (pass-if-equal "rank 0"
- '(99)
- (let* ((a #0(99))
- (l '())
- (p (lambda (x) (set! l (cons x l)))))
- (array-for-each p a)
- l))
-
- (pass-if-equal "noncompact array"
- '(3 2 1 0)
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (p (lambda (x) (set! l (cons x l)))))
- (array-for-each p a)
- l))
-
- (pass-if-equal "vector"
- '(3 2 1 0)
- (let* ((a #(0 1 2 3))
- (l '())
- (p (lambda (x) (set! l (cons x l)))))
- (array-for-each p a)
- l))
-
- (pass-if-equal "shared array"
- '(3 2 1 0)
- (let* ((a #2((0 1) (2 3)))
- (a' (make-shared-array a
- (lambda (x)
- (list (quotient x 4)
- (modulo x 4)))
- 4))
- (l '())
- (p (lambda (x) (set! l (cons x l)))))
- (array-for-each p a')
- l)))
-
- (with-test-prefix "3 sources"
- (pass-if-equal "noncompact arrays 1"
- '((3 1 3) (2 0 2))
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1))
- l))
-
- (pass-if-equal "noncompact arrays 2"
- '((3 3 3) (2 2 1))
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
- l))
-
- (pass-if-equal "noncompact arrays 3"
- '((3 3 3) (2 1 1))
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
- l))
-
- (pass-if-equal "noncompact arrays 4"
- '((3 2 3) (1 0 2))
- (let* ((a #2((0 1) (2 3)))
- (l '())
- (rec (lambda args (set! l (cons args l)))))
- (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
- l)))
-
- (with-test-prefix "empty arrays"
-
- (pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
- (let* ((a (list))
- (b (make-array 0 2 2))
- (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
- (array-for-each (lambda (c) (set! a (cons c a))) c)
- (equal? a '())))
-
- (pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
- (let* ((a (list))
- (b (make-typed-array 'f64 0 2 2))
- (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
- (array-for-each (lambda (c) (set! a (cons c a))) c)
- (equal? a '())))
-
- ;; FIXME add type 'b cases.
-
- (pass-if-exception "empty arrays shape check" exception:shape-mismatch
- (let* ((a (list))
- (b (make-typed-array 'f64 0 0 2))
- (c (make-typed-array 'f64 0 2 0)))
- (array-for-each (lambda (b c) (set! a (cons* b c a))) b c)))))
--
2.7.3
next prev parent reply other threads:[~2016-07-12 17:16 UTC|newest]
Thread overview: 16+ messages / expand[flat|nested] mbox.gz Atom feed top
2016-07-12 7:48 Patchset related to array functions Daniel Llorens
2016-07-12 14:11 ` Andy Wingo
2016-07-12 17:16 ` Daniel Llorens [this message]
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=A1BFED22-3DF9-46F7-A3E0-08BC44E7C4D3@bluewin.ch \
--to=daniel.llorens@bluewin.ch \
--cc=guile-devel@gnu.org \
--cc=wingo@pobox.com \
/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).