#include <time.h>
#include <intprops.h>
+#include <vla.h>
#include "lisp.h"
#include "commands.h"
static Lisp_Object Qmd5, Qsha1, Qsha224, Qsha256, Qsha384, Qsha512;
+static void sort_vector_copy (Lisp_Object, ptrdiff_t,
+ Lisp_Object [restrict], Lisp_Object [restrict]);
static bool internal_equal (Lisp_Object, Lisp_Object, int, bool, Lisp_Object);
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
This function obeys the conventions for collation order in your
locale settings. For example, punctuation and whitespace characters
-are considered less significant for sorting:
+might be considered less significant for sorting:
\(sort '\("11" "12" "1 1" "1 2" "1.1" "1.2") 'string-collate-lessp)
=> \("11" "1 1" "1.1" "12" "1 2" "1.2")
The optional argument LOCALE, a string, overrides the setting of your
current locale identifier for collation. The value is system
dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
-while it would be \"English_USA.1252\" on MS Windows systems.
+while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
If IGNORE-CASE is non-nil, characters are converted to lower-case
before comparing them.
+To emulate Unicode-compliant collation on MS-Windows systems,
+bind `w32-collate-ignore-punctuation' to a non-nil value, since
+the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
+
If your system does not support a locale environment, this function
behaves like `string-lessp'. */)
(Lisp_Object s1, Lisp_Object s2, Lisp_Object locale, Lisp_Object ignore_case)
This function obeys the conventions for collation order in your locale
settings. For example, characters with different coding points but
-the same meaning are considered as equal, like different grave accent
-unicode characters:
+the same meaning might be considered as equal, like different grave
+accent Unicode characters:
\(string-collate-equalp \(string ?\\uFF40) \(string ?\\u1FEF))
=> t
The optional argument LOCALE, a string, overrides the setting of your
current locale identifier for collation. The value is system
dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
-while it would be \"English_USA.1252\" on MS Windows systems.
+while it would be \"enu_USA.1252\" on MS Windows systems.
If IGNORE-CASE is non-nil, characters are converted to lower-case
before comparing them.
+To emulate Unicode-compliant collation on MS-Windows systems,
+bind `w32-collate-ignore-punctuation' to a non-nil value, since
+the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
+
If your system does not support a locale environment, this function
-behaves like `string-equal'. */)
+behaves like `string-equal'.
+
+Do NOT use this function to compare file names for equality, only
+for sorting them. */)
(Lisp_Object s1, Lisp_Object s2, Lisp_Object locale, Lisp_Object ignore_case)
{
#if defined __STDC_ISO_10646__ || defined WINDOWSNT
return merge (front, back, predicate);
}
-/* Using GNU qsort_r, we can pass this as a parameter. This also
- exists on FreeBSD and Darwin/OSX, but with a different signature. */
-#ifndef HAVE_QSORT_R
-static Lisp_Object sort_vector_predicate;
-#endif
+/* Using PRED to compare, return whether A and B are in order.
+ Compare stably when A appeared before B in the input. */
+static bool
+inorder (Lisp_Object pred, Lisp_Object a, Lisp_Object b)
+{
+ return NILP (call2 (pred, b, a));
+}
-/* Comparison function called by qsort. */
-
-static int
-#ifdef HAVE_QSORT_R
-#if defined (DARWIN_OS) || defined (__FreeBSD__)
-sort_vector_compare (void *arg, const void *p, const void *q)
-#elif defined (GNU_LINUX)
-sort_vector_compare (const void *p, const void *q, void *arg)
-#else /* neither darwin/bsd nor gnu/linux */
-#error "check how qsort_r comparison function works on your platform"
-#endif /* DARWIN_OS || __FreeBSD__ */
-#else /* not HAVE_QSORT_R */
-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
+/* Using PRED to compare, merge from ALEN-length A and BLEN-length B
+ into DEST. Argument arrays must be nonempty and must not overlap,
+ except that B might be the last part of DEST. */
+static void
+merge_vectors (Lisp_Object pred,
+ ptrdiff_t alen, Lisp_Object const a[restrict VLA_ELEMS (alen)],
+ ptrdiff_t blen, Lisp_Object const b[VLA_ELEMS (blen)],
+ Lisp_Object dest[VLA_ELEMS (alen + blen)])
+{
+ eassume (0 < alen && 0 < blen);
+ Lisp_Object const *alim = a + alen;
+ Lisp_Object const *blim = b + blen;
- op = *(Lisp_Object *) p;
- oq = *(Lisp_Object *) q;
- vp = XSAVE_OBJECT (op, 1);
- vq = XSAVE_OBJECT (oq, 1);
+ while (true)
+ {
+ if (inorder (pred, a[0], b[0]))
+ {
+ *dest++ = *a++;
+ if (a == alim)
+ {
+ if (dest != b)
+ memcpy (dest, b, (blim - b) * sizeof *dest);
+ return;
+ }
+ }
+ else
+ {
+ *dest++ = *b++;
+ if (b == blim)
+ {
+ memcpy (dest, a, (alim - a) * sizeof *dest);
+ return;
+ }
+ }
+ }
+}
- /* 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)));
+/* Using PRED to compare, sort LEN-length VEC in place, using TMP for
+ temporary storage. LEN must be at least 2. */
+static void
+sort_vector_inplace (Lisp_Object pred, ptrdiff_t len,
+ Lisp_Object vec[restrict VLA_ELEMS (len)],
+ Lisp_Object tmp[restrict VLA_ELEMS (len >> 1)])
+{
+ eassume (2 <= len);
+ ptrdiff_t halflen = len >> 1;
+ sort_vector_copy (pred, halflen, vec, tmp);
+ if (1 < len - halflen)
+ sort_vector_inplace (pred, len - halflen, vec + halflen, vec);
+ merge_vectors (pred, halflen, tmp, len - halflen, vec + halflen, vec);
}
-/* Sort VECTOR using PREDICATE, preserving original order of elements
- considered as equal. */
+/* Using PRED to compare, sort from LEN-length SRC into DST.
+ Len must be positive. */
+static void
+sort_vector_copy (Lisp_Object pred, ptrdiff_t len,
+ Lisp_Object src[restrict VLA_ELEMS (len)],
+ Lisp_Object dest[restrict VLA_ELEMS (len)])
+{
+ eassume (0 < len);
+ ptrdiff_t halflen = len >> 1;
+ if (halflen < 1)
+ dest[0] = src[0];
+ else
+ {
+ if (1 < halflen)
+ sort_vector_inplace (pred, halflen, src, dest);
+ if (1 < len - halflen)
+ sort_vector_inplace (pred, len - halflen, src + halflen, dest);
+ merge_vectors (pred, halflen, src, len - halflen, src + halflen, dest);
+ }
+}
-static Lisp_Object
+/* Sort VECTOR in place using PREDICATE, preserving original order of
+ elements considered as equal. */
+
+static void
sort_vector (Lisp_Object vector, Lisp_Object predicate)
{
- ptrdiff_t i;
- EMACS_INT len = ASIZE (vector);
- Lisp_Object *v = XVECTOR (vector)->contents;
-
+ ptrdiff_t len = ASIZE (vector);
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
-#if defined (DARWIN_OS) || defined (__FreeBSD__)
- qsort_r (v, len, word_size, (void *) &predicate, sort_vector_compare);
-#elif defined (GNU_LINUX)
- qsort_r (v, len, word_size, sort_vector_compare, (void *) &predicate);
-#else /* neither darwin/bsd nor gnu/linux */
-#error "check how qsort_r works on your platform"
-#endif /* DARWIN_OS || __FreeBSD__ */
-#else /* not HAVE_QSORT_R */
- 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++)
+ return;
+ ptrdiff_t halflen = len >> 1;
+ Lisp_Object *tmp;
+ Lisp_Object tmpvec = Qnil;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+ GCPRO3 (vector, predicate, tmpvec);
+ if (halflen < MAX_ALLOCA / word_size)
+ tmp = alloca (halflen * word_size);
+ else
{
- Lisp_Object save = v[i];
- /* Use explicit free to offload GC. */
- v[i] = XSAVE_OBJECT (save, 1);
- free_misc (save);
+ tmpvec = Fmake_vector (make_number (halflen), make_number (0));
+ tmp = XVECTOR (tmpvec)->contents;
}
- return vector;
+ sort_vector_inplace (predicate, len, XVECTOR (vector)->contents, tmp);
+ UNGCPRO;
}
DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
if (CONSP (seq))
seq = sort_list (seq, predicate);
else if (VECTORP (seq))
- seq = sort_vector (seq, predicate);
+ sort_vector (seq, predicate);
else if (!NILP (seq))
wrong_type_argument (Qsequencep, seq);
return seq;
Fsetcdr (tail, l1);
return value;
}
- tem = call2 (pred, Fcar (l2), Fcar (l1));
- if (NILP (tem))
+ if (inorder (pred, Fcar (l1), Fcar (l2)))
{
tem = l1;
l1 = Fcdr (l1);