re PR libfortran/32858 (printf-capabilities for runtime_error())

2007-07-29  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/32858
	PR libfortran/30814
	* configure.ac:  Added checks for presence of stdio.h and
	stdarg.h.  Test presence of vsnprintf().
	* configure: Regenerated.
	* config.h.in:  Regenerated.
	* libgfortran.h:  Include <stdio.h>.  Add printf attribute to
	prototype of runtime_error.  Remove prototype for st_sprintf.
	Add prototype for st_vprintf.
	* runtime/main.c (store_exec_path):  Replace st_sprintf by sprintf.
	* runtime/error.c (st_sprintf):  Remove.
	(runtime_error):  Rewrite as a variadic function.  Call
	st_vprintf().
	* intrinsics/pack_generic.c:  Output extents of LHS and RHS for
	bounds error.
	* io/open.c (new_unit):  Replace st_sprintf by sprintf.
	* io/list_read.c (convert_integer):  Likewise.
	(parse_repeat):  Likewise.
	(read_logical):  Likewise.
	(read_character):  Likewise.
	(parse_real):  Likewise.
	(read_real):  Likewise.
	(check_type):  Likewise.
	(nml_parse_qualifyer):  Likewise.
	(nml_read_obj):  Likewise.
	(nml_get_ojb_data):  Likewise.
	* io/unix.c (init_error_stream):  Remove.
	(tempfile):  Replace st_sprintf by sprintf.
	(st_vprintf):  New function.
	(st_printf):  Rewrite to call st_vprintf.
	* io/transfer.c (require_type):  Replace st_sprintf by sprintf.
	* io/format.c (format_error):  Likewise.
	* io/write.c (nml_write_obj):  Likewise.

2007-07-29  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/32858
	PR libfortran/30814
	* gfortran.dg/pack_bounds_1.f90:  Adjust to new error message.

From-SVN: r127049

6 files changed, 80 insertions, 162 deletions

diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
index 36ab89b..c8cd2a7 100644
--- a/libgfortran/io/format.c
+++ b/libgfortran/io/format.c
@@ -915,7 +915,7 @@ format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
   if (f != NULL)
     fmt->format_string = f->source;
 
-  st_sprintf (buffer, "%s\n", message);
+  sprintf (buffer, "%s\n", message);
 
   j = fmt->format_string - dtp->format;
 
diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index b06b1ca..41d4a60 100644
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -464,8 +464,8 @@ convert_integer (st_parameter_dt *dtp, int length, int negative)
 
       if (dtp->u.p.repeat_count == 0)
 	{
-	  st_sprintf (message, "Zero repeat count in item %d of list input",
-		      dtp->u.p.item_count);
+	  sprintf (message, "Zero repeat count in item %d of list input",
+		   dtp->u.p.item_count);
 
 	  generate_error (&dtp->common, ERROR_READ_VALUE, message);
 	  m = 1;
@@ -477,11 +477,11 @@ convert_integer (st_parameter_dt *dtp, int length, int negative)
 
  overflow:
   if (length == -1)
-    st_sprintf (message, "Repeat count overflow in item %d of list input",
-		dtp->u.p.item_count);
+    sprintf (message, "Repeat count overflow in item %d of list input",
+	     dtp->u.p.item_count);
   else
-    st_sprintf (message, "Integer overflow while reading item %d",
-		dtp->u.p.item_count);
+    sprintf (message, "Integer overflow while reading item %d",
+	     dtp->u.p.item_count);
 
   free_saved (dtp);
   generate_error (&dtp->common, ERROR_READ_VALUE, message);
@@ -527,9 +527,9 @@ parse_repeat (st_parameter_dt *dtp)
 
 	  if (repeat > MAX_REPEAT)
 	    {
-	      st_sprintf (message,
-			  "Repeat count overflow in item %d of list input",
-			  dtp->u.p.item_count);
+	      sprintf (message,
+		       "Repeat count overflow in item %d of list input",
+		       dtp->u.p.item_count);
 
 	      generate_error (&dtp->common, ERROR_READ_VALUE, message);
 	      return 1;
@@ -540,9 +540,9 @@ parse_repeat (st_parameter_dt *dtp)
 	case '*':
 	  if (repeat == 0)
 	    {
-	      st_sprintf (message,
-			  "Zero repeat count in item %d of list input",
-			  dtp->u.p.item_count);
+	      sprintf (message,
+		       "Zero repeat count in item %d of list input",
+		       dtp->u.p.item_count);
 
 	      generate_error (&dtp->common, ERROR_READ_VALUE, message);
 	      return 1;
@@ -563,8 +563,8 @@ parse_repeat (st_parameter_dt *dtp)
 
   eat_line (dtp);
   free_saved (dtp);
-  st_sprintf (message, "Bad repeat count in item %d of list input",
-	      dtp->u.p.item_count);
+  sprintf (message, "Bad repeat count in item %d of list input",
+	   dtp->u.p.item_count);
   generate_error (&dtp->common, ERROR_READ_VALUE, message);
   return 1;
 }
@@ -708,7 +708,7 @@ read_logical (st_parameter_dt *dtp, int length)
 
   eat_line (dtp);
   free_saved (dtp);
-  st_sprintf (message, "Bad logical value while reading item %d",
+  sprintf (message, "Bad logical value while reading item %d",
 	      dtp->u.p.item_count);
   generate_error (&dtp->common, ERROR_READ_VALUE, message);
   return;
@@ -840,7 +840,7 @@ read_integer (st_parameter_dt *dtp, int length)
   
   eat_line (dtp);
   free_saved (dtp);
-  st_sprintf (message, "Bad integer for item %d in list input",
+  sprintf (message, "Bad integer for item %d in list input",
 	      dtp->u.p.item_count);
   generate_error (&dtp->common, ERROR_READ_VALUE, message);
 
@@ -1004,7 +1004,7 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
   else
     {
       free_saved (dtp);
-      st_sprintf (message, "Invalid string input in item %d",
+      sprintf (message, "Invalid string input in item %d",
 		  dtp->u.p.item_count);
       generate_error (&dtp->common, ERROR_READ_VALUE, message);
     }
@@ -1123,7 +1123,7 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
 
   eat_line (dtp);
   free_saved (dtp);
-  st_sprintf (message, "Bad floating point number for item %d",
+  sprintf (message, "Bad floating point number for item %d",
 	      dtp->u.p.item_count);
   generate_error (&dtp->common, ERROR_READ_VALUE, message);
 
@@ -1206,7 +1206,7 @@ eol_2:
 
   eat_line (dtp);
   free_saved (dtp);
-  st_sprintf (message, "Bad complex value in item %d of list input",
+  sprintf (message, "Bad complex value in item %d of list input",
 	      dtp->u.p.item_count);
   generate_error (&dtp->common, ERROR_READ_VALUE, message);
 }
@@ -1421,7 +1421,7 @@ read_real (st_parameter_dt *dtp, int length)
 
   eat_line (dtp);
   free_saved (dtp);
-  st_sprintf (message, "Bad real number in item %d of list input",
+  sprintf (message, "Bad real number in item %d of list input",
 	      dtp->u.p.item_count);
   generate_error (&dtp->common, ERROR_READ_VALUE, message);
 }
@@ -1437,7 +1437,7 @@ check_type (st_parameter_dt *dtp, bt type, int len)
 
   if (dtp->u.p.saved_type != BT_NULL && dtp->u.p.saved_type != type)
     {
-      st_sprintf (message, "Read type %s where %s was expected for item %d",
+      sprintf (message, "Read type %s where %s was expected for item %d",
 		  type_name (dtp->u.p.saved_type), type_name (type),
 		  dtp->u.p.item_count);
 
@@ -1450,7 +1450,7 @@ check_type (st_parameter_dt *dtp, bt type, int len)
 
   if (dtp->u.p.saved_length != len)
     {
-      st_sprintf (message,
+      sprintf (message,
 		  "Read kind %d %s where kind %d is required for item %d",
 		  dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
 		  dtp->u.p.item_count);
@@ -1723,8 +1723,8 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
 		  if ((c==',' && dim == rank -1)
 		      || (c==')' && dim < rank -1))
 		    {
-		      st_sprintf (parse_err_msg,
-				  "Bad number of index fields");
+		      sprintf (parse_err_msg,
+			       "Bad number of index fields");
 		      goto err_ret;
 		    }
 		  break;
@@ -1739,21 +1739,21 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
 		  break;
 
 		default:
-		  st_sprintf (parse_err_msg, "Bad character in index");
+		  sprintf (parse_err_msg, "Bad character in index");
 		  goto err_ret;
 		}
 
 	      if ((c == ',' || c == ')') && indx == 0
 		  && dtp->u.p.saved_string == 0)
 		{
-		  st_sprintf (parse_err_msg, "Null index field");
+		  sprintf (parse_err_msg, "Null index field");
 		  goto err_ret;
 		}
 
 	      if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
 		  || (indx == 2 && dtp->u.p.saved_string == 0))
 		{
-		  st_sprintf(parse_err_msg, "Bad index triplet");
+		  sprintf(parse_err_msg, "Bad index triplet");
 		  goto err_ret;
 		}
 
@@ -1769,7 +1769,7 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
 	      /* Now read the index.  */
 	      if (convert_integer (dtp, sizeof(ssize_t), neg))
 		{
-		  st_sprintf (parse_err_msg, "Bad integer in index");
+		  sprintf (parse_err_msg, "Bad integer in index");
 		  goto err_ret;
 		}
 	      break;
@@ -1811,13 +1811,13 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
 	  || (ls[dim].end > (ssize_t)ad[dim].ubound)
 	  || (ls[dim].end < (ssize_t)ad[dim].lbound))
 	{
-	  st_sprintf (parse_err_msg, "Index %d out of range", dim + 1);
+	  sprintf (parse_err_msg, "Index %d out of range", dim + 1);
 	  goto err_ret;
 	}
       if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
 	  || (ls[dim].step == 0))
 	{
-	  st_sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
+	  sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
 	  goto err_ret;
 	}
 
@@ -2171,7 +2171,7 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
 	    goto incr_idx;
 
           default:
-	    st_sprintf (nml_err_msg, "Bad type for namelist object %s",
+	    sprintf (nml_err_msg, "Bad type for namelist object %s",
 			nl->var_name);
 	    internal_error (&dtp->common, nml_err_msg);
 	    goto nml_err_ret;
@@ -2260,7 +2260,7 @@ incr_idx:
 
   if (dtp->u.p.repeat_count > 1)
     {
-       st_sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
+       sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
 		   nl->var_name );
        goto nml_err_ret;
     }
@@ -2310,7 +2310,7 @@ nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
       c = next_char (dtp);
       if (c != '?')
 	{
-	  st_sprintf (nml_err_msg, "namelist read: misplaced = sign");
+	  sprintf (nml_err_msg, "namelist read: misplaced = sign");
 	  goto nml_err_ret;
 	}
       nml_query (dtp, '=');
@@ -2325,7 +2325,7 @@ nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
       nml_match_name (dtp, "end", 3);
       if (dtp->u.p.nml_read_error)
 	{
-	  st_sprintf (nml_err_msg, "namelist not terminated with / or &end");
+	  sprintf (nml_err_msg, "namelist not terminated with / or &end");
 	  goto nml_err_ret;
 	}
     case '/':
@@ -2384,11 +2384,11 @@ get_name:
   if (nl == NULL)
     {
       if (dtp->u.p.nml_read_error && *pprev_nl)
-	st_sprintf (nml_err_msg, "Bad data for namelist object %s",
+	sprintf (nml_err_msg, "Bad data for namelist object %s",
 		    (*pprev_nl)->var_name);
 
       else
-	st_sprintf (nml_err_msg, "Cannot match namelist object name %s",
+	sprintf (nml_err_msg, "Cannot match namelist object name %s",
 		    dtp->u.p.saved_string);
 
       goto nml_err_ret;
@@ -2412,7 +2412,7 @@ get_name:
       if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
 			       parse_err_msg) == FAILURE)
 	{
-	  st_sprintf (nml_err_msg, "%s for namelist variable %s",
+	  sprintf (nml_err_msg, "%s for namelist variable %s",
 		      parse_err_msg, nl->var_name);
 	  goto nml_err_ret;
 	}
@@ -2429,7 +2429,7 @@ get_name:
 
       if (nl->type != GFC_DTYPE_DERIVED)
 	{
-	  st_sprintf (nml_err_msg, "Attempt to get derived component for %s",
+	  sprintf (nml_err_msg, "Attempt to get derived component for %s",
 		      nl->var_name);
 	  goto nml_err_ret;
 	}
@@ -2457,7 +2457,7 @@ get_name:
 
       if (nml_parse_qualifier (dtp, chd, ind, 1, parse_err_msg) == FAILURE)
 	{
-	  st_sprintf (nml_err_msg, "%s for namelist variable %s",
+	  sprintf (nml_err_msg, "%s for namelist variable %s",
 		      parse_err_msg, nl->var_name);
 	  goto nml_err_ret;
 	}
@@ -2467,7 +2467,7 @@ get_name:
 
       if (ind[0].step != 1)
 	{
-	  st_sprintf (nml_err_msg,
+	  sprintf (nml_err_msg,
 		      "Bad step in substring for namelist object %s",
 		      nl->var_name);
 	  goto nml_err_ret;
@@ -2490,7 +2490,7 @@ get_name:
 
   if (c == '(')
     {
-      st_sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
+      sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
 		  " namelist object %s", nl->var_name);
       goto nml_err_ret;
     }
@@ -2514,7 +2514,7 @@ get_name:
 
   if (c != '=')
     {
-      st_sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
+      sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
 		  nl->var_name);
       goto nml_err_ret;
     }
diff --git a/libgfortran/io/open.c b/libgfortran/io/open.c
index 68be74b..67f8804 100644
--- a/libgfortran/io/open.c
+++ b/libgfortran/io/open.c
@@ -389,19 +389,19 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
       switch (errno)
 	{
 	case ENOENT: 
-	  st_sprintf (msg, "File '%s' does not exist", path);
+	  sprintf (msg, "File '%s' does not exist", path);
 	  break;
 
 	case EEXIST:
-	  st_sprintf (msg, "File '%s' already exists", path);
+	  sprintf (msg, "File '%s' already exists", path);
 	  break;
 
 	case EACCES:
-	  st_sprintf (msg, "Permission denied trying to open file '%s'", path);
+	  sprintf (msg, "Permission denied trying to open file '%s'", path);
 	  break;
 
 	case EISDIR:
-	  st_sprintf (msg, "'%s' is a directory", path);
+	  sprintf (msg, "'%s' is a directory", path);
 	  break;
 
 	default:
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 3feae04..04f9f73 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -852,8 +852,8 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
   if (actual == expected)
     return 0;
 
-  st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
-	      type_name (expected), dtp->u.p.item_count, type_name (actual));
+  sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
+	   type_name (expected), dtp->u.p.item_count, type_name (actual));
 
   format_error (dtp, f, buffer);
   return 1;
diff --git a/libgfortran/io/unix.c b/libgfortran/io/unix.c
index 87d001e..e9ad164 100644
--- a/libgfortran/io/unix.c
+++ b/libgfortran/io/unix.c
@@ -142,10 +142,6 @@ typedef struct
 }
 int_stream;
 
-extern stream *init_error_stream (unix_stream *);
-internal_proto(init_error_stream);
-
-
 /* This implementation of stream I/O is based on the paper:
  *
  *  "Exploiting the advantages of mapped files for stream I/O",
@@ -1155,7 +1151,7 @@ tempfile (st_parameter_open *opp)
 
   template = get_mem (strlen (tempdir) + 20);
 
-  st_sprintf (template, "%s/gfortrantmpXXXXXX", tempdir);
+  sprintf (template, "%s/gfortrantmpXXXXXX", tempdir);
 
 #ifdef HAVE_MKSTEMP
 
@@ -1385,122 +1381,44 @@ error_stream (void)
   return fd_to_stream (STDERR_FILENO, PROT_WRITE);
 }
 
-/* init_error_stream()-- Return a pointer to the error stream.  This
- * subroutine is called when the stream is needed, rather than at
- * initialization.  We want to work even if memory has been seriously
- * corrupted. */
 
-stream *
-init_error_stream (unix_stream *error)
-{
-  memset (error, '\0', sizeof (*error));
+/* st_vprintf()-- vprintf function for error output.  To avoid buffer
+   overruns, we limit the length of the buffer to ST_VPRINTF_SIZE.  2k
+   is big enough to completely fill a 80x25 terminal, so it shuld be
+   OK.  We use a direct write() because it is simpler and least likely
+   to be clobbered by memory corruption.  */
 
-  error->fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
+#define ST_VPRINTF_SIZE 2048
 
-  error->st.alloc_w_at = (void *) fd_alloc_w_at;
-  error->st.sfree = (void *) fd_sfree;
-
-  error->unbuffered = 1;
-  error->buffer = error->small_buffer;
+int
+st_vprintf (const char *format, va_list ap)
+{
+  static char buffer[ST_VPRINTF_SIZE];
+  int written;
+  int fd;
 
-  return (stream *) error;
+  fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
+#ifdef HAVE_VSNPRINTF
+  written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
+#else
+  written = __builtin_vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
+#endif
+  written = write (fd, buffer, written);
+  return written;
 }
 
-/* st_printf()-- simple printf() function for streams that handles the
- * formats %d, %s and %c.  This function handles printing of error
- * messages that originate within the library itself, not from a user
- * program. */
+/* st_printf()-- printf() function for error output.  This just calls
+   st_vprintf() to do the actual work.  */
 
 int
 st_printf (const char *format, ...)
 {
-  int count, total;
-  va_list arg;
-  char *p;
-  const char *q;
-  stream *s;
-  char itoa_buf[GFC_ITOA_BUF_SIZE];
-  unix_stream err_stream;
-
-  total = 0;
-  s = init_error_stream (&err_stream);
-  va_start (arg, format);
-
-  for (;;)
-    {
-      count = 0;
-
-      while (format[count] != '%' && format[count] != '\0')
-	count++;
-
-      if (count != 0)
-	{
-	  p = salloc_w (s, &count);
-	  memmove (p, format, count);
-	  sfree (s);
-	}
-
-      total += count;
-      format += count;
-      if (*format++ == '\0')
-	break;
-
-      switch (*format)
-	{
-	case 'c':
-	  count = 1;
-
-	  p = salloc_w (s, &count);
-	  *p = (char) va_arg (arg, int);
-
-	  sfree (s);
-	  break;
-
-	case 'd':
-	  q = gfc_itoa (va_arg (arg, int), itoa_buf, sizeof (itoa_buf));
-	  count = strlen (q);
-
-	  p = salloc_w (s, &count);
-	  memmove (p, q, count);
-	  sfree (s);
-	  break;
-
-	case 'x':
-	  q = xtoa (va_arg (arg, unsigned), itoa_buf, sizeof (itoa_buf));
-	  count = strlen (q);
-
-	  p = salloc_w (s, &count);
-	  memmove (p, q, count);
-	  sfree (s);
-	  break;
-
-	case 's':
-	  q = va_arg (arg, char *);
-	  count = strlen (q);
-
-	  p = salloc_w (s, &count);
-	  memmove (p, q, count);
-	  sfree (s);
-	  break;
-
-	case '\0':
-	  return total;
-
-	default:
-	  count = 2;
-	  p = salloc_w (s, &count);
-	  p[0] = format[-1];
-	  p[1] = format[0];
-	  sfree (s);
-	  break;
-	}
-
-      total += count;
-      format++;
-    }
-
-  va_end (arg);
-  return total;
+  int written;
+  va_list ap;
+  va_start (ap, format);
+  written = st_vprintf(format, ap);
+  va_end (ap);
+  return written;
 }
 
 
diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
index b4e5d3e..9509711 100644
--- a/libgfortran/io/write.c
+++ b/libgfortran/io/write.c
@@ -1719,7 +1719,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 	{
 	  if (rep_ctr > 1)
 	    {
-	      st_sprintf(rep_buff, " %d*", rep_ctr);
+	      sprintf(rep_buff, " %d*", rep_ctr);
 	      write_character (dtp, rep_buff, strlen (rep_buff));
 	      dtp->u.p.no_leading_blank = 1;
 	    }
@@ -1792,7 +1792,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 		      ext_name[tot_len] = '(';
 		      tot_len++;
 		    }
-		  st_sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
+		  sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
 		  tot_len += strlen (ext_name + tot_len);
 		  ext_name[tot_len] = (dim_i == obj->var_rank - 1) ? ')' : ',';
 		  tot_len++;