Support const and noreturn DEFUN attributes.

* lib-src/make-docfile.c (struct global): New field 'flags'.
(DEFUN_noreturn, DEFUN_const): New enum bitfields.
(add_global): Now return pointer to global.
(write_globals): Add _Noreturn and ATTRIBUTE_CONST attributes
if requested by global's flags.
(stream_match): New function.
(scan_c_stream): Recognize 'attributes:' of DEFUN.

* src/callint.c (Finteractive):
* src/character.c (Fcharacterp, Fmax_char):
* src.data.c (Feq, Fnull, Fconsp, Fatom, Flistp, Fnlistp, Fsymbolp)
(Fstringp, Fchar_or_string_p, Fintegerp, Fnatnump, Fnumberp)
(Ffloatp, Fbyteorder):
* src/decompress.c (Fzlib_available_p):
* src/fns.c (Fidentity):
* src/frame.c (Fframe_windows_min_size):
* src/gnutls.c (Fgnutls_error_p, Fgnutls_available_p):
* src/window.c (Fwindow__sanitize_window_sizes):
* src/xdisp.c (Ftool_bar_height):
* src/xfaces.c (Fface_attribute_relative_p): Add const attribute.
* src/emacs.c (Fkill_emacs):
* src/eval.c (Fthrow):
* src/keyboard.c (Ftop_level, Fexit_recursive_edit)
(Fabor_recursive_edit): Add noreturn attribute.

lib-src/ChangeLog

@@ -1,3 +1,14 @@
+2015-01-13  Dmitry Antipov  <dmantipov@yandex.ru>
+
+	Support DEFUN attributes.
+	* make-docfile.c (struct global): New field 'flags'.
+	(DEFUN_noreturn, DEFUN_const): New enum bitfields.
+	(add_global): Now return pointer to global.
+	(write_globals): Add _Noreturn and ATTRIBUTE_CONST attributes
+	if requested by global's flags.
+	(stream_match): New function.
+	(scan_c_stream): Recognize 'attributes:' of DEFUN.
+
 2015-01-10  Paul Eggert  <eggert@cs.ucla.edu>
 
 	Port to 32-bit --with-wide-int

lib-src/make-docfile.c

@@ -562,6 +562,7 @@ struct global
 {
   enum global_type type;
   char *name;
+  int flags;
   union
   {
     int value;
@@ -569,13 +570,16 @@ struct global
   } v;
 };
 
+/* Bit values for FLAGS field from the above.  Applied for DEFUNs only.  */
+enum { DEFUN_noreturn = 1, DEFUN_const = 2 };
+
 /* All the variable names we saw while scanning C sources in `-g'
    mode.  */
 int num_globals;
 int num_globals_allocated;
 struct global *globals;
 
-static void
+static struct global *
 add_global (enum global_type type, char *name, int value, char const *svalue)
 {
   /* Ignore the one non-symbol that can occur.  */
@@ -601,7 +605,10 @@ add_global (enum global_type type, char *name, int value, char const *svalue)
 	globals[num_globals - 1].v.svalue = svalue;
       else
 	globals[num_globals - 1].v.value = value;
+      globals[num_globals - 1].flags = 0;
+      return globals + num_globals - 1;
     }
+  return NULL;
 }
 
 static int
@@ -708,13 +715,7 @@ write_globals (void)
 		globals[i].name, globals[i].name, globals[i].name);
       else
 	{
-	  /* It would be nice to have a cleaner way to deal with these
+	  if (globals[i].flags & DEFUN_noreturn)
-	     special hacks.  */
-	  if (strcmp (globals[i].name, "Fthrow") == 0
-	      || strcmp (globals[i].name, "Ftop_level") == 0
-	      || strcmp (globals[i].name, "Fkill_emacs") == 0
-	      || strcmp (globals[i].name, "Fexit_recursive_edit") == 0
-	      || strcmp (globals[i].name, "Fabort_recursive_edit") == 0)
 	    fputs ("_Noreturn ", stdout);
 
 	  printf ("EXFUN (%s, ", globals[i].name);
@@ -726,36 +727,7 @@ write_globals (void)
 	    printf ("%d", globals[i].v.value);
 	  putchar (')');
 
-	  /* It would be nice to have a cleaner way to deal with these
+	  if (globals[i].flags & DEFUN_const)
-	     special hacks, too.  */
-	  if (strcmp (globals[i].name, "Fatom") == 0
-	      || strcmp (globals[i].name, "Fbyteorder") == 0
-	      || strcmp (globals[i].name, "Fcharacterp") == 0
-	      || strcmp (globals[i].name, "Fchar_or_string_p") == 0
-	      || strcmp (globals[i].name, "Fconsp") == 0
-	      || strcmp (globals[i].name, "Feq") == 0
-	      || strcmp (globals[i].name, "Fface_attribute_relative_p") == 0
-	      || strcmp (globals[i].name, "Fframe_windows_min_size") == 0
-	      || strcmp (globals[i].name, "Fgnutls_errorp") == 0
-	      || strcmp (globals[i].name, "Fidentity") == 0
-	      || strcmp (globals[i].name, "Fintegerp") == 0
-	      || strcmp (globals[i].name, "Finteractive") == 0
-	      || strcmp (globals[i].name, "Ffloatp") == 0
-	      || strcmp (globals[i].name, "Flistp") == 0
-	      || strcmp (globals[i].name, "Fmax_char") == 0
-	      || strcmp (globals[i].name, "Fnatnump") == 0
-	      || strcmp (globals[i].name, "Fnlistp") == 0
-	      || strcmp (globals[i].name, "Fnull") == 0
-	      || strcmp (globals[i].name, "Fnumberp") == 0
-	      || strcmp (globals[i].name, "Fstringp") == 0
-	      || strcmp (globals[i].name, "Fsymbolp") == 0
-	      || strcmp (globals[i].name, "Ftool_bar_height") == 0
-	      || strcmp (globals[i].name, "Fwindow__sanitize_window_sizes") == 0
-#ifndef WINDOWSNT
-	      || strcmp (globals[i].name, "Fgnutls_available_p") == 0
-	      || strcmp (globals[i].name, "Fzlib_available_p") == 0
-#endif
-	      || 0)
 	    fputs (" ATTRIBUTE_CONST", stdout);
 
 	  puts (";");
@@ -817,6 +789,23 @@ scan_c_file (char *filename, const char *mode)
   return scan_c_stream (infile);
 }
 
+/* Return 1 if next input from INFILE is equal to P, -1 if EOF,
+   0 if input doesn't match.  */
+
+static int
+stream_match (FILE *infile, const char *p)
+{
+  for (; *p; p++)
+    {
+      int c = getc (infile);
+      if (c == EOF)
+       return -1;
+      if (c != *p)
+       return 0;
+    }
+  return 1;
+}
+
 static int
 scan_c_stream (FILE *infile)
 {
@@ -1033,7 +1022,63 @@ scan_c_stream (FILE *infile)
 
       if (generate_globals)
 	{
-	  add_global (FUNCTION, name, maxargs, 0);
+	  struct global *g = add_global (FUNCTION, name, maxargs, 0);
+
+	  /* The following code tries to recognize function attributes
+	     specified after the docstring, e.g.:
+
+	     DEFUN ("foo", Ffoo, Sfoo, X, Y, Z,
+		   doc: /\* doc *\/
+		   attributes: attribute1 attribute2 ...)
+	       (Lisp_Object arg...)
+
+	     Now only 'noreturn' and 'const' attributes are used.  */
+
+	  /* Advance to the end of docstring.  */
+	  c = getc (infile);
+	  if (c == EOF)
+	    goto eof;
+	  int d = getc (infile);
+	  if (d == EOF)
+	    goto eof;
+	  while (1)
+	    {
+	      if (c == '*' && d == '/')
+		break;
+	      c = d, d = getc (infile);
+	      if (d == EOF)
+		goto eof;
+	    }
+	  /* Skip spaces, if any.  */
+	  do
+	    {
+	      c = getc (infile);
+	      if (c == EOF)
+		goto eof;
+	    }
+	  while (c == ' ' || c == '\n' || c == '\r' || c == '\t');
+	  /* Check for 'attributes:' token.  */
+	  if (c == 'a' && stream_match (infile, "ttributes:"))
+	    {
+	      char *p = input_buffer;
+	      /* Collect attributes up to ')'.  */
+	      while (1)
+		{
+		  c = getc (infile);
+		  if (c == EOF)
+		    goto eof;
+		  if (c == ')')
+		    break;
+		  if (p - input_buffer > sizeof (input_buffer))
+		    abort ();
+		  *p++ = c;
+		}
+	      *p = 0;
+	      if (strstr (input_buffer, "noreturn"))
+		g->flags |= DEFUN_noreturn;
+	      if (strstr (input_buffer, "const"))
+		g->flags |= DEFUN_const;
+	    }
 	  continue;
 	}
 

src/ChangeLog

@@ -1,3 +1,23 @@
+2015-01-13  Dmitry Antipov  <dmantipov@yandex.ru>
+
+	Add DEFUN attributes.
+	* callint.c (Finteractive):
+	* character.c (Fcharacterp, Fmax_char):
+	* data.c (Feq, Fnull, Fconsp, Fatom, Flistp, Fnlistp, Fsymbolp)
+	(Fstringp, Fchar_or_string_p, Fintegerp, Fnatnump, Fnumberp)
+	(Ffloatp, Fbyteorder):
+	* decompress.c (Fzlib_available_p):
+	* fns.c (Fidentity):
+	* frame.c (Fframe_windows_min_size):
+	* gnutls.c (Fgnutls_error_p, Fgnutls_available_p):
+	* window.c (Fwindow__sanitize_window_sizes):
+	* xdisp.c (Ftool_bar_height):
+	* xfaces.c (Fface_attribute_relative_p): Add const attribute.
+	* emacs.c (Fkill_emacs):
+	* eval.c (Fthrow):
+	* keyboard.c (Ftop_level, Fexit_recursive_edit)
+	(Fabor_recursive_edit): Add noreturn attribute.
+
 2015-01-12  Paul Eggert  <eggert@cs.ucla.edu>
 
 	Port to 32-bit MingGW --with-wide-int

src/callint.c

@@ -101,7 +101,8 @@ If the string begins with `^' and `shift-select-mode' is non-nil,
  Emacs first calls the function `handle-shift-selection'.
 You may use `@', `*', and `^' together.  They are processed in the
  order that they appear, before reading any arguments.
-usage: (interactive &optional ARGS)  */)
+usage: (interactive &optional ARGS)  */
+       attributes: const)
   (Lisp_Object args)
 {
   return Qnil;

src/character.c

@@ -232,14 +232,16 @@ DEFUN ("characterp", Fcharacterp, Scharacterp, 1, 2, 0,
 In Emacs Lisp, characters are represented by character codes, which
 are non-negative integers.  The function `max-char' returns the
 maximum character code.
-usage: (characterp OBJECT)  */)
+usage: (characterp OBJECT)  */
+       attributes: const)
   (Lisp_Object object, Lisp_Object ignore)
 {
   return (CHARACTERP (object) ? Qt : Qnil);
 }
 
 DEFUN ("max-char", Fmax_char, Smax_char, 0, 0, 0,
-       doc: /* Return the character of the maximum code.  */)
+       doc: /* Return the character of the maximum code.  */
+       attributes: const)
   (void)
 {
   return make_number (MAX_CHAR);

src/data.c

@@ -176,7 +176,8 @@ args_out_of_range_3 (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
 /* Data type predicates.  */
 
 DEFUN ("eq", Feq, Seq, 2, 2, 0,
-       doc: /* Return t if the two args are the same Lisp object.  */)
+       doc: /* Return t if the two args are the same Lisp object.  */
+       attributes: const)
   (Lisp_Object obj1, Lisp_Object obj2)
 {
   if (EQ (obj1, obj2))
@@ -185,7 +186,8 @@ DEFUN ("eq", Feq, Seq, 2, 2, 0,
 }
 
 DEFUN ("null", Fnull, Snull, 1, 1, 0,
-       doc: /* Return t if OBJECT is nil.  */)
+       doc: /* Return t if OBJECT is nil.  */
+       attributes: const)
   (Lisp_Object object)
 {
   if (NILP (object))
@@ -263,7 +265,8 @@ for example, (type-of 1) returns `integer'.  */)
 }
 
 DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0,
-       doc: /* Return t if OBJECT is a cons cell.  */)
+       doc: /* Return t if OBJECT is a cons cell.  */
+       attributes: const)
   (Lisp_Object object)
 {
   if (CONSP (object))
@@ -272,7 +275,8 @@ DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0,
 }
 
 DEFUN ("atom", Fatom, Satom, 1, 1, 0,
-       doc: /* Return t if OBJECT is not a cons cell.  This includes nil.  */)
+       doc: /* Return t if OBJECT is not a cons cell.  This includes nil.  */
+       attributes: const)
   (Lisp_Object object)
 {
   if (CONSP (object))
@@ -282,7 +286,8 @@ DEFUN ("atom", Fatom, Satom, 1, 1, 0,
 
 DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
        doc: /* Return t if OBJECT is a list, that is, a cons cell or nil.
-Otherwise, return nil.  */)
+Otherwise, return nil.  */
+       attributes: const)
   (Lisp_Object object)
 {
   if (CONSP (object) || NILP (object))
@@ -291,7 +296,8 @@ Otherwise, return nil.  */)
 }
 
 DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
-       doc: /* Return t if OBJECT is not a list.  Lists include nil.  */)
+       doc: /* Return t if OBJECT is not a list.  Lists include nil.  */
+       attributes: const)
   (Lisp_Object object)
 {
   if (CONSP (object) || NILP (object))
@@ -300,7 +306,8 @@ DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
 }
 
 DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
-       doc: /* Return t if OBJECT is a symbol.  */)
+       doc: /* Return t if OBJECT is a symbol.  */
+       attributes: const)
   (Lisp_Object object)
 {
   if (SYMBOLP (object))
@@ -333,7 +340,8 @@ DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
 }
 
 DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
-       doc: /* Return t if OBJECT is a string.  */)
+       doc: /* Return t if OBJECT is a string.  */
+       attributes: const)
   (Lisp_Object object)
 {
   if (STRINGP (object))
@@ -436,7 +444,8 @@ DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
 }
 
 DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
-       doc: /* Return t if OBJECT is a character or a string.  */)
+       doc: /* Return t if OBJECT is a character or a string.  */
+       attributes: const)
   (register Lisp_Object object)
 {
   if (CHARACTERP (object) || STRINGP (object))
@@ -445,7 +454,8 @@ DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
 }
 
 DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0,
-       doc: /* Return t if OBJECT is an integer.  */)
+       doc: /* Return t if OBJECT is an integer.  */
+       attributes: const)
   (Lisp_Object object)
 {
   if (INTEGERP (object))
@@ -463,7 +473,8 @@ DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1,
 }
 
 DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
-       doc: /* Return t if OBJECT is a nonnegative integer.  */)
+       doc: /* Return t if OBJECT is a nonnegative integer.  */
+       attributes: const)
   (Lisp_Object object)
 {
   if (NATNUMP (object))
@@ -472,7 +483,8 @@ DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
 }
 
 DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
-       doc: /* Return t if OBJECT is a number (floating point or integer).  */)
+       doc: /* Return t if OBJECT is a number (floating point or integer).  */
+       attributes: const)
   (Lisp_Object object)
 {
   if (NUMBERP (object))
@@ -492,7 +504,8 @@ DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
 }
 
 DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
-       doc: /* Return t if OBJECT is a floating point number.  */)
+       doc: /* Return t if OBJECT is a floating point number.  */
+       attributes: const)
   (Lisp_Object object)
 {
   if (FLOATP (object))
@@ -2954,7 +2967,8 @@ DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
 DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0,
        doc: /* Return the byteorder for the machine.
 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
-lowercase l) for small endian machines.  */)
+lowercase l) for small endian machines.  */
+       attributes: const)
   (void)
 {
   unsigned i = 0x04030201;

src/decompress.c

@@ -88,7 +88,8 @@ unwind_decompress (void *ddata)
 }
 
 DEFUN ("zlib-available-p", Fzlib_available_p, Szlib_available_p, 0, 0, 0,
-       doc: /* Return t if zlib decompression is available in this instance of Emacs.  */)
+       doc: /* Return t if zlib decompression is available in this instance of Emacs.  */
+       attributes: const)
      (void)
 {
 #ifdef WINDOWSNT

src/emacs.c

@@ -1892,7 +1892,8 @@ or SIGHUP, and upon SIGINT in batch mode.
 
 The value of `kill-emacs-hook', if not void,
 is a list of functions (of no args),
-all of which are called before Emacs is actually killed.  */)
+all of which are called before Emacs is actually killed.  */
+       attributes: noreturn)
   (Lisp_Object arg)
 {
   struct gcpro gcpro1;

src/eval.c

@@ -1162,7 +1162,8 @@ unwind_to_catch (struct handler *catch, Lisp_Object value)
 
 DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
        doc: /* Throw to the catch for TAG and return VALUE from it.
-Both TAG and VALUE are evalled.  */)
+Both TAG and VALUE are evalled.  */
+       attributes: noreturn)
   (register Lisp_Object tag, Lisp_Object value)
 {
   struct handler *c;

src/fns.c

@@ -46,7 +46,8 @@ static void sort_vector_copy (Lisp_Object, ptrdiff_t,
 static bool internal_equal (Lisp_Object, Lisp_Object, int, bool, Lisp_Object);
 
 DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
-       doc: /* Return the argument unchanged.  */)
+       doc: /* Return the argument unchanged.  */
+       attributes: const)
   (Lisp_Object arg)
 {
   return arg;

src/frame.c

@@ -270,7 +270,8 @@ predicates which report frame's specific UI-related capabilities.  */)
 /* Placeholder used by temacs -nw before window.el is loaded.  */
 DEFUN ("frame-windows-min-size", Fframe_windows_min_size,
        Sframe_windows_min_size, 4, 4, 0,
-       doc: /* */)
+       doc: /* */
+       attributes: const)
      (Lisp_Object frame, Lisp_Object horizontal,
       Lisp_Object ignore, Lisp_Object pixelwise)
 {

src/gnutls.c

@@ -695,7 +695,8 @@ See also `gnutls-boot'.  */)
 DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
        doc: /* Return t if ERROR indicates a GnuTLS problem.
 ERROR is an integer or a symbol with an integer `gnutls-code' property.
-usage: (gnutls-errorp ERROR)  */)
+usage: (gnutls-errorp ERROR)  */
+       attributes: const)
   (Lisp_Object err)
 {
   if (EQ (err, Qt)) return Qnil;
@@ -1603,7 +1604,8 @@ This function may also return `gnutls-e-again', or
 #endif	/* HAVE_GNUTLS */
 
 DEFUN ("gnutls-available-p", Fgnutls_available_p, Sgnutls_available_p, 0, 0, 0,
-       doc: /* Return t if GnuTLS is available in this instance of Emacs.  */)
+       doc: /* Return t if GnuTLS is available in this instance of Emacs.  */
+       attributes: const)
      (void)
 {
 #ifdef HAVE_GNUTLS

src/keyboard.c

@@ -1163,7 +1163,8 @@ top_level_1 (Lisp_Object ignore)
 
 DEFUN ("top-level", Ftop_level, Stop_level, 0, 0, "",
        doc: /* Exit all recursive editing levels.
-This also exits all active minibuffers.  */)
+This also exits all active minibuffers.  */
+       attributes: noreturn)
   (void)
 {
 #ifdef HAVE_WINDOW_SYSTEM
@@ -1186,7 +1187,8 @@ user_error (const char *msg)
 
 /* _Noreturn will be added to prototype by make-docfile.  */
 DEFUN ("exit-recursive-edit", Fexit_recursive_edit, Sexit_recursive_edit, 0, 0, "",
-       doc: /* Exit from the innermost recursive edit or minibuffer.  */)
+       doc: /* Exit from the innermost recursive edit or minibuffer.  */
+       attributes: noreturn)
   (void)
 {
   if (command_loop_level > 0 || minibuf_level > 0)
@@ -1197,7 +1199,8 @@ DEFUN ("exit-recursive-edit", Fexit_recursive_edit, Sexit_recursive_edit, 0, 0,
 
 /* _Noreturn will be added to prototype by make-docfile.  */
 DEFUN ("abort-recursive-edit", Fabort_recursive_edit, Sabort_recursive_edit, 0, 0, "",
-       doc: /* Abort the command that requested this recursive edit or minibuffer input.  */)
+       doc: /* Abort the command that requested this recursive edit or minibuffer input.  */
+       attributes: noreturn)
   (void)
 {
   if (command_loop_level > 0 || minibuf_level > 0)

src/window.c

@@ -3000,7 +3000,8 @@ resize_root_window (Lisp_Object window, Lisp_Object delta, Lisp_Object horizonta
 /* Placeholder used by temacs -nw before window.el is loaded.  */
 DEFUN ("window--sanitize-window-sizes", Fwindow__sanitize_window_sizes,
        Swindow__sanitize_window_sizes, 2, 2, 0,
-       doc: /* */)
+       doc: /* */
+       attributes: const)
      (Lisp_Object frame, Lisp_Object horizontal)
 {
   return Qnil;

src/xdisp.c

@@ -12276,7 +12276,8 @@ DEFUN ("tool-bar-height", Ftool_bar_height, Stool_bar_height,
        0, 2, 0,
        doc: /* Return the number of lines occupied by the tool bar of FRAME.
 If FRAME is nil or omitted, use the selected frame.  Optional argument
-PIXELWISE non-nil means return the height of the tool bar in pixels.  */)
+PIXELWISE non-nil means return the height of the tool bar in pixels.  */
+       attributes: const)
   (Lisp_Object frame, Lisp_Object pixelwise)
 {
   int height = 0;

src/xfaces.c

@@ -3546,7 +3546,8 @@ with the value VALUE is relative.
 A relative value is one that doesn't entirely override whatever is
 inherited from another face.  For most possible attributes,
 the only relative value that users see is `unspecified'.
-However, for :height, floating point values are also relative.  */)
+However, for :height, floating point values are also relative.  */
+       attributes: const)
   (Lisp_Object attribute, Lisp_Object value)
 {
   if (EQ (value, Qunspecified) || (EQ (value, QCignore_defface)))