mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Fix sort, sort! for arrays with nonzero lower bound

Browse source 
* 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!.
This commit is contained in:
Daniel Llorens 2017-02-13 12:58:34 +01:00
parent ffcdb7bddf
commit 3bfd4aaa6e
6 changed files with 202 additions and 134 deletions
Download patch file Download diff file Expand all files Collapse all files

32
doc/ref/api-data.texi
View file

@ -7498,10 +7498,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
@ -7509,14 +7505,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
@ -7568,6 +7565,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

48
libguile/quicksort.i.c
View file

@ -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));

44
libguile/sort.c
View file

@ -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,25 @@ 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 +186,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;
@ -427,10 +426,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

1
module/Makefile.am
View file

@ -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 \

50
module/ice-9/arrays.scm
View file

@ -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)))

131
test-suite/tests/sort.test
View file

@ -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,67 +64,72 @@
(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))))
(test-sort! (make-vector 100)))
(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 typed vector"
(test-sort! (make-f64vector 100))))
(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 <) <)))
(with-test-prefix "sort!"
(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 empty vector"
(test-sort-inplace! (vector)))
(pass-if "sort of vector"
(test-sort-inplace! (make-vector 100)))
(pass-if "sort of empty typed vector"
(test-sort-inplace! (f64vector)))
(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 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 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 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 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!)))
(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 <) <))))
(with-test-prefix "stable-sort"