Fix sort, sort! for arrays with nonzero lower bound

* 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

@@ -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
+Set each element of the @var{dst} array to values obtained from calls to
-to @var{proc}.  The value returned is unspecified.
+@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})},
+Each call is @code{(@var{proc} @var{elem} @dots{})}, where each
-where each @var{elem} is from the corresponding @var{src} array, at
+@var{elem} is from the corresponding @var{src} array, at the
-the @var{dst} index.  @code{array-map-in-order!} makes the calls in
+@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
 

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;
+    ssize_t lo;
-    size_t hi;
+    ssize_t hi;
   } stack_node;
 
   static const char s_buggy_less[] = "buggy less predicate used when sorting";
 
-  if (nr_elems == 0)
+  if (ubnd-lbnd+1 > MAX_THRESH)
-    /* Avoid lossage with unsigned arithmetic below.  */
-    return;
-
-  if (nr_elems > MAX_THRESH)
     {
-      size_t lo = 0;
+      ssize_t lo = lbnd;
-      size_t hi = nr_elems-1;
+      ssize_t hi = ubnd;
 
       stack_node stack[STACK_SIZE];
       stack_node *top = stack + 1;
 
       while (STACK_NOT_EMPTY)
 	{
-	  size_t left;
+	  ssize_t left;
-	  size_t right;
+	  ssize_t right;
-	  size_t mid = lo + (hi - lo) / 2;
+	  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;
+    ssize_t tmp = lbnd;
-    size_t end = nr_elems-1;
+    ssize_t end = ubnd;
-    size_t thresh = min (end, MAX_THRESH);
+    ssize_t thresh = min (end, MAX_THRESH);
-    size_t run;
+    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)
+    if (tmp != lbnd)
-      SWAP (tmp, 0);
+      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));

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,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",
+      scm_error (scm_out_of_range_key, FUNC_NAME, "startpos ~s out of range of ~s",
-                 vec, scm_list_1(startpos));
+                 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",
+      scm_error (scm_out_of_range_key, FUNC_NAME, "endpos ~s out of range of ~s",
-                 vec, scm_list_1(endpos));
+                 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,
+    quicksort (scm_array_handle_writable_elements (&handle) - dims[0].lbnd * dims[0].inc,
-                 epos-spos, dims[0].inc, less);
+               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, i*dims[0].inc),
-                                           scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i-1)))))
+                                           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_from_ssize_t (dims[0].lbnd),
-				    scm_array_length (items));
+                                    scm_from_ssize_t (dims[0].ubnd+1));
+
+      scm_array_handle_release (&handle);
       return items;
     }
   else

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				\

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.
+(define-module (ice-9 arrays)
-;;;; 
+  #:export (array-copy))
-;;;; This library is free software; you can redistribute it and/or
+
-;;;; modify it under the terms of the GNU Lesser General Public
+; This is actually defined in boot-9.scm, apparently for b.c.
-;;;; License as published by the Free Software Foundation; either
+;; (define (array-shape a)
-;;;; version 3 of the License, or (at your option) any later version.
+;;   (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
-;;;; 
+;;        (array-dimensions a)))
-;;;; This library is distributed in the hope that it will be useful,
+
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; FIXME writes over the array twice if (array-type) is #t
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+(define (array-copy a)
-;;;; Lesser General Public License for more details.
+  (let ((b (apply make-typed-array (array-type a) *unspecified* (array-shape a))))
-;;;; 
+    (array-copy! a b)
-;;;; You should have received a copy of the GNU Lesser General Public
+    b))
-;;;; 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 (array-shape a)
-  (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
-       (array-dimensions a)))

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,67 +64,72 @@
     (sort '(1 2) (lambda (x y z) z)))
 
   (pass-if "sort of vector"
-    (let* ((v (randomize-vector! (make-vector 1000) 1000))
+    (test-sort! (make-vector 100)))
-           (w (vector-copy v)))
-      (and (sorted? (sort v <) <)
-           (equal? w v))))
 
-  (pass-if "sort of typed array"
+  (pass-if "sort of typed vector"
-    (let* ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99))
+    (test-sort! (make-f64vector 100))))
-           (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"
+(with-test-prefix "sort!"
-    (let ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99)))
-      (sorted? (sort! v <) <)))
 
-  (pass-if "sort! of non-contigous vector"
+  (pass-if "sort of empty vector"
-    (let* ((a (make-array 0 1000 3))
+    (test-sort-inplace! (vector)))
-	   (v (make-shared-array a (lambda (i) (list i 0)) 1000)))
+
-      (randomize-vector! v 1000)
+  (pass-if "sort of vector"
-      (sorted? (sort! v <) <)))
+    (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)
+      (test-sort-inplace! v)))
-      (sorted? (sort! v <) <)))
 
-  (pass-if "sort! of negative-increment vector"
+  (pass-if "sort! of negative-increment array"
-    (let* ((a (make-array 0 1000 3))
+    (let* ((a (make-array 0 100 3))
-	   (v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000)))
+	   (v (make-shared-array a (lambda (i) (list (- 99 i) 0)) 100)))
-      (randomize-vector! v 1000)
+      (test-sort-inplace! v)))
-      (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)
+      (test-sort-inplace! v))))
-      (sorted? (sort! v <) <))))
+
 
 (with-test-prefix "stable-sort!"
 
   (pass-if "stable-sort!"
-    (let ((v (randomize-vector! (make-vector 1000) 1000)))
+    (let ((v (make-vector 100)))
-      (sorted? (stable-sort! v <) <)))
+      (test-sort-inplace! v stable-sort!)))
 
-  (pass-if "stable-sort! of non-contigous vector"
+  (pass-if "stable-sort! of non-contigous array"
-    (let* ((a (make-array 0 1000 3))
+    (let* ((a (make-array 0 100 3))
-	   (v (make-shared-array a (lambda (i) (list i 0)) 1000)))
+	   (v (make-shared-array a (lambda (i) (list i 0)) 100)))
-      (randomize-vector! v 1000)
+      (test-sort-inplace! v stable-sort!)))
-      (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!)))
 
-  (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"