mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
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.
This commit is contained in:
Daniel Llorens
parent
3320eaa788
commit
f227a56991
3 changed files with 151 additions and 82 deletions
|
|
@ -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
|
||||
|
|
|
|||
108
libguile/sort.c
108
libguile/sort.c
|
|
@ -51,21 +51,23 @@
|
|||
#include "libguile/validate.h"
|
||||
#include "libguile/sort.h"
|
||||
|
||||
/* We have two quicksort variants: one for contigous vectors and one
|
||||
for vectors with arbitrary increments between elements. Note that
|
||||
increments can be negative.
|
||||
/* We have two quicksort variants: one for SCM (#t) arrays and one for
|
||||
typed arrays.
|
||||
*/
|
||||
|
||||
#define NAME quicksort1
|
||||
#define INC_PARAM /* empty */
|
||||
#define INC 1
|
||||
#include "libguile/quicksort.i.c"
|
||||
|
||||
#define NAME quicksort
|
||||
#define INC_PARAM ssize_t inc,
|
||||
#define INC inc
|
||||
#define VEC_PARAM SCM * ra,
|
||||
#define GET(i) ra[(i)*inc]
|
||||
#define SET(i, val) ra[(i)*inc] = val
|
||||
#include "libguile/quicksort.i.c"
|
||||
|
||||
#define NAME quicksorta
|
||||
#define INC_PARAM
|
||||
#define VEC_PARAM scm_t_array_handle * const ra,
|
||||
#define GET(i) scm_array_handle_ref (ra, scm_array_handle_pos_1 (ra, i))
|
||||
#define SET(i, val) scm_array_handle_set (ra, scm_array_handle_pos_1 (ra, i), val)
|
||||
#include "libguile/quicksort.i.c"
|
||||
|
||||
SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
|
||||
(SCM vec, SCM less, SCM startpos, SCM endpos),
|
||||
|
|
@ -76,22 +78,38 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
|
|||
"is not specified.")
|
||||
#define FUNC_NAME s_scm_restricted_vector_sort_x
|
||||
{
|
||||
size_t vlen, spos, len;
|
||||
ssize_t vinc;
|
||||
ssize_t spos = scm_to_ssize_t (startpos);
|
||||
size_t epos = scm_to_ssize_t (endpos);
|
||||
|
||||
scm_t_array_handle handle;
|
||||
SCM *velts;
|
||||
scm_array_get_handle (vec, &handle);
|
||||
scm_t_array_dim const * dims = scm_array_handle_dims (&handle);
|
||||
|
||||
velts = scm_vector_writable_elements (vec, &handle, &vlen, &vinc);
|
||||
spos = scm_to_unsigned_integer (startpos, 0, vlen);
|
||||
len = scm_to_unsigned_integer (endpos, spos, vlen) - spos;
|
||||
if (scm_array_handle_rank(&handle) != 1)
|
||||
{
|
||||
scm_array_handle_release (&handle);
|
||||
scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", vec, SCM_EOL);
|
||||
}
|
||||
if (spos < dims[0].lbnd)
|
||||
{
|
||||
scm_array_handle_release (&handle);
|
||||
scm_error (scm_out_of_range_key, FUNC_NAME, "startpos out of range",
|
||||
vec, scm_list_1(startpos));
|
||||
}
|
||||
if (epos > dims[0].ubnd+1)
|
||||
{
|
||||
scm_array_handle_release (&handle);
|
||||
scm_error (scm_out_of_range_key, FUNC_NAME, "endpos out of range",
|
||||
vec, scm_list_1(endpos));
|
||||
}
|
||||
|
||||
if (vinc == 1)
|
||||
quicksort1 (velts + spos*vinc, len, less);
|
||||
if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
|
||||
quicksort (scm_array_handle_writable_elements (&handle) + (spos-dims[0].lbnd) * dims[0].inc,
|
||||
epos-spos, dims[0].inc, less);
|
||||
else
|
||||
quicksort (velts + spos*vinc, len, vinc, less);
|
||||
quicksorta (&handle, epos-spos, less);
|
||||
|
||||
scm_array_handle_release (&handle);
|
||||
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
|
@ -140,15 +158,23 @@ 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);
|
||||
scm_t_array_handle handle;
|
||||
scm_array_get_handle (items, &handle);
|
||||
scm_t_array_dim const * dims = scm_array_handle_dims (&handle);
|
||||
|
||||
for (i = 1; i < len; i++, elts += inc)
|
||||
if (scm_array_handle_rank(&handle) != 1)
|
||||
{
|
||||
scm_array_handle_release (&handle);
|
||||
scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items, SCM_EOL);
|
||||
}
|
||||
|
||||
if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
|
||||
{
|
||||
ssize_t inc = dims[0].inc;
|
||||
const SCM *elts = scm_array_handle_elements (&handle);
|
||||
for (ssize_t i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i, elts += inc)
|
||||
{
|
||||
if (scm_is_true (scm_call_2 (less, elts[inc], elts[0])))
|
||||
{
|
||||
|
|
@ -156,13 +182,24 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
|
|||
break;
|
||||
}
|
||||
}
|
||||
|
||||
scm_array_handle_release (&handle);
|
||||
|
||||
return result;
|
||||
}
|
||||
else
|
||||
{
|
||||
for (ssize_t i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i)
|
||||
{
|
||||
if (scm_is_true (scm_call_2 (less,
|
||||
scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i)),
|
||||
scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i-1)))))
|
||||
{
|
||||
result = SCM_BOOL_F;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return SCM_BOOL_F;
|
||||
scm_array_handle_release (&handle);
|
||||
return result;
|
||||
}
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -404,7 +441,13 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
|
|||
if (scm_is_pair (items))
|
||||
return scm_sort_x (scm_list_copy (items), less);
|
||||
else if (scm_is_array (items) && scm_c_array_rank (items) == 1)
|
||||
return scm_sort_x (scm_vector_copy (items), less);
|
||||
{
|
||||
if (scm_c_array_rank (items) != 1)
|
||||
scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items, SCM_EOL);
|
||||
SCM copy = scm_make_typed_array (scm_array_type (items), SCM_UNSPECIFIED, scm_array_dimensions (items));
|
||||
scm_array_copy_x (items, copy);
|
||||
return scm_sort_x (copy, less);
|
||||
}
|
||||
else
|
||||
SCM_WRONG_TYPE_ARG (1, items);
|
||||
}
|
||||
|
|
@ -498,7 +541,8 @@ 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) {
|
||||
if (len == 0)
|
||||
{
|
||||
scm_array_handle_release (&vec_handle);
|
||||
return items;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 '#() <))))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue