Have 'make' output better GEN names

[gnu-emacs] / src / fns.c

diff --git a/src/fns.c b/src/fns.c
index a454341fce692bb79d7ad3ddf026dd81be7954df..7739663b775492c0fcabf5a594811d87f3dca8b8 100644 (file)
--- a/src/fns.c
+++ b/src/fns.c
@@ -1,6 +1,6 @@
 /* Random utility Lisp functions.
 
 /* Random utility Lisp functions.
 

-Copyright (C) 1985-1987, 1993-1995, 1997-2014 Free Software Foundation,
+Copyright (C) 1985-1987, 1993-1995, 1997-2015 Free Software Foundation,

 Inc.
 
 This file is part of GNU Emacs.
 Inc.
 
 This file is part of GNU Emacs.


@@ -24,6 +24,7 @@ along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
 #include <time.h>
 
 #include <intprops.h>
 #include <time.h>
 
 #include <intprops.h>

+#include <vla.h>

 
 #include "lisp.h"
 #include "commands.h"
 
 #include "lisp.h"
 #include "commands.h"


@@ -40,15 +41,8 @@ along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
 #include "xterm.h"
 #endif
 
 #include "xterm.h"
 #endif
 

-Lisp_Object Qstring_lessp, Qstring_collate_lessp, Qstring_collate_equalp;
-static Lisp_Object Qprovide, Qrequire;
-static Lisp_Object Qyes_or_no_p_history;
-Lisp_Object Qcursor_in_echo_area;
-static Lisp_Object Qwidget_type;
-static Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
-
-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,
 static bool internal_equal (Lisp_Object, Lisp_Object, int, bool, Lisp_Object);
 
 DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,


@@ -344,25 +338,32 @@ Symbols are also allowed; their print names are used instead.  */)
   return i1 < SCHARS (s2) ? Qt : Qnil;
 }
 
   return i1 < SCHARS (s2) ? Qt : Qnil;
 }
 

-DEFUN ("string-collate-lessp", Fstring_collate_lessp, Sstring_collate_lessp, 2, 2, 0,
+DEFUN ("string-collate-lessp", Fstring_collate_lessp, Sstring_collate_lessp, 2, 4, 0,

        doc: /* Return t if first arg string is less than second in collation order.
        doc: /* Return t if first arg string is less than second in collation order.

-
-Case is significant.  Symbols are also allowed; their print names are
-used instead.
+Symbols are also allowed; their print names are used instead.

 
 This function obeys the conventions for collation order in your
 locale settings.  For example, punctuation and whitespace characters
 
 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")
 
 
 \(sort '\("11" "12" "1 1" "1 2" "1.1" "1.2") 'string-collate-lessp)
   => \("11" "1 1" "1.1" "12" "1 2" "1.2")
 

-If your system does not support a locale environment, this function
-behaves like `string-lessp'.
+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, e.g., \"enu_USA.1252\" on MS-Windows systems.
+
+If IGNORE-CASE is non-nil, characters are converted to lower-case
+before comparing them.

 
 

-If the environment variable \"LC_COLLATE\" is set in `process-environment',
-it overrides the setting of your current locale.  */)
-  (Lisp_Object s1, Lisp_Object s2)
+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)

 {
 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
   /* Check parameters.  */
 {
 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
   /* Check parameters.  */


@@ -372,34 +373,46 @@ it overrides the setting of your current locale.  */)
     s2 = SYMBOL_NAME (s2);
   CHECK_STRING (s1);
   CHECK_STRING (s2);
     s2 = SYMBOL_NAME (s2);
   CHECK_STRING (s1);
   CHECK_STRING (s2);

+  if (!NILP (locale))
+    CHECK_STRING (locale);

 
 

-  return (str_collate (s1, s2) < 0) ? Qt : Qnil;
+  return (str_collate (s1, s2, locale, ignore_case) < 0) ? Qt : Qnil;

 
 #else  /* !__STDC_ISO_10646__, !WINDOWSNT */
   return Fstring_lessp (s1, s2);
 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
 }
 
 
 #else  /* !__STDC_ISO_10646__, !WINDOWSNT */
   return Fstring_lessp (s1, s2);
 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
 }
 

-DEFUN ("string-collate-equalp", Fstring_collate_equalp, Sstring_collate_equalp, 2, 2, 0,
+DEFUN ("string-collate-equalp", Fstring_collate_equalp, Sstring_collate_equalp, 2, 4, 0,

        doc: /* Return t if two strings have identical contents.
        doc: /* Return t if two strings have identical contents.

-
-Case is significant.  Symbols are also allowed; their print names are
-used instead.
+Symbols are also allowed; their print names are used instead.

 
 This function obeys the conventions for collation order in your locale
 settings.  For example, characters with different coding points but
 
 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
 
 
 \(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 \"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'.
 
 If your system does not support a locale environment, this function
 behaves like `string-equal'.
 

-If the environment variable \"LC_COLLATE\" is set in `process-environment',
-it overrides the setting of your current locale.  */)
-  (Lisp_Object s1, Lisp_Object s2)
+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
   /* Check parameters.  */
 {
 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
   /* Check parameters.  */


@@ -409,8 +422,10 @@ it overrides the setting of your current locale.  */)
     s2 = SYMBOL_NAME (s2);
   CHECK_STRING (s1);
   CHECK_STRING (s2);
     s2 = SYMBOL_NAME (s2);
   CHECK_STRING (s1);
   CHECK_STRING (s2);

+  if (!NILP (locale))
+    CHECK_STRING (locale);

 
 

-  return (str_collate (s1, s2) == 0) ? Qt : Qnil;
+  return (str_collate (s1, s2, locale, ignore_case) == 0) ? Qt : Qnil;

 
 #else  /* !__STDC_ISO_10646__, !WINDOWSNT */
   return Fstring_equal (s1, s2);
 
 #else  /* !__STDC_ISO_10646__, !WINDOWSNT */
   return Fstring_equal (s1, s2);


@@ -1876,87 +1891,121 @@ sort_list (Lisp_Object list, Lisp_Object predicate)
   return merge (front, back, predicate);
 }
 
   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.  */
+/* 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));
+}

 
 

-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 */  
+/* 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)])

 {
 {

-  bool more, less;
-  Lisp_Object op, oq, vp, vq;
-#ifdef HAVE_QSORT_R
-  Lisp_Object sort_vector_predicate = *(Lisp_Object *) arg;
-#endif  
+  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)
 {
 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)
   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;
+    return;
+  ptrdiff_t halflen = len >> 1;
+  Lisp_Object *tmp;
+  struct gcpro gcpro1, gcpro2;
+  GCPRO2 (vector, predicate);
+  USE_SAFE_ALLOCA;
+  SAFE_ALLOCA_LISP (tmp, halflen);
+  for (ptrdiff_t i = 0; i < halflen; i++)
+    tmp[i] = make_number (0);
+  sort_vector_inplace (predicate, len, XVECTOR (vector)->contents, tmp);
+  SAFE_FREE ();
+  UNGCPRO;

 }
 
 DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
        doc: /* Sort SEQ, stably, comparing elements using PREDICATE.
 }
 
 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.  */)
+Returns the sorted sequence.  SEQ should be a list or vector.  SEQ 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))
   (Lisp_Object seq, Lisp_Object predicate)
 {
   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;
   else if (!NILP (seq))
     wrong_type_argument (Qsequencep, seq);
   return seq;


@@ -1999,8 +2048,7 @@ merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred)
          Fsetcdr (tail, l1);
          return value;
        }
          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);
        {
          tem = l1;
          l1 = Fcdr (l1);


@@ -2648,8 +2696,7 @@ If dialog boxes are supported, a dialog box will be used
 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil.  */)
   (Lisp_Object prompt)
 {
 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil.  */)
   (Lisp_Object prompt)
 {

-  register Lisp_Object ans;
-  Lisp_Object args[2];
+  Lisp_Object ans;

   struct gcpro gcpro1;
 
   CHECK_STRING (prompt);
   struct gcpro gcpro1;
 
   CHECK_STRING (prompt);


@@ -2668,10 +2715,8 @@ if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil.  */)
       return obj;
     }
 
       return obj;
     }
 

-  args[0] = prompt;
-  args[1] = build_string ("(yes or no) ");
-  prompt = Fconcat (2, args);
-
+  AUTO_STRING (yes_or_no, "(yes or no) ");
+  prompt = Fconcat (2, (Lisp_Object []) {prompt, yes_or_no});

   GCPRO1 (prompt);
 
   while (1)
   GCPRO1 (prompt);
 
   while (1)


@@ -2733,8 +2778,6 @@ advisable.  */)
   return ret;
 }
 \f
   return ret;
 }
 \f

-static Lisp_Object Qsubfeatures;
-

 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 2, 0,
        doc: /* Return t if FEATURE is present in this Emacs.
 
 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 2, 0,
        doc: /* Return t if FEATURE is present in this Emacs.
 


@@ -2753,8 +2796,6 @@ SUBFEATURE can be used to check a specific subfeature of FEATURE.  */)
   return (NILP (tem)) ? Qnil : Qt;
 }
 
   return (NILP (tem)) ? Qnil : Qt;
 }
 

-static Lisp_Object Qfuncall;
-

 DEFUN ("provide", Fprovide, Sprovide, 1, 2, 0,
        doc: /* Announce that FEATURE is a feature of the current Emacs.
 The optional argument SUBFEATURES should be a list of symbols listing
 DEFUN ("provide", Fprovide, Sprovide, 1, 2, 0,
        doc: /* Announce that FEATURE is a feature of the current Emacs.
 The optional argument SUBFEATURES should be a list of symbols listing


@@ -3229,7 +3270,6 @@ into shorter lines.  */)
   if (encoded_length < 0)
     {
       /* The encoding wasn't possible. */
   if (encoded_length < 0)
     {
       /* The encoding wasn't possible. */

-      SAFE_FREE ();

       error ("Multibyte character in data for base64 encoding");
     }
 
       error ("Multibyte character in data for base64 encoding");
     }
 


@@ -3374,7 +3414,6 @@ If the region can't be decoded, signal an error and don't modify the buffer.  */
   if (decoded_length < 0)
     {
       /* The decoding wasn't possible. */
   if (decoded_length < 0)
     {
       /* The decoding wasn't possible. */

-      SAFE_FREE ();

       error ("Invalid base64 data");
     }
 
       error ("Invalid base64 data");
     }
 


@@ -3543,14 +3582,6 @@ base64_decode_1 (const char *from, char *to, ptrdiff_t length,
 
 static struct Lisp_Hash_Table *weak_hash_tables;
 
 
 static struct Lisp_Hash_Table *weak_hash_tables;
 

-/* Various symbols.  */
-
-static Lisp_Object Qhash_table_p;
-static Lisp_Object Qkey, Qvalue, Qeql;
-Lisp_Object Qeq, Qequal;
-Lisp_Object QCtest, QCsize, QCrehash_size, QCrehash_threshold, QCweakness;
-static Lisp_Object Qhash_table_test, Qkey_or_value, Qkey_and_value;
-

 \f
 /***********************************************************************
                               Utilities
 \f
 /***********************************************************************
                               Utilities


@@ -3942,12 +3973,9 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h)
 #ifdef ENABLE_CHECKING
       if (HASH_TABLE_P (Vpurify_flag)
          && XHASH_TABLE (Vpurify_flag) == h)
 #ifdef ENABLE_CHECKING
       if (HASH_TABLE_P (Vpurify_flag)
          && XHASH_TABLE (Vpurify_flag) == h)

-       {
-         Lisp_Object args[2];
-         args[0] = build_string ("Growing hash table to: %d");
-         args[1] = make_number (new_size);
-         Fmessage (2, args);
-       }
+       Fmessage (2, ((Lisp_Object [])
+         { build_string ("Growing hash table to: %d"),
+           make_number (new_size) }));

 #endif
 
       set_hash_key_and_value (h, larger_vector (h->key_and_value,
 #endif
 
       set_hash_key_and_value (h, larger_vector (h->key_and_value,


@@ -4427,13 +4455,10 @@ sxhash (Lisp_Object obj, int depth)
       break;
 
     case Lisp_Misc:
       break;
 
     case Lisp_Misc:

+    case Lisp_Symbol:

       hash = XHASH (obj);
       break;
 
       hash = XHASH (obj);
       break;
 

-    case Lisp_Symbol:
-      obj = SYMBOL_NAME (obj);
-      /* Fall through.  */
-

     case Lisp_String:
       hash = sxhash_string (SSDATA (obj), SBYTES (obj));
       break;
     case Lisp_String:
       hash = sxhash_string (SSDATA (obj), SBYTES (obj));
       break;


@@ -4521,12 +4546,12 @@ usage: (make-hash-table &rest KEYWORD-ARGS)  */)
 {
   Lisp_Object test, size, rehash_size, rehash_threshold, weak;
   struct hash_table_test testdesc;
 {
   Lisp_Object test, size, rehash_size, rehash_threshold, weak;
   struct hash_table_test testdesc;

-  char *used;

   ptrdiff_t i;
   ptrdiff_t i;

+  USE_SAFE_ALLOCA;

 
   /* The vector `used' is used to keep track of arguments that
      have been consumed.  */
 
   /* The vector `used' is used to keep track of arguments that
      have been consumed.  */

-  used = alloca (nargs * sizeof *used);
+  char *used = SAFE_ALLOCA (nargs * sizeof *used);

   memset (used, 0, nargs * sizeof *used);
 
   /* See if there's a `:test TEST' among the arguments.  */
   memset (used, 0, nargs * sizeof *used);
 
   /* See if there's a `:test TEST' among the arguments.  */


@@ -4593,6 +4618,7 @@ usage: (make-hash-table &rest KEYWORD-ARGS)  */)
     if (!used[i])
       signal_error ("Invalid argument list", args[i]);
 
     if (!used[i])
       signal_error ("Invalid argument list", args[i]);
 

+  SAFE_FREE ();

   return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak);
 }
 
   return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak);
 }