* Better support for non-zero lower bound arrays [v2]
@ 2017-02-21 11:59 daniel.llorens
2017-02-21 11:59 ` [PATCH 1/6] Replace uniform-vector-read benchmark with bytevector-io benchmark daniel.llorens
` (5 more replies)
0 siblings, 6 replies; 7+ messages in thread
From: daniel.llorens @ 2017-02-21 11:59 UTC (permalink / raw)
To: guile-devel
This patchset improves the support for non-zero lower bound
arrays. Specifically, the functions sort, sort!,
restricted-vector-sort!, array-slice-for-each, and truncated-print from
(ice-9 pretty print) now support non-zero lower bound arrays.
The patchset also adds support for bitvectors in truncated-print and
completes the removal of uniform-vector-read!/write, which were still
present in the manual.
The last patch removes scm_generalized_vector_handle(), which has been
deprecated since 2.0.9.
Compared with the earlier patchset, this only includes array-copy and
not typed-array-copy in (ice-9 arrays). It is perhaps not clear that
that interface is the best. I've also removed the Scheme function
array-print, which wasn't being used.
Regards
Daniel
^ permalink raw reply [flat|nested] 7+ messages in thread
* [PATCH 1/6] Replace uniform-vector-read benchmark with bytevector-io benchmark
2017-02-21 11:59 Better support for non-zero lower bound arrays [v2] daniel.llorens
@ 2017-02-21 11:59 ` daniel.llorens
2017-02-21 11:59 ` [PATCH 2/6] Remove documentation on uniform-vector-read!, uniform-vector-write daniel.llorens
` (4 subsequent siblings)
5 siblings, 0 replies; 7+ messages in thread
From: daniel.llorens @ 2017-02-21 11:59 UTC (permalink / raw)
To: guile-devel
From: Daniel Llorens <daniel.llorens@bluewin.ch>
* benchmark-suite/benchmarks/uniform-vector-read.bm:
Remove; uniform-vector-read! and uniform-vector-write were deprecated
in 2.0 and are have been removed in 2.1.
* benchmark-suite/benchmarks/bytevector-io.bm: New benchmark.
* benchmark-suite/Makefile.am: Run the new benchmark.
---
benchmark-suite/Makefile.am | 2 +-
.../{uniform-vector-read.bm => bytevector-io.bm} | 29 +++++++++++-----------
2 files changed, 15 insertions(+), 16 deletions(-)
rename benchmark-suite/benchmarks/{uniform-vector-read.bm => bytevector-io.bm} (64%)
diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am
index 1222121..47bd036 100644
--- a/benchmark-suite/Makefile.am
+++ b/benchmark-suite/Makefile.am
@@ -1,5 +1,6 @@
SCM_BENCHMARKS = benchmarks/0-reference.bm \
benchmarks/arithmetic.bm \
+ benchmarks/bytevector-io.bm \
benchmarks/bytevectors.bm \
benchmarks/chars.bm \
benchmarks/continuations.bm \
@@ -13,7 +14,6 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm \
benchmarks/srfi-13.bm \
benchmarks/structs.bm \
benchmarks/subr.bm \
- benchmarks/uniform-vector-read.bm \
benchmarks/vectors.bm \
benchmarks/vlists.bm \
benchmarks/write.bm \
diff --git a/benchmark-suite/benchmarks/uniform-vector-read.bm b/benchmark-suite/benchmarks/bytevector-io.bm
similarity index 64%
rename from benchmark-suite/benchmarks/uniform-vector-read.bm
rename to benchmark-suite/benchmarks/bytevector-io.bm
index 01b7478..7ae7c0e 100644
--- a/benchmark-suite/benchmarks/uniform-vector-read.bm
+++ b/benchmark-suite/benchmarks/bytevector-io.bm
@@ -1,6 +1,6 @@
-;;; uniform-vector-read.bm --- Exercise binary I/O primitives. -*- Scheme -*-
+;;; bytevector-io.bm --- Exercise bytevector I/O primitives. -*- Scheme -*-
;;;
-;;; Copyright (C) 2008 Free Software Foundation, Inc.
+;;; Copyright (C) 2008, 2017 Free Software Foundation, Inc.
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
@@ -17,9 +17,10 @@
;;; not, write to the Free Software Foundation, Inc., 51 Franklin
;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
-(define-module (benchmarks uniform-vector-read)
+(define-module (benchmarks bytevector-io)
:use-module (benchmark-suite lib)
- :use-module (srfi srfi-4))
+ :use-module (rnrs io ports)
+ :use-module (rnrs bytevectors))
(define file-name
(tmpnam))
@@ -30,24 +31,22 @@
(define buf
(make-u8vector %buffer-size))
-(define str
- (make-string %buffer-size))
-
\f
-(with-benchmark-prefix "uniform-vector-read!"
+(with-benchmark-prefix "bytevector i/o"
- (benchmark "uniform-vector-write" 4000
+ (benchmark "put-bytevector" 4000
(let ((output (open-output-file file-name)))
- (uniform-vector-write buf output)
+ (put-bytevector output buf)
(close output)))
- (benchmark "uniform-vector-read!" 20000
+ (benchmark "get-bytevector-n!" 20000
(let ((input (open-input-file file-name)))
(setvbuf input 'none)
- (uniform-vector-read! buf input)
+ (get-bytevector-n! input buf 0 (bytevector-length buf))
(close input)))
- (benchmark "string port" 5000
- (let ((input (open-input-string str)))
- (uniform-vector-read! buf input)
+ (benchmark "get-bytevector-n" 20000
+ (let ((input (open-input-file file-name)))
+ (setvbuf input 'none)
+ (get-bytevector-n input (bytevector-length buf))
(close input))))
--
2.10.1
^ permalink raw reply related [flat|nested] 7+ messages in thread
* [PATCH 2/6] Remove documentation on uniform-vector-read!, uniform-vector-write
2017-02-21 11:59 Better support for non-zero lower bound arrays [v2] daniel.llorens
2017-02-21 11:59 ` [PATCH 1/6] Replace uniform-vector-read benchmark with bytevector-io benchmark daniel.llorens
@ 2017-02-21 11:59 ` daniel.llorens
2017-02-21 11:59 ` [PATCH 3/6] Fix sort, sort! for arrays with nonzero lower bound daniel.llorens
` (3 subsequent siblings)
5 siblings, 0 replies; 7+ messages in thread
From: daniel.llorens @ 2017-02-21 11:59 UTC (permalink / raw)
To: guile-devel
From: Daniel Llorens <daniel.llorens@bluewin.ch>
* NEWS: Add specific removal notice.
* doc/ref/api-data.texi: Remove documentation on uniform-vector-read!,
uniform-vector-write.
---
NEWS | 7 +++++++
doc/ref/api-data.texi | 33 ---------------------------------
2 files changed, 7 insertions(+), 33 deletions(-)
diff --git a/NEWS b/NEWS
index 4dc7173..1a0a285 100644
--- a/NEWS
+++ b/NEWS
@@ -739,6 +739,13 @@ All code deprecated in Guile 2.0 has been removed. See older NEWS, and
check that your programs can compile without linker warnings and run
without runtime warnings. See "Deprecation" in the manual.
+In particular, the following functions, which were deprecated in 2.0.10
+but not specifically mentioned earlier in this file, have been removed:
+
+*** `uniform-vector-read!' and `uniform-vector-write' have been
+ removed. Use `get-bytevector-n!' and `put-bytevector' from (rnrs io
+ ports) instead.
+
** Remove miscellaneous unused interfaces
We have removed accidentally public, undocumented interfaces that we
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 1b3170e..f5c8798 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -7565,39 +7565,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.10.1
^ permalink raw reply related [flat|nested] 7+ messages in thread
* [PATCH 3/6] Fix sort, sort! for arrays with nonzero lower bound
2017-02-21 11:59 Better support for non-zero lower bound arrays [v2] daniel.llorens
2017-02-21 11:59 ` [PATCH 1/6] Replace uniform-vector-read benchmark with bytevector-io benchmark daniel.llorens
2017-02-21 11:59 ` [PATCH 2/6] Remove documentation on uniform-vector-read!, uniform-vector-write daniel.llorens
@ 2017-02-21 11:59 ` daniel.llorens
2017-02-21 11:59 ` [PATCH 4/6] Support non-zero lower bounds in array-slice-for-each daniel.llorens
` (2 subsequent siblings)
5 siblings, 0 replies; 7+ messages in thread
From: daniel.llorens @ 2017-02-21 11:59 UTC (permalink / raw)
To: guile-devel
From: Daniel Llorens <daniel.llorens@bluewin.ch>
* module/ice-9/arrays.scm (array-copy): New function, export.
* module/Makefile.am: Install (ice-9 arrays).
* doc/ref/api-data.texi: Add documentation for (ice-9 arrays).
* libguile/quicksort.i.c: Use signed bounds throughout.
* libguile/sort.c (scm_restricted_vector_sort_x): Fix error calls. Fix
calls to quicksort.
* test-suite/tests/sort.test: Actually test that the sorted results
match the original data. Test cases for non-zero base index arrays for
sort, sort!, and stable-sort!.
---
doc/ref/api-data.texi | 32 +++++++----
libguile/quicksort.i.c | 48 ++++++++--------
libguile/sort.c | 43 ++++++++++-----
module/Makefile.am | 1 +
module/ice-9/arrays.scm | 50 ++++++++++-------
test-suite/tests/sort.test | 133 ++++++++++++++++++++++++++++-----------------
6 files changed, 185 insertions(+), 122 deletions(-)
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index f5c8798..71aafbf 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -7495,10 +7495,6 @@ same type, and have corresponding elements which are either
@code{equal?} (@pxref{Equality}) in that all arguments must be arrays.
@end deffn
-@c FIXME: array-map! accepts no source arrays at all, and in that
-@c case makes calls "(proc)". Is that meant to be a documented
-@c feature?
-@c
@c FIXME: array-for-each doesn't say what happens if the sources have
@c different index ranges. The code currently iterates over the
@c indices of the first and expects the others to cover those. That
@@ -7506,14 +7502,15 @@ same type, and have corresponding elements which are either
@c documented feature?
@deffn {Scheme Procedure} array-map! dst proc src @dots{}
-@deffnx {Scheme Procedure} array-map-in-order! dst proc src1 @dots{} srcN
+@deffnx {Scheme Procedure} array-map-in-order! dst proc src @dots{}
@deffnx {C Function} scm_array_map_x (dst, proc, srclist)
-Set each element of the @var{dst} array to values obtained from calls
-to @var{proc}. The value returned is unspecified.
+Set each element of the @var{dst} array to values obtained from calls to
+@var{proc}. The list of @var{src} arguments may be empty. The value
+returned is unspecified.
-Each call is @code{(@var{proc} @var{elem1} @dots{} @var{elemN})},
-where each @var{elem} is from the corresponding @var{src} array, at
-the @var{dst} index. @code{array-map-in-order!} makes the calls in
+Each call is @code{(@var{proc} @var{elem} @dots{})}, where each
+@var{elem} is from the corresponding @var{src} array, at the
+@var{dst} index. @code{array-map-in-order!} makes the calls in
row-major order, @code{array-map!} makes them in an unspecified order.
The @var{src} arrays must have the same number of dimensions as
@@ -7565,6 +7562,21 @@ $\left(\matrix{%
@end example
@end deffn
+An additional array function is available in the module
+@code{(ice-9 arrays)}. It can be used with:
+
+@example
+(use-modules (ice-9 arrays))
+@end example
+
+@deffn {Scheme Procedure} array-copy src
+Return a new array with the same elements, type and shape as
+@var{src}. However, the array increments may not be the same as those of
+@var{src}. In the current implementation, the returned array will be in
+row-major order, but that might change in the future. Use
+@code{array-copy!} on an array of known order if that is a concern.
+@end deffn
+
@node Shared Arrays
@subsubsection Shared Arrays
diff --git a/libguile/quicksort.i.c b/libguile/quicksort.i.c
index cf1742e..5982672 100644
--- a/libguile/quicksort.i.c
+++ b/libguile/quicksort.i.c
@@ -27,7 +27,7 @@
reduces the probability of selecting a bad pivot value and eliminates
certain extraneous comparisons.
- 3. Only quicksorts NR_ELEMS / MAX_THRESH partitions, leaving insertion sort
+ 3. Only quicksorts (UBND-LBND+1) / MAX_THRESH partitions, leaving insertion sort
to order the MAX_THRESH items within each partition. This is a big win,
since insertion sort is faster for small, mostly sorted array segments.
@@ -54,33 +54,29 @@
#define STACK_NOT_EMPTY (stack < top)
static void
-NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
+NAME (VEC_PARAM ssize_t lbnd, ssize_t ubnd, INC_PARAM SCM less)
{
/* Stack node declarations used to store unfulfilled partition obligations. */
typedef struct {
- size_t lo;
- size_t hi;
+ ssize_t lo;
+ ssize_t hi;
} stack_node;
static const char s_buggy_less[] = "buggy less predicate used when sorting";
- if (nr_elems == 0)
- /* Avoid lossage with unsigned arithmetic below. */
- return;
-
- if (nr_elems > MAX_THRESH)
+ if (ubnd-lbnd+1 > MAX_THRESH)
{
- size_t lo = 0;
- size_t hi = nr_elems-1;
+ ssize_t lo = lbnd;
+ ssize_t hi = ubnd;
stack_node stack[STACK_SIZE];
stack_node *top = stack + 1;
while (STACK_NOT_EMPTY)
{
- size_t left;
- size_t right;
- size_t mid = lo + (hi - lo) / 2;
+ ssize_t left;
+ ssize_t right;
+ ssize_t mid = lo + (hi - lo) / 2;
SCM pivot;
/* Select median value from among LO, MID, and HI. Rearrange
@@ -145,16 +141,16 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
ignore one or both. Otherwise, push the larger partition's
bounds on the stack and continue sorting the smaller one. */
- if ((size_t) (right - lo) <= MAX_THRESH)
+ if ((right - lo) <= MAX_THRESH)
{
- if ((size_t) (hi - left) <= MAX_THRESH)
+ if ((hi - left) <= MAX_THRESH)
/* Ignore both small partitions. */
POP (lo, hi);
else
/* Ignore small left partition. */
lo = left;
}
- else if ((size_t) (hi - left) <= MAX_THRESH)
+ else if ((hi - left) <= MAX_THRESH)
/* Ignore small right partition. */
hi = right;
else if ((right - lo) > (hi - left))
@@ -179,10 +175,10 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
one beyond it!). */
{
- size_t tmp = 0;
- size_t end = nr_elems-1;
- size_t thresh = min (end, MAX_THRESH);
- size_t run;
+ ssize_t tmp = lbnd;
+ ssize_t end = ubnd;
+ ssize_t thresh = min (end, MAX_THRESH);
+ ssize_t run;
/* Find smallest element in first threshold and place it at the
array's beginning. This is the smallest array element,
@@ -192,12 +188,12 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
if (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
tmp = run;
- if (tmp != 0)
- SWAP (tmp, 0);
+ if (tmp != lbnd)
+ SWAP (tmp, lbnd);
/* Insertion sort, running from left-hand-side up to right-hand-side. */
- run = 1;
+ run = lbnd + 1;
while (++run <= end)
{
SCM_TICK;
@@ -206,7 +202,7 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
while (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
{
/* The comparison predicate may be buggy */
- if (tmp == 0)
+ if (tmp == lbnd)
scm_misc_error (NULL, s_buggy_less, SCM_EOL);
tmp -= 1;
@@ -216,7 +212,7 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
if (tmp != run)
{
SCM to_insert = GET(run);
- size_t hi, lo;
+ ssize_t hi, lo;
for (hi = lo = run; --lo >= tmp; hi = lo)
SET(hi, GET(lo));
diff --git a/libguile/sort.c b/libguile/sort.c
index 8c20d34..ad7b8b8 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -79,7 +79,7 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
#define FUNC_NAME s_scm_restricted_vector_sort_x
{
ssize_t spos = scm_to_ssize_t (startpos);
- size_t epos = scm_to_ssize_t (endpos);
+ ssize_t epos = scm_to_ssize_t (endpos)-1;
scm_t_array_handle handle;
scm_t_array_dim const * dims;
@@ -89,26 +89,26 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
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);
+ scm_misc_error (FUNC_NAME, "rank must be 1", scm_list_1 (vec));
}
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));
+ scm_error (scm_out_of_range_key, FUNC_NAME, "startpos ~s out of range of ~s",
+ scm_list_2 (startpos, vec), scm_list_1 (startpos));
}
- if (epos > dims[0].ubnd+1)
+ if (epos > dims[0].ubnd)
{
scm_array_handle_release (&handle);
- scm_error (scm_out_of_range_key, FUNC_NAME, "endpos out of range",
- vec, scm_list_1(endpos));
+ scm_error (scm_out_of_range_key, FUNC_NAME, "endpos ~s out of range of ~s",
+ scm_list_2 (endpos, vec), scm_list_1 (endpos));
}
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);
+ quicksort (scm_array_handle_writable_elements (&handle) - dims[0].lbnd * dims[0].inc,
+ spos, epos, dims[0].inc, less);
else
- quicksorta (&handle, epos-spos, less);
+ quicksorta (&handle, spos, epos, less);
scm_array_handle_release (&handle);
return SCM_UNSPECIFIED;
@@ -187,11 +187,11 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
}
else
{
- for (i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i)
+ for (i = 1, end = dims[0].ubnd-dims[0].lbnd+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)))))
+ scm_array_handle_ref (&handle, i*dims[0].inc),
+ scm_array_handle_ref (&handle, (i-1)*dims[0].inc))))
{
result = SCM_BOOL_F;
break;
@@ -418,10 +418,23 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
}
else if (scm_is_array (items) && scm_c_array_rank (items) == 1)
{
+ scm_t_array_handle handle;
+ scm_t_array_dim const * dims;
+ scm_array_get_handle (items, &handle);
+ dims = scm_array_handle_dims (&handle);
+
+ if (scm_array_handle_rank(&handle) != 1)
+ {
+ scm_array_handle_release (&handle);
+ scm_misc_error (FUNC_NAME, "rank must be 1", scm_list_1 (items));
+ }
+
scm_restricted_vector_sort_x (items,
less,
- scm_from_int (0),
- scm_array_length (items));
+ scm_from_ssize_t (dims[0].lbnd),
+ scm_from_ssize_t (dims[0].ubnd+1));
+
+ scm_array_handle_release (&handle);
return items;
}
else
diff --git a/module/Makefile.am b/module/Makefile.am
index 67f041d..7b621cc 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -44,6 +44,7 @@ ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
SOURCES = \
ice-9/and-let-star.scm \
+ ice-9/arrays.scm \
ice-9/atomic.scm \
ice-9/binary-ports.scm \
ice-9/boot-9.scm \
diff --git a/module/ice-9/arrays.scm b/module/ice-9/arrays.scm
index f7f9e5e..2c04b2e 100644
--- a/module/ice-9/arrays.scm
+++ b/module/ice-9/arrays.scm
@@ -1,22 +1,32 @@
-;;; installed-scm-file
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 1999, 2001, 2004, 2006, 2017 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
-;;;; Copyright (C) 1999, 2001, 2004, 2006 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 (ice-9 arrays)
+ #:export (array-copy))
+
+; This is actually defined in boot-9.scm, apparently for b.c.
+;; (define (array-shape a)
+;; (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
+;; (array-dimensions a)))
+
+; FIXME writes over the array twice if (array-type) is #t
+(define (array-copy a)
+ (let ((b (apply make-typed-array (array-type a) *unspecified* (array-shape a))))
+ (array-copy! a b)
+ b))
-(define (array-shape a)
- (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
- (array-dimensions a)))
diff --git a/test-suite/tests/sort.test b/test-suite/tests/sort.test
index 249f890..c04c2f0 100644
--- a/test-suite/tests/sort.test
+++ b/test-suite/tests/sort.test
@@ -1,5 +1,6 @@
;;;; sort.test --- tests Guile's sort functions -*- scheme -*-
-;;;; Copyright (C) 2003, 2006, 2007, 2009, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2007, 2009, 2011, 2017
+;;;; 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
@@ -15,11 +16,42 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-(use-modules (test-suite lib))
+(use-modules (test-suite lib)
+ (ice-9 arrays))
+
+(set! *random-state* (seed->random-state 2017))
+
+; Randomly shuffle u in place, using Fisher-Yates algorithm.
+(define (array-shuffle! v)
+ (unless (= 1 (array-rank v)) (throw 'bad-rank (array-rank v)))
+ (let* ((dims (car (array-shape v)))
+ (lo (car dims)))
+ (let loop ((i (cadr dims)))
+ (if (> i lo)
+ (let* ((j (+ lo (random (- (1+ i) lo))))
+ (t (array-ref v j)))
+ (array-set! v (array-ref v i) j)
+ (array-set! v t i)
+ (loop (- i 1)))
+ v))))
+
+(define* (test-sort! v #:optional (sort sort))
+ (array-index-map! v (lambda (i) i))
+ (let ((before (array-copy v)))
+ (array-shuffle! v)
+ (let ((after (array-copy v)))
+ (and
+ (equal? before (sort v <))
+ (equal? after v)))))
+
+(define* (test-sort-inplace! v #:optional (sort! sort!))
+ (array-index-map! v (lambda (i) i))
+ (let ((before (array-copy v)))
+ (array-shuffle! v)
+ (and (equal? before (sort! v <))
+ (equal? before v)
+ (sorted? v <))))
-(define (randomize-vector! v n)
- (array-index-map! v (lambda (i) (random n)))
- v)
(with-test-prefix "sort"
@@ -32,66 +64,65 @@
(sort '(1 2) (lambda (x y z) z)))
(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 <) <)))
+ (test-sort! (make-vector 100)))
+
+ (pass-if "sort of typed vector"
+ (test-sort! (make-f64vector 100))))
+
+
+(with-test-prefix "sort!"
+
+ (pass-if "sort of vector"
+ (test-sort-inplace! (make-vector 100)))
+
+ (pass-if "sort! of typed vector"
+ (test-sort-inplace! (make-f64vector 100)))
+
+ (pass-if "sort! of non-contigous array"
+ (let* ((a (make-array 0 100 3))
+ (v (make-shared-array a (lambda (i) (list i 0)) 100)))
+ (test-sort-inplace! 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 <) <)))
+ (test-sort-inplace! v)))
+
+ (pass-if "sort! of negative-increment array"
+ (let* ((a (make-array 0 100 3))
+ (v (make-shared-array a (lambda (i) (list (- 99 i) 0)) 100)))
+ (test-sort-inplace! 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 non-zero base index array"
+ (test-sort-inplace! (make-array 0 '(-99 0))))
+ (pass-if "sort! of non-zero base index typed array"
+ (test-sort-inplace! (make-typed-array 'f64 0 '(-99 0))))
+
(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 <) <)))
+ (test-sort-inplace! v))))
+
+
+(with-test-prefix "stable-sort!"
(pass-if "stable-sort!"
- (let ((v (randomize-vector! (make-vector 1000) 1000)))
- (sorted? (stable-sort! v <) <)))
+ (let ((v (make-vector 100)))
+ (test-sort-inplace! v stable-sort!)))
- (pass-if "stable-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? (stable-sort! v <) <)))
+ (pass-if "stable-sort! of non-contigous array"
+ (let* ((a (make-array 0 100 3))
+ (v (make-shared-array a (lambda (i) (list i 0)) 100)))
+ (test-sort-inplace! v stable-sort!)))
- (pass-if "stable-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? (stable-sort! v <) <))))
+ (pass-if "stable-sort! of negative-increment array"
+ (let* ((a (make-array 0 100 3))
+ (v (make-shared-array a (lambda (i) (list (- 99 i) 0)) 100)))
+ (test-sort-inplace! v stable-sort!)))
+ (pass-if "stable-sort! of non-zero base index array"
+ (test-sort-inplace! (make-array 0 '(-99 0)) stable-sort!)))
;;;
;;; stable-sort
--
2.10.1
^ permalink raw reply related [flat|nested] 7+ messages in thread
* [PATCH 4/6] Support non-zero lower bounds in array-slice-for-each
2017-02-21 11:59 Better support for non-zero lower bound arrays [v2] daniel.llorens
` (2 preceding siblings ...)
2017-02-21 11:59 ` [PATCH 3/6] Fix sort, sort! for arrays with nonzero lower bound daniel.llorens
@ 2017-02-21 11:59 ` daniel.llorens
2017-02-21 11:59 ` [PATCH 5/6] Fix bitvectors and non-zero lower bound arrays in truncated-print daniel.llorens
2017-02-21 11:59 ` [PATCH 6/6] Remove scm_generalized_vector_get_handle daniel.llorens
5 siblings, 0 replies; 7+ messages in thread
From: daniel.llorens @ 2017-02-21 11:59 UTC (permalink / raw)
To: guile-devel
From: Daniel Llorens <daniel.llorens@bluewin.ch>
* libguile/array-handle.c (scm_array_handle_writable_elements): Fix
error message.
* libguile/array-map.c (scm_array_slice_for_each): Support non-zero
lower bounds. Fix error messages.
* test-suite/tests/array-map.test: Test scm_array_slice_for_each with
non-zero lower bound argument.
---
libguile/array-handle.c | 2 +-
libguile/array-map.c | 22 +++++++++-------------
test-suite/tests/array-map.test | 8 ++++++++
3 files changed, 18 insertions(+), 14 deletions(-)
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 89277d9..4c2fe0e 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -327,7 +327,7 @@ SCM *
scm_array_handle_writable_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");
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "array of Scheme values");
return ((SCM*)h->elements) + h->base;
}
diff --git a/libguile/array-map.c b/libguile/array-map.c
index c2825bc..b6529c0 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -677,6 +677,7 @@ SCM_DEFINE (scm_array_slice_for_each, "array-slice-for-each", 2, 0, 1,
"@end lisp")
#define FUNC_NAME s_scm_array_slice_for_each
{
+ SCM xargs = args;
int const N = scm_ilength (args);
int const frank = scm_to_int (frame_rank);
int ocd;
@@ -740,9 +741,9 @@ SCM_DEFINE (scm_array_slice_for_each, "array-slice-for-each", 2, 0, 1,
assert((pool0+pool_size==pool) && "internal error");
#undef AFIC_ALLOC_ADVANCE
- for (n=0; scm_is_pair(args); args=scm_cdr(args), ++n)
+ for (n=0, xargs=args; scm_is_pair(xargs); xargs=scm_cdr(xargs), ++n)
{
- args_[n] = scm_car(args);
+ args_[n] = scm_car(xargs);
scm_array_get_handle(args_[n], ah+n);
as[n] = scm_array_handle_dims(ah+n);
rank[n] = scm_array_handle_rank(ah+n);
@@ -750,29 +751,24 @@ SCM_DEFINE (scm_array_slice_for_each, "array-slice-for-each", 2, 0, 1,
/* checks */
msg = NULL;
if (frank<0)
- msg = "bad frame rank";
+ msg = "bad frame rank ~S, ~S";
else
{
for (n=0; n!=N; ++n)
{
if (rank[n]<frank)
{
- msg = "frame too large for arguments";
+ msg = "frame too large for arguments: ~S, ~S";
goto check_msg;
}
for (k=0; k!=frank; ++k)
{
- if (as[n][k].lbnd!=0)
+ if (as[0][k].lbnd!=as[n][k].lbnd || as[0][k].ubnd!=as[n][k].ubnd)
{
- msg = "non-zero base index is not supported";
+ msg = "mismatched frames: ~S, ~S";
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;
+ s[k] = as[n][k].ubnd - as[n][k].lbnd + 1;
/* this check is needed if the array cannot be entirely */
/* unrolled, because the unrolled subloop will be run before */
@@ -787,7 +783,7 @@ SCM_DEFINE (scm_array_slice_for_each, "array-slice-for-each", 2, 0, 1,
{
for (n=0; n!=N; ++n)
scm_array_handle_release(ah+n);
- scm_misc_error("array-slice-for-each", msg, scm_cons_star(frame_rank, args));
+ scm_misc_error("array-slice-for-each", msg, scm_cons(frame_rank, args));
}
/* prepare moving cells. */
for (n=0; n!=N; ++n)
diff --git a/test-suite/tests/array-map.test b/test-suite/tests/array-map.test
index 3471841..8e0e769 100644
--- a/test-suite/tests/array-map.test
+++ b/test-suite/tests/array-map.test
@@ -520,6 +520,14 @@
(array-slice-for-each 1 (lambda (a) (sort! a <)) a)
a))
+ (pass-if-equal "1 argument frame rank 1, non-zero base indices"
+ #2@1@1((1 3 9) (2 7 8))
+ (let* ((a (make-array *unspecified* '(1 2) '(1 3)))
+ (b #2@1@1((9 1 3) (7 8 2))))
+ (array-copy! b a)
+ (array-slice-for-each 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))))
--
2.10.1
^ permalink raw reply related [flat|nested] 7+ messages in thread
* [PATCH 5/6] Fix bitvectors and non-zero lower bound arrays in truncated-print
2017-02-21 11:59 Better support for non-zero lower bound arrays [v2] daniel.llorens
` (3 preceding siblings ...)
2017-02-21 11:59 ` [PATCH 4/6] Support non-zero lower bounds in array-slice-for-each daniel.llorens
@ 2017-02-21 11:59 ` daniel.llorens
2017-02-21 11:59 ` [PATCH 6/6] Remove scm_generalized_vector_get_handle daniel.llorens
5 siblings, 0 replies; 7+ messages in thread
From: daniel.llorens @ 2017-02-21 11:59 UTC (permalink / raw)
To: guile-devel
From: Daniel Llorens <daniel.llorens@bluewin.ch>
* module/ice-9/arrays.scm (array-print-prefix, array-print): New private
functions.
* libguile/arrays.c (scm_i_print_array): Reuse (array-print-prefix) from
(ice-9 arrays). Make sure to release the array handle.
* module/ice-9/pretty-print.scm (truncated-print): Support
bitvectors.
Don't try to guess the array prefix but call array-print-prefix from
(ice-9 arrays) instead.
Fix call to print-sequence to support non-zero lower bound arrays.
* test-suite/tests/arrays.test: Test that arrays print properly.
* test-suite/tests/print.test: Test truncated-print with bitvectors,
non-zero lower bound arrays.
---
libguile/arrays.c | 48 +++++++----------------------------
module/ice-9/arrays.scm | 40 ++++++++++++++++++++++++++++-
module/ice-9/pretty-print.scm | 26 +++++++++++++------
test-suite/tests/arrays.test | 55 +++++++++++++++++++++++++++++++++++++++-
test-suite/tests/print.test | 58 +++++++++++++++++++++++++++++++++++++------
5 files changed, 170 insertions(+), 57 deletions(-)
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 8b8bc48..682fbf6 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -908,50 +908,17 @@ scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos,
return 1;
}
-/* Print an array.
-*/
-
int
scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
{
scm_t_array_handle h;
- size_t i;
- int print_lbnds = 0, zero_size = 0, print_lens = 0;
+ int d;
+ scm_call_2 (scm_c_private_ref ("ice-9 arrays", "array-print-prefix"),
+ array, port);
+
scm_array_get_handle (array, &h);
- scm_putc ('#', port);
- if (SCM_I_ARRAYP (array))
- scm_intprint (h.ndims, 10, port);
- if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
- scm_write (scm_array_handle_element_type (&h), port);
-
- for (i = 0; i < h.ndims; i++)
- {
- if (h.dims[i].lbnd != 0)
- print_lbnds = 1;
- if (h.dims[i].ubnd - h.dims[i].lbnd + 1 == 0)
- zero_size = 1;
- else if (zero_size)
- print_lens = 1;
- }
-
- if (print_lbnds || print_lens)
- for (i = 0; i < h.ndims; i++)
- {
- if (print_lbnds)
- {
- scm_putc ('@', port);
- scm_intprint (h.dims[i].lbnd, 10, port);
- }
- if (print_lens)
- {
- scm_putc (':', port);
- scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1,
- 10, port);
- }
- }
-
if (h.ndims == 0)
{
/* Rank zero arrays, which are really just scalars, are printed
@@ -977,10 +944,13 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
scm_putc ('(', port);
scm_i_print_array_dimension (&h, 0, 0, port, pstate);
scm_putc (')', port);
- return 1;
+ d = 1;
}
else
- return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
+ d = scm_i_print_array_dimension (&h, 0, 0, port, pstate);
+
+ scm_array_handle_release (&h);
+ return d;
}
void
diff --git a/module/ice-9/arrays.scm b/module/ice-9/arrays.scm
index 2c04b2e..f03eb35 100644
--- a/module/ice-9/arrays.scm
+++ b/module/ice-9/arrays.scm
@@ -17,9 +17,13 @@
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 arrays)
+ #:use-module (rnrs io ports)
+ #:use-module (srfi srfi-1)
#:export (array-copy))
-; This is actually defined in boot-9.scm, apparently for b.c.
+;; This is actually defined in boot-9.scm, apparently for backwards
+;; compatibility.
+
;; (define (array-shape a)
;; (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
;; (array-dimensions a)))
@@ -30,3 +34,37 @@
(array-copy! a b)
b))
+\f
+;; Printing arrays
+
+;; The dimensions aren't printed out unless they cannot be deduced from
+;; the content, which happens only when certain axes are empty. #:dims?
+;; can be used to force this printing. An array with all the dimensions
+;; printed out is still readable syntax, this can be useful for
+;; truncated-print.
+
+(define* (array-print-prefix a port #:key dims?)
+ (put-char port #\#)
+ (display (array-rank a) port)
+ (let ((t (array-type a)))
+ (unless (eq? #t t)
+ (display t port)))
+ (let ((ss (array-shape a)))
+ (let loop ((s ss) (slos? #f) (szero? #f) (slens? dims?))
+ (define lo caar)
+ (define hi cadar)
+ (if (null? s)
+ (when (or slos? slens?)
+ (pair-for-each (lambda (s)
+ (when slos?
+ (put-char port #\@)
+ (display (lo s) port))
+ (when slens?
+ (put-char port #\:)
+ (display (- (hi s) (lo s) -1) port)))
+ ss))
+ (let ((zero-size? (zero? (- (hi s) (lo s) -1))))
+ (loop (cdr s)
+ (or slos? (not (zero? (lo s))))
+ (or szero? zero-size?)
+ (or slens? (and (not zero-size?) szero?))))))))
diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index d3d7652..5be108d 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -429,17 +429,25 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(display ")"))
(else
(display "#"))))
+ ((bitvector? x)
+ (cond
+ ((>= width (+ 2 (array-length x)))
+ (format #t "~a" x))
+ ;; the truncated bitvector would print as #1b(...), so we print by hand.
+ ((>= width (+ 2 ellipsis-width))
+ (format #t "#*")
+ (array-for-each (lambda (xi) (format #t (if xi "1" "0")))
+ (make-shared-array x list (- width 2 ellipsis-width)))
+ (format #t ellipsis))
+ (else
+ (display "#"))))
((and (array? x) (not (string? x)))
(let* ((type (array-type x))
- (prefix
+ (prefix
(if inner?
""
- (if (zero? (array-rank x))
- (string-append "#0" (if (eq? #t type) "" (symbol->string type)))
- (let ((s (format #f "~a"
- (apply make-typed-array type *unspecified*
- (make-list (array-rank x) 0)))))
- (substring s 0 (- (string-length s) 2))))))
+ (call-with-output-string
+ (lambda (s) ((@@ (ice-9 arrays) array-print-prefix) x s)))))
(width-prefix (string-length prefix)))
(cond
((>= width (+ 2 width-prefix ellipsis-width))
@@ -447,7 +455,9 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(if (zero? (array-rank x))
(print (array-ref x) (- width width-prefix 2))
(print-sequence x (- width width-prefix 2) (array-length x)
- array-cell-ref identity
+ (let ((base (caar (array-shape x))))
+ (lambda (x i) (array-cell-ref x (+ base i))))
+ identity
#:inner? (< 1 (array-rank x))))
(display ")"))
(else
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 1df77b1..e913e30 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -999,4 +999,57 @@
"#1(b c)"
(format #f "~a" (make-shared-array #(a b c)
(lambda (i) (list (+ i 1)))
- 2))))
+ 2)))
+
+ (pass-if-equal "0-array"
+ "#0(9)"
+ (format #f "~a" (make-array 9)))
+
+ (pass-if-equal "2-array"
+ "#2f64((0.0 1.0) (2.0 3.0))"
+ (format #f "~a" #2f64((0 1) (2 3))))
+
+ (pass-if-equal "empty 3-array"
+ "#3()"
+ (format #f "~a" (make-array 1 0 0 0)))
+
+ (pass-if-equal "empty 3-array with last nonempty dim."
+ "#3:0:0:1()"
+ (format #f "~a" (make-array 1 0 0 1)))
+
+ (pass-if-equal "empty 3-array with middle nonempty dim."
+ "#3:0:1:0()"
+ (format #f "~a" (make-array 1 0 1 0)))
+
+ (pass-if-equal "empty 3-array with first nonempty dim."
+ "#3(())"
+ (format #f "~a" (make-array 1 1 0 0)))
+
+ (pass-if-equal "3-array with non-zero lower bounds"
+ "#3@1@0@1(((1 1 1) (1 1 1)) ((1 1 1) (1 1 1)))"
+ (format #f "~a" (make-array 1 '(1 2) '(0 1) '(1 3))))
+
+ (pass-if-equal "3-array with non-zero-lower bounds and last nonempty dim."
+ "#3@0:0@0:0@1:3()"
+ (format #f "~a" (make-array 1 0 0 '(1 3))))
+
+ (pass-if-equal "3-array with non-zero-lower bounds and middle nonempty dim."
+ "#3@0:0@1:3@0:0()"
+ (format #f "~a" (make-array 1 0 '(1 3) 0)))
+
+ (pass-if-equal "3-array with non-zero-lower bounds and first nonempty dim."
+ "#3@1@0@0(() () ())"
+ (format #f "~a" (make-array 1 '(1 3) 0 0)))
+
+ (pass-if-equal "3-array with singleton dim case I"
+ "#3@1@1@-1(((1 1 1)))"
+ (format #f "~a" (make-array 1 '(1 1) '(1 1) '(-1 1))))
+
+ (pass-if-equal "3-array with singleton dim case II"
+ "#3@-1@1@1(((1) (1) (1)))"
+ (format #f "~a" (make-array 1 '(-1 -1) '(1 3) '(1 1))))
+
+ (pass-if-equal "3-array with singleton dim case III"
+ "#3@1@-1@1(((1)) ((1)) ((1)))"
+ (format #f "~a" (make-array 1 '(1 3) '(-1 -1) '(1 1)))))
+
diff --git a/test-suite/tests/print.test b/test-suite/tests/print.test
index 82cc776..f2e3145 100644
--- a/test-suite/tests/print.test
+++ b/test-suite/tests/print.test
@@ -147,6 +147,35 @@
(pass-if-equal "#<directory (test-…>"
(tprint (current-module) 20 "UTF-8"))
+ ;; bitvectors
+
+ (let ((testv (bitvector #t #f #f #t #t #f #t #t)))
+ (pass-if-equal "#*10011011"
+ (tprint testv 11 "UTF-8"))
+
+ (pass-if-equal "#*10011011"
+ (tprint testv 11 "ISO-8859-1"))
+
+ (pass-if-equal "#*10011…"
+ (tprint testv 8 "UTF-8"))
+
+ (pass-if-equal "#*100..."
+ (tprint testv 8 "ISO-8859-1"))
+
+ (pass-if-equal "#*10…"
+ (tprint testv 5 "UTF-8"))
+
+ (pass-if-equal "#*..."
+ (tprint testv 5 "ISO-8859-1"))
+
+ (pass-if-equal "#*1…"
+ (tprint testv 4 "UTF-8"))
+
+ (pass-if-equal "#"
+ (tprint testv 4 "ISO-8859-1")))
+
+ ;; rank 0 arrays
+
(pass-if-equal "#0(#)"
(tprint (make-typed-array #t 9.0) 6 "UTF-8"))
@@ -162,18 +191,31 @@
(pass-if-equal "#"
(tprint (make-typed-array 's32 0 20 20) 7 "UTF-8"))
- (pass-if-equal "#2s32(…)"
- (tprint (make-typed-array 's32 0 20 20) 8 "UTF-8"))
+ ;; higher dimensional arrays
+
+ (let ((testa (make-typed-array 's32 0 20 20)))
+ (pass-if-equal "#2s32(…)"
+ (tprint testa 8 "UTF-8"))
+
+ (pass-if-equal "#2s32(# …)"
+ (tprint testa 10 "UTF-8"))
- (pass-if-equal "#2s32(# …)"
- (tprint (make-typed-array 's32 0 20 20) 10 "UTF-8"))
+ (pass-if-equal "#2s32((…) …)"
+ (tprint testa 12 "UTF-8"))
- (pass-if-equal "#2s32((…) …)"
- (tprint (make-typed-array 's32 0 20 20) 12 "UTF-8"))
+ (pass-if-equal "#2s32((0 …) …)"
+ (tprint testa 14 "UTF-8")))
- (pass-if-equal "#2s32((0 …) …)"
- (tprint (make-typed-array 's32 0 20 20) 14 "UTF-8"))
+ ;; check that bounds are printed correctly
+ (pass-if-equal "#2@-1@0((foo foo foo foo …) …)"
+ (tprint (make-array 'foo '(-1 3) 5) 30 "UTF-8"))
+
+ (pass-if-equal "#3@-1:5@0:0@0:5(() () () # #)"
+ (tprint (make-array 'foo '(-1 3) 0 5) 30 "UTF-8"))
+
+ ;; nested objects including arrays
+
(pass-if-equal "#2((#(9 9) #(9 9)) (#(9 9) #(9 9)))"
(tprint (make-typed-array #t (make-typed-array #t 9 2) 2 2) 40 "UTF-8"))
--
2.10.1
^ permalink raw reply related [flat|nested] 7+ messages in thread
* [PATCH 6/6] Remove scm_generalized_vector_get_handle
2017-02-21 11:59 Better support for non-zero lower bound arrays [v2] daniel.llorens
` (4 preceding siblings ...)
2017-02-21 11:59 ` [PATCH 5/6] Fix bitvectors and non-zero lower bound arrays in truncated-print daniel.llorens
@ 2017-02-21 11:59 ` daniel.llorens
5 siblings, 0 replies; 7+ messages in thread
From: daniel.llorens @ 2017-02-21 11:59 UTC (permalink / raw)
To: guile-devel
From: Daniel Llorens <daniel.llorens@bluewin.ch>
This was deprecated in 2.0.9 (118ff892be199f0af359d1b027645d4783a364ec).
* libguile/bitvectors.c (scm_bitvector_writable_elements): Replace
scm_generalized_vector_get_handle.
Remove unnecessary #includes.
* libguile/vectors.c (scm_vector_writable_elements): Replace
scm_generalized_vector_get_handle.
Remove unnecessary #includes.
* libguile/random.c (scm_random_normal_vector_x): Replace
scm_generalized_vector_get_handle.
* libguile/generalized-vectors.h, libguile/generalized-vectors.c
(scm_generalized_vector_get_handle): Remove.
Remove unnecessary #includes.
* NEWS: Add removal notice.
---
NEWS | 4 ++++
libguile/bitvectors.c | 10 ++++++----
libguile/generalized-vectors.c | 13 -------------
libguile/generalized-vectors.h | 7 ++-----
libguile/random.c | 8 +++++++-
libguile/vectors.c | 15 ++++++++-------
6 files changed, 27 insertions(+), 30 deletions(-)
diff --git a/NEWS b/NEWS
index 1a0a285..8b39901 100644
--- a/NEWS
+++ b/NEWS
@@ -746,6 +746,10 @@ but not specifically mentioned earlier in this file, have been removed:
removed. Use `get-bytevector-n!' and `put-bytevector' from (rnrs io
ports) instead.
+*** `scm_generalized_vector_get_handle' has been removed. Use
+ `scm_array_get_handle' to get a handle and `scm_array_handle_rank'
+ to check the rank.
+
** Remove miscellaneous unused interfaces
We have removed accidentally public, undocumented interfaces that we
diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c
index 7a4ed9b..0dde67b 100644
--- a/libguile/bitvectors.c
+++ b/libguile/bitvectors.c
@@ -27,12 +27,9 @@
#include "libguile/_scm.h"
#include "libguile/__scm.h"
-#include "libguile/strings.h"
#include "libguile/array-handle.h"
#include "libguile/bitvectors.h"
#include "libguile/arrays.h"
-#include "libguile/generalized-vectors.h"
-#include "libguile/srfi-4.h"
/* Bit vectors. Would be nice if they were implemented on top of bytevectors,
* but alack, all we have is this crufty C.
@@ -204,7 +201,12 @@ scm_bitvector_writable_elements (SCM vec,
size_t *lenp,
ssize_t *incp)
{
- scm_generalized_vector_get_handle (vec, h);
+ scm_array_get_handle (vec, h);
+ if (1 != scm_array_handle_rank (h))
+ {
+ scm_array_handle_release (h);
+ scm_wrong_type_arg_msg (NULL, 0, vec, "rank 1 bit array");
+ }
if (offp)
{
scm_t_array_dim *dim = scm_array_handle_dims (h);
diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c
index 276b9d8..68c1042 100644
--- a/libguile/generalized-vectors.c
+++ b/libguile/generalized-vectors.c
@@ -27,8 +27,6 @@
#include "libguile/_scm.h"
#include "libguile/__scm.h"
-#include "libguile/array-handle.h"
-#include "libguile/generalized-arrays.h"
#include "libguile/generalized-vectors.h"
@@ -70,17 +68,6 @@ SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0,
#undef FUNC_NAME
void
-scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h)
-{
- scm_array_get_handle (vec, h);
- if (scm_array_handle_rank (h) != 1)
- {
- scm_array_handle_release (h);
- scm_wrong_type_arg_msg (NULL, 0, vec, "vector");
- }
-}
-
-void
scm_init_generalized_vectors ()
{
#include "libguile/generalized-vectors.x"
diff --git a/libguile/generalized-vectors.h b/libguile/generalized-vectors.h
index 77d6272..9df8a0c 100644
--- a/libguile/generalized-vectors.h
+++ b/libguile/generalized-vectors.h
@@ -3,7 +3,8 @@
#ifndef SCM_GENERALIZED_VECTORS_H
#define SCM_GENERALIZED_VECTORS_H
-/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 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
@@ -24,15 +25,11 @@
\f
#include "libguile/__scm.h"
-#include "libguile/array-handle.h"
\f
/* Generalized vectors */
-SCM_API void scm_generalized_vector_get_handle (SCM vec,
- scm_t_array_handle *h);
-
SCM_API SCM scm_make_generalized_vector (SCM type, SCM len, SCM fill);
SCM_INTERNAL void scm_i_register_vector_constructor (SCM type, SCM (*ctor)(SCM, SCM));
diff --git a/libguile/random.c b/libguile/random.c
index 1ee0459..a8ad075 100644
--- a/libguile/random.c
+++ b/libguile/random.c
@@ -621,7 +621,13 @@ SCM_DEFINE (scm_random_normal_vector_x, "random:normal-vector!", 1, 1, 0,
state = SCM_VARIABLE_REF (scm_var_random_state);
SCM_VALIDATE_RSTATE (2, state);
- scm_generalized_vector_get_handle (v, &handle);
+ scm_array_get_handle (v, &handle);
+ if (1 != scm_array_handle_rank (&handle))
+ {
+ scm_array_handle_release (&handle);
+ scm_wrong_type_arg_msg (NULL, 0, v, "rank 1 array");
+ }
+
dim = scm_array_handle_dims (&handle);
if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
diff --git a/libguile/vectors.c b/libguile/vectors.c
index b9613c5..81cac79 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -25,15 +25,10 @@
#include "libguile/_scm.h"
#include "libguile/eq.h"
-#include "libguile/strings.h"
#include "libguile/validate.h"
#include "libguile/vectors.h"
-#include "libguile/arrays.h" /* Hit me with the ugly stick */
-#include "libguile/generalized-vectors.h"
-#include "libguile/strings.h"
-#include "libguile/srfi-13.h"
-#include "libguile/dynwind.h"
+#include "libguile/array-handle.h"
#include "libguile/bdw-gc.h"
@@ -70,7 +65,13 @@ scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
if (SCM_I_WVECTP (vec))
scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
- scm_generalized_vector_get_handle (vec, h);
+ scm_array_get_handle (vec, h);
+ if (1 != scm_array_handle_rank (h))
+ {
+ scm_array_handle_release (h);
+ scm_wrong_type_arg_msg (NULL, 0, vec, "rank 1 array of Scheme values");
+ }
+
if (lenp)
{
scm_t_array_dim *dim = scm_array_handle_dims (h);
--
2.10.1
^ permalink raw reply related [flat|nested] 7+ messages in thread
end of thread, other threads:[~2017-02-21 11:59 UTC | newest]
Thread overview: 7+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2017-02-21 11:59 Better support for non-zero lower bound arrays [v2] daniel.llorens
2017-02-21 11:59 ` [PATCH 1/6] Replace uniform-vector-read benchmark with bytevector-io benchmark daniel.llorens
2017-02-21 11:59 ` [PATCH 2/6] Remove documentation on uniform-vector-read!, uniform-vector-write daniel.llorens
2017-02-21 11:59 ` [PATCH 3/6] Fix sort, sort! for arrays with nonzero lower bound daniel.llorens
2017-02-21 11:59 ` [PATCH 4/6] Support non-zero lower bounds in array-slice-for-each daniel.llorens
2017-02-21 11:59 ` [PATCH 5/6] Fix bitvectors and non-zero lower bound arrays in truncated-print daniel.llorens
2017-02-21 11:59 ` [PATCH 6/6] Remove scm_generalized_vector_get_handle daniel.llorens
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).