[Guile-commits] 06/11: Support typed arrays in some sort functions

[Daniel Llorens]

lloda pushed a commit to branch lloda-squash0
in repository guile.

commit d0dd52756ca032eeebc458313f28e2c95e386d5f
Author: Daniel Llorens <address@hidden>
Date:   Tue Jul 12 18:43:03 2016 +0200

    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            |  131 ++++++++++++++++++++++++++++++--------------
 test-suite/tests/sort.test |   32 ++++++++++-
 3 files changed, 140 insertions(+), 68 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..8c20d34 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,39 @@ 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_t_array_dim const * dims;
+  scm_array_get_handle (vec, &handle);
+  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 +159,49 @@ 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;
-           }
-       }
+      ssize_t i, end;
+      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_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 (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 (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 +443,14 @@ 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);
+    {
+      SCM copy;
+      if (scm_c_array_rank (items) != 1)
+        scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items, 
SCM_EOL);
+      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 +544,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 '#() <))))
-