mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-03 11:33:37 +00:00
Code Issues Releases Activity

Add vectors support to Fsort.

Browse Source 
* configure.ac (AC_CHECK_FUNCS): Check for qsort_r.
* src/fns.c (sort_vector, sort_vector_compare): New functions.
(sort_list): Likewise, refactored out of ...
(Fsort): ... adjusted user.  Mention vectors in docstring.
(sort_vector_predicate) [!HAVE_QSORT_R]: New variable.
* src/alloc.c (make_save_int_obj): New function.
* src/lisp.h (enum Lisp_Save_Type): New member SAVE_TYPE_INT_OBJ.
(make_save_int_obj): Add prototype.
* test/automated/fns-tests.el (fns-tests-sort): New test.
This commit is contained in:
Dmitry Antipov 2014-08-29 11:29:47 +04:00
parent 483dc86ad0
commit 1764ec4414
8 changed files with 143 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
ChangeLog
View File

@ -1,3 +1,7 @@
2014-08-29 Dmitry Antipov <dmantipov@yandex.ru>
* configure.ac (AC_CHECK_FUNCS): Check for qsort_r.
2014-08-28 Ken Brown <kbrown@cornell.edu>
* configure.ac (HYBRID_MALLOC): New macro; define to use gmalloc

2
configure.ac
View File

@ -3573,7 +3573,7 @@ select getpagesize setlocale newlocale \
getrlimit setrlimit shutdown getaddrinfo \
pthread_sigmask strsignal setitimer \
sendto recvfrom getsockname getpeername getifaddrs freeifaddrs \
gai_strerror sync \
gai_strerror sync qsort_r \
getpwent endpwent getgrent endgrent \
cfmakeraw cfsetspeed copysign __executable_start log2)
LIBS=$OLD_LIBS

11
src/ChangeLog
View File

@ -1,3 +1,14 @@
2014-08-29 Dmitry Antipov <dmantipov@yandex.ru>
Add vectors support to Fsort.
* fns.c (sort_vector, sort_vector_compare): New functions.
(sort_list): Likewise, refactored out of ...
(Fsort): ... adjusted user. Mention vectors in docstring.
(sort_vector_predicate) [!HAVE_QSORT_R]: New variable.
* alloc.c (make_save_int_obj): New function.
* lisp.h (enum Lisp_Save_Type): New member SAVE_TYPE_INT_OBJ.
(make_save_int_obj): Add prototype.
2014-08-28 Ken Brown <kbrown@cornell.edu>
Add support for HYBRID_MALLOC, allowing the use of gmalloc before

11
src/alloc.c
View File

@ -3610,6 +3610,17 @@ make_save_ptr_int (void *a, ptrdiff_t b)
return val;
}
Lisp_Object
make_save_int_obj (ptrdiff_t a, Lisp_Object b)
{
Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
struct Lisp_Save_Value *p = XSAVE_VALUE (val);
p->save_type = SAVE_TYPE_INT_OBJ;
p->data[0].integer = a;
p->data[1].object = b;
return val;
}
#if ! (defined USE_X_TOOLKIT || defined USE_GTK)
Lisp_Object
make_save_ptr_ptr (void *a, void *b)

99
src/fns.c
View File

@ -1846,13 +1846,12 @@ See also the function `nreverse', which is used more often. */)
wrong_type_argument (Qsequencep, seq);
return new;
}
DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
doc: /* Sort LIST, stably, comparing elements using PREDICATE.
Returns the sorted list. LIST is modified by side effects.
PREDICATE is called with two elements of LIST, and should return non-nil
if the first element should sort before the second. */)
(Lisp_Object list, Lisp_Object predicate)
/* Sort LIST using PREDICATE, preserving original order of elements
considered as equal. */
static Lisp_Object
sort_list (Lisp_Object list, Lisp_Object predicate)
{
Lisp_Object front, back;
register Lisp_Object len, tem;
@ -1877,6 +1876,92 @@ if the first element should sort before the second. */)
return merge (front, back, predicate);
}
/* Using GNU qsort_r, we can pass this as a parameter. */
#ifndef HAVE_QSORT_R
static Lisp_Object sort_vector_predicate;
#endif
/* Comparison function called by qsort. */
static int
#ifdef HAVE_QSORT_R
sort_vector_compare (const void *p, const void *q, void *arg)
#else
sort_vector_compare (const void *p, const void *q)
#endif /* HAVE_QSORT_R */
{
bool more, less;
Lisp_Object op, oq, vp, vq;
#ifdef HAVE_QSORT_R
Lisp_Object sort_vector_predicate = *(Lisp_Object *) arg;
#endif
op = *(Lisp_Object *) p;
oq = *(Lisp_Object *) q;
vp = XSAVE_OBJECT (op, 1);
vq = XSAVE_OBJECT (oq, 1);
/* Use recorded element index as a secondary key to
preserve original order. Pretty ugly but works. */
more = NILP (call2 (sort_vector_predicate, vp, vq));
less = NILP (call2 (sort_vector_predicate, vq, vp));
return ((more && !less) ? 1
: ((!more && less) ? -1
: XSAVE_INTEGER (op, 0) - XSAVE_INTEGER (oq, 0)));
}
/* Sort VECTOR using PREDICATE, preserving original order of elements
considered as equal. */
static Lisp_Object
sort_vector (Lisp_Object vector, Lisp_Object predicate)
{
ptrdiff_t i;
EMACS_INT len = ASIZE (vector);
Lisp_Object *v = XVECTOR (vector)->contents;
if (len < 2)
return vector;
/* Record original index of each element to make qsort stable. */
for (i = 0; i < len; i++)
v[i] = make_save_int_obj (i, v[i]);
/* Setup predicate and sort. */
#ifdef HAVE_QSORT_R
qsort_r (v, len, word_size, sort_vector_compare, (void *) &predicate);
#else
sort_vector_predicate = predicate;
qsort (v, len, word_size, sort_vector_compare);
#endif /* HAVE_QSORT_R */
/* Discard indexes and restore original elements. */
for (i = 0; i < len; i++)
{
Lisp_Object save = v[i];
/* Use explicit free to offload GC. */
v[i] = XSAVE_OBJECT (save, 1);
free_misc (save);
}
return vector;
}
DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
doc: /* Sort SEQ, stably, comparing elements using PREDICATE.
Returns the sorted sequence. SEQ should be a list or vector.
If SEQ is a list, it is modified by side effects. PREDICATE
is called with two elements of SEQ, and should return non-nil
if the first element should sort before the second. */)
(Lisp_Object seq, Lisp_Object predicate)
{
if (CONSP (seq))
seq = sort_list (seq, predicate);
else if (VECTORP (seq))
seq = sort_vector (seq, predicate);
else if (!NILP (seq))
wrong_type_argument (Qarrayp, seq);
return seq;
}
Lisp_Object
merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred)
{

2
src/lisp.h
View File

@ -1989,6 +1989,7 @@ enum Lisp_Save_Type
SAVE_TYPE_OBJ_OBJ_OBJ_OBJ
= SAVE_OBJECT + (SAVE_TYPE_OBJ_OBJ_OBJ << SAVE_SLOT_BITS),
SAVE_TYPE_PTR_INT = SAVE_POINTER + (SAVE_INTEGER << SAVE_SLOT_BITS),
SAVE_TYPE_INT_OBJ = SAVE_INTEGER + (SAVE_OBJECT << SAVE_SLOT_BITS),
SAVE_TYPE_PTR_OBJ = SAVE_POINTER + (SAVE_OBJECT << SAVE_SLOT_BITS),
SAVE_TYPE_PTR_PTR = SAVE_POINTER + (SAVE_POINTER << SAVE_SLOT_BITS),
SAVE_TYPE_FUNCPTR_PTR_OBJ
@ -3773,6 +3774,7 @@ extern Lisp_Object make_save_obj_obj_obj_obj (Lisp_Object, Lisp_Object,
extern Lisp_Object make_save_ptr (void *);
extern Lisp_Object make_save_ptr_int (void *, ptrdiff_t);
extern Lisp_Object make_save_ptr_ptr (void *, void *);
extern Lisp_Object make_save_int_obj (ptrdiff_t, Lisp_Object);
extern Lisp_Object make_save_funcptr_ptr_obj (void (*) (void), void *,
Lisp_Object);
extern Lisp_Object make_save_memory (Lisp_Object *, ptrdiff_t);

4
test/ChangeLog
View File

@ -1,3 +1,7 @@
2014-08-29 Dmitry Antipov <dmantipov@yandex.ru>
* automated/fns-tests.el (fns-tests-sort): New test.
2014-08-28 Glenn Morris <rgm@gnu.org>
* automated/python-tests.el (python-shell-calculate-exec-path-2):

18
test/automated/fns-tests.el
View File

@ -100,3 +100,21 @@
(should (compare-strings "こんにちはｺﾝﾆﾁﾊ" nil nil "こんにちはｺﾝﾆﾁﾊ" nil nil))
(should (= (compare-strings "んにちはｺﾝﾆﾁﾊこ" nil nil "こんにちはｺﾝﾆﾁﾊ" nil nil) 1))
(should (= (compare-strings "こんにちはｺﾝﾆﾁﾊ" nil nil "んにちはｺﾝﾆﾁﾊこ" nil nil) -1)))
(ert-deftest fns-tests-sort ()
(should (equal (sort '(9 5 2 -1 5 3 8 7 4) (lambda (x y) (< x y)))
'(-1 2 3 4 5 5 7 8 9)))
(should (equal (sort '(9 5 2 -1 5 3 8 7 4) (lambda (x y) (> x y)))
'(9 8 7 5 5 4 3 2 -1)))
(should (equal (sort '[9 5 2 -1 5 3 8 7 4] (lambda (x y) (< x y)))
[-1 2 3 4 5 5 7 8 9]))
(should (equal (sort '[9 5 2 -1 5 3 8 7 4] (lambda (x y) (> x y)))
[9 8 7 5 5 4 3 2 -1]))
(should (equal
(sort
(vector
(cons 8 "xxx") (cons 9 "aaa") (cons 8 "bbb") (cons 9 "zzz")
(cons 9 "ppp") (cons 8 "ttt") (cons 8 "eee") (cons 9 "fff"))
(lambda (x y) (< (car x) (car y))))
[(8 . "xxx") (8 . "bbb") (8 . "ttt") (8 . "eee")
(9 . "aaa") (9 . "zzz") (9 . "ppp") (9 . "fff")])))