Add vectors support to Fsort.

* 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.

diff --git a/ChangeLog b/ChangeLog
index 07fd290f4e01d682d6b6eab1b09dc6e3b69712ff..a998e4d205420e3c629b67d9d6d2bf8b8ee3c308 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -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

diff --git a/configure.ac b/configure.ac
index 4f17a55895e78d8fc98b7e422241aee97bf68796..ef3aad217321f89e56ca634820f144d62f86a474 100644 (file)
--- 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 9b3c3d0bd664ed2272090f9fdb60dc10e8c60a14..c24ca69536fca3cc901c9922adb393fea2fedb66 100644 (file)
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -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

diff --git a/src/alloc.c b/src/alloc.c
index 9c81ae2eedfac21e941e0b8a2ee078987536de2f..bb47a24d905855c62e115d5308d7d069c0e2e57b 100644 (file)
--- 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 2e2acf84b95f412e1cb085f119b573d6aebd6ee4..8845a43fc4b460a2ce295ed8c8ce6c175c0b2c5e 100644 (file)
--- 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;
 }
-\f
-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 98734a55812f475582b830ce859f5a96f736dbdd..7cbbb2998964d27fdab8a0b55f73914d0b3760da 100644 (file)
--- 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 7546dd1fb4677fa615b2a1a9d6618a9052dec30f..70c2af66194f9867d7f82e8730b8d78ccb4d6276 100644 (file)
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -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):

diff --git a/test/automated/fns-tests.el b/test/automated/fns-tests.el
index d3d921f425f9188c4bdbef3c863710d2bc244481..a6c45443db6201c1e91ecca9711a951ec5d50946 100644 (file)
--- 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")])))