diff --git a/libguile/quicksort.i.c b/libguile/quicksort.i.c index 4e39f827a..cf1742efa 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 9373fb892..8c20d3453 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; + 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); - elts = scm_vector_elements (items, &handle, &len, &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); + } - 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; - } - } + 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 9209b539f..249f890ec 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 '#() <)))) -