diff --git a/ChangeLog b/ChangeLog index 07fd290f4e0..a998e4d2054 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2014-08-29 Dmitry Antipov + + * configure.ac (AC_CHECK_FUNCS): Check for qsort_r. + 2014-08-28 Ken Brown * configure.ac (HYBRID_MALLOC): New macro; define to use gmalloc diff --git a/configure.ac b/configure.ac index 4f17a55895e..ef3aad21732 100644 --- a/configure.ac +++ b/configure.ac @@ -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 diff --git a/src/ChangeLog b/src/ChangeLog index 9b3c3d0bd66..c24ca69536f 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,14 @@ +2014-08-29 Dmitry Antipov + + 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 Add support for HYBRID_MALLOC, allowing the use of gmalloc before diff --git a/src/alloc.c b/src/alloc.c index 9c81ae2eedf..bb47a24d905 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -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) diff --git a/src/fns.c b/src/fns.c index 2e2acf84b95..8845a43fc4b 100644 --- a/src/fns.c +++ b/src/fns.c @@ -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) { diff --git a/src/lisp.h b/src/lisp.h index 98734a55812..7cbbb299896 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -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); diff --git a/test/ChangeLog b/test/ChangeLog index 7546dd1fb46..70c2af66194 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,7 @@ +2014-08-29 Dmitry Antipov + + * automated/fns-tests.el (fns-tests-sort): New test. + 2014-08-28 Glenn Morris * automated/python-tests.el (python-shell-calculate-exec-path-2): diff --git a/test/automated/fns-tests.el b/test/automated/fns-tests.el index d3d921f425f..a6c45443db6 100644 --- a/test/automated/fns-tests.el +++ b/test/automated/fns-tests.el @@ -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")])))