mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-04 05:50:26 +02:00
Code Activity

Support typed arrays in some sort functions

Browse source 
* 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 2016-07-12 18:43:03 +02:00
parent 0ebea8746b
commit d0dd52756c
3 changed files with 138 additions and 66 deletions
Download patch file Download diff file Expand all files Collapse all files

127
libguile/sort.c
View file

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