list_read.c (snprintf): Define if HAVE_SNPRINTF isn't defined.

	* io/list_read.c (snprintf): Define if HAVE_SNPRINTF isn't defined.
	(nml_read_obj): Add nml_err_msg_size argument.  Pass it down to
	recursive call.  Use snprintf instead of sprintf when %s nl->var_name
	is used.
	(nml_get_obj_data): Add nml_err_msg_size argument.  Pass it down to
	nml_read_obj call.  Use snprintf instead of sprintf when %s
	nl->var_name is used.  Pass nml_err_msg to nml_parse_qualifier instead
	of parse_err_msg array.  Append " for namelist variable " and
	nl->var_name to it.
	(namelist_read): Increase size of nml_err_msg array to 200.  Pass
	sizeof nml_err_msg as extra argument to nml_get_obj_data.

	* gfortran.dg/namelist_47.f90: New test.

From-SVN: r134132

gcc/testsuite/ChangeLog

+2008-04-09  Jakub Jelinek  <jakub@redhat.com>
+
+	* gfortran.dg/namelist_47.f90: New test.
+
 2008-04-09  Richard Guenther  <rguenther@suse.de>
 
 	* gfortran.dg/bind_c_usage_14.f03: Adjust.

gcc/testsuite/gfortran.dg/namelist_47.f90

+! { dg-do run }
+
+module nml_47
+  type             ::  mt
+    character(len=2) ::  c012345678901234567890123456789012345678901234567890123456789h(2) = (/"aa","bb"/)
+  end type mt
+  type             ::  bt
+    integer        ::  i(2) = (/1,2/)
+    type(mt)       ::  m(2)
+  end type bt
+end module nml_47
+
+program namelist_47
+  use nml_47
+  type(bt)         ::  x(2)
+  character(140)    ::  teststring
+  namelist /mynml/ x
+
+  teststring = " x(2)%m%c012345678901234567890123456789012345678901234567890123456789h(:)(2:2) = 'z','z',"
+  call writenml (teststring)
+  teststring = " x(2)%m(2)%c012345678901234567890123456789012345678901234567890123456789h(:)(2) = 'z','z',"
+  call writenml (teststring)
+  teststring = " x(2)%m(2)%c012345678901234567890123456789012345678901234567890123456789h(:)(:3) = 'z','z',"
+  call writenml (teststring)
+  teststring = " x(2)%m(2)%c012345678901234567890123456789012345678901234567890123456789h(1:2)(k:) = 'z','z',"
+  call writenml (teststring)
+
+contains
+
+subroutine writenml (astring)
+  character(140), intent(in)  :: astring
+  character(300)   :: errmessage
+  integer          :: ierror
+
+  open (10, status="scratch", delim='apostrophe')
+  write (10, '(A)') "&MYNML"
+  write (10, '(A)') astring
+  write (10, '(A)') "/"
+  rewind (10)
+  read (10, nml = mynml, iostat=ierror, iomsg=errmessage)
+  if (ierror == 0) call abort
+  print '(a)', trim(errmessage)
+  close (10)
+
+end subroutine writenml
+
+end program namelist_47
+! { dg-output "Multiple sub-objects with non-zero rank in namelist object x(\n|\r\n|\r)" }
+! { dg-output "Missing colon in substring qualifier for namelist variable x%m%c012345678901234567890123456789012345678901234567890123456789h(\n|\r\n|\r)" }
+! { dg-output "Substring out of range for namelist variable x%m%c012345678901234567890123456789012345678901234567890123456789h(\n|\r\n|\r)" }
+! { dg-output "Bad character in substring qualifier for namelist variable x%m%c012345678901234567890123456789012345678901234567890123456789h(\n|\r\n|\r)" }
+! { dg-final { cleanup-modules "nml_47" } }

libgfortran/ChangeLog

+2008-04-09  Jakub Jelinek  <jakub@redhat.com>
+
+	* io/list_read.c (snprintf): Define if HAVE_SNPRINTF isn't defined.
+	(nml_read_obj): Add nml_err_msg_size argument.  Pass it down to
+	recursive call.  Use snprintf instead of sprintf when %s nl->var_name
+	is used.
+	(nml_get_obj_data): Add nml_err_msg_size argument.  Pass it down to
+	nml_read_obj call.  Use snprintf instead of sprintf when %s
+	nl->var_name is used.  Pass nml_err_msg to nml_parse_qualifier instead
+	of parse_err_msg array.  Append " for namelist variable " and
+	nl->var_name to it.
+	(namelist_read): Increase size of nml_err_msg array to 200.  Pass
+	sizeof nml_err_msg as extra argument to nml_get_obj_data.
+
 2008-04-07  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/25829 28655

libgfortran/io/list_read.c

@@ -65,6 +65,10 @@ Boston, MA 02110-1301, USA.  */
 
 #define MAX_REPEAT 200000000
 
+#ifndef HAVE_SNPRINTF
+# undef snprintf
+# define snprintf(str, size, ...) sprintf (str, __VA_ARGS__)
+#endif
 
 /* Save a character to a string buffer, enlarging it as necessary.  */
 
@@ -1912,7 +1916,7 @@ calls:
    static void nml_match_name (char *name, int len)
    static int nml_query (st_parameter_dt *dtp)
    static int nml_get_obj_data (st_parameter_dt *dtp,
-				namelist_info **prev_nl, char *)
+				namelist_info **prev_nl, char *, size_t)
 calls:
       static void nml_untouch_nodes (st_parameter_dt *dtp)
       static namelist_info * find_nml_node (st_parameter_dt *dtp,
@@ -1921,7 +1925,7 @@ calls:
 				     array_loop_spec * ls, int rank, char *)
       static void nml_touch_nodes (namelist_info * nl)
       static int nml_read_obj (namelist_info *nl, index_type offset,
-			       namelist_info **prev_nl, char *,
+			       namelist_info **prev_nl, char *, size_t,
 			       index_type clow, index_type chigh)
 calls:
       -itself-  */
@@ -2335,7 +2339,7 @@ query_return:
 static try
 nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
 	      namelist_info **pprev_nl, char *nml_err_msg,
-	      index_type clow, index_type chigh)
+	      size_t nml_err_msg_size, index_type clow, index_type chigh)
 {
   namelist_info * cmp;
   char * obj_name;
@@ -2453,8 +2457,8 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
 	      {
 
 		if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
-				  pprev_nl, nml_err_msg, clow, chigh)
-		    == FAILURE)
+				  pprev_nl, nml_err_msg, nml_err_msg_size,
+				  clow, chigh) == FAILURE)
 		  {
 		    free_mem (obj_name);
 		    return FAILURE;
@@ -2471,8 +2475,8 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
 	    goto incr_idx;
 
           default:
-	    sprintf (nml_err_msg, "Bad type for namelist object %s",
-			nl->var_name);
+	    snprintf (nml_err_msg, nml_err_msg_size,
+		      "Bad type for namelist object %s", nl->var_name);
 	    internal_error (&dtp->common, nml_err_msg);
 	    goto nml_err_ret;
           }
@@ -2560,9 +2564,9 @@ incr_idx:
 
   if (dtp->u.p.repeat_count > 1)
     {
-       sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
-		   nl->var_name );
-       goto nml_err_ret;
+      snprintf (nml_err_msg, nml_err_msg_size,
+		"Repeat count too large for namelist object %s", nl->var_name);
+      goto nml_err_ret;
     }
   return SUCCESS;
 
@@ -2580,7 +2584,7 @@ nml_err_ret:
 
 static try
 nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
-		  char *nml_err_msg)
+		  char *nml_err_msg, size_t nml_err_msg_size)
 {
   char c;
   namelist_info * nl;
@@ -2588,7 +2592,6 @@ nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
   namelist_info * root_nl = NULL;
   int dim, parsed_rank;
   int component_flag;
-  char parse_err_msg[30];
   index_type clow, chigh;
   int non_zero_rank_count;
 
@@ -2687,12 +2690,13 @@ get_name:
   if (nl == NULL)
     {
       if (dtp->u.p.nml_read_error && *pprev_nl)
-	sprintf (nml_err_msg, "Bad data for namelist object %s",
-		    (*pprev_nl)->var_name);
+	snprintf (nml_err_msg, nml_err_msg_size,
+		  "Bad data for namelist object %s", (*pprev_nl)->var_name);
 
       else
-	sprintf (nml_err_msg, "Cannot match namelist object name %s",
-		    dtp->u.p.saved_string);
+	snprintf (nml_err_msg, nml_err_msg_size,
+		  "Cannot match namelist object name %s",
+		  dtp->u.p.saved_string);
 
       goto nml_err_ret;
     }
@@ -2714,10 +2718,12 @@ get_name:
     {
       parsed_rank = 0;
       if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
-			       parse_err_msg, &parsed_rank) == FAILURE)
+			       nml_err_msg, &parsed_rank) == FAILURE)
 	{
-	  sprintf (nml_err_msg, "%s for namelist variable %s",
-		      parse_err_msg, nl->var_name);
+	  char *nml_err_msg_end = strchr (nml_err_msg, '\0');
+	  snprintf (nml_err_msg_end,
+		    nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
+		    " for namelist variable %s", nl->var_name);
 	  goto nml_err_ret;
 	}
 
@@ -2738,8 +2744,8 @@ get_name:
     {
       if (nl->type != GFC_DTYPE_DERIVED)
 	{
-	  sprintf (nml_err_msg, "Attempt to get derived component for %s",
-		      nl->var_name);
+	  snprintf (nml_err_msg, nml_err_msg_size,
+		    "Attempt to get derived component for %s", nl->var_name);
 	  goto nml_err_ret;
 	}
 
@@ -2763,11 +2769,13 @@ get_name:
       descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
       array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
 
-      if (nml_parse_qualifier (dtp, chd, ind, -1, parse_err_msg, &parsed_rank)
+      if (nml_parse_qualifier (dtp, chd, ind, -1, nml_err_msg, &parsed_rank)
 	  == FAILURE)
 	{
-	  sprintf (nml_err_msg, "%s for namelist variable %s",
-		      parse_err_msg, nl->var_name);
+	  char *nml_err_msg_end = strchr (nml_err_msg, '\0');
+	  snprintf (nml_err_msg_end,
+		    nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
+		    " for namelist variable %s", nl->var_name);
 	  goto nml_err_ret;
 	}
 
@@ -2776,9 +2784,9 @@ get_name:
 
       if (ind[0].step != 1)
 	{
-	  sprintf (nml_err_msg,
-		   "Step not allowed in substring qualifier"
-		   " for namelist object %s", nl->var_name);
+	  snprintf (nml_err_msg, nml_err_msg_size,
+		    "Step not allowed in substring qualifier"
+		    " for namelist object %s", nl->var_name);
 	  goto nml_err_ret;
 	}
 
@@ -2799,16 +2807,18 @@ get_name:
 
   if (c == '(')
     {
-      sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
-		  " namelist object %s", nl->var_name);
+      snprintf (nml_err_msg, nml_err_msg_size,
+		"Qualifier for a scalar or non-character namelist object %s",
+		nl->var_name);
       goto nml_err_ret;
     }
 
   /* Make sure there is no more than one non-zero rank object.  */
   if (non_zero_rank_count > 1)
     {
-      sprintf (nml_err_msg, "Multiple sub-objects with non-zero rank in"
-	       " namelist object %s", nl->var_name);
+      snprintf (nml_err_msg, nml_err_msg_size,
+		"Multiple sub-objects with non-zero rank in namelist object %s",
+		nl->var_name);
       non_zero_rank_count = 0;
       goto nml_err_ret;
     }
@@ -2832,12 +2842,14 @@ get_name:
 
   if (c != '=')
     {
-      sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
-		  nl->var_name);
+      snprintf (nml_err_msg, nml_err_msg_size,
+		"Equal sign must follow namelist object name %s",
+		nl->var_name);
       goto nml_err_ret;
     }
 
-  if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, clow, chigh) == FAILURE)
+  if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size,
+		    clow, chigh) == FAILURE)
     goto nml_err_ret;
 
   return SUCCESS;
@@ -2856,7 +2868,7 @@ namelist_read (st_parameter_dt *dtp)
 {
   char c;
   jmp_buf eof_jump;
-  char nml_err_msg[100];
+  char nml_err_msg[200];
   /* Pointer to the previously read object, in case attempt is made to read
      new object name.  Should this fail, error message can give previous
      name.  */
@@ -2924,7 +2936,8 @@ find_nml_name:
 
   while (!dtp->u.p.input_complete)
     {
-      if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg) == FAILURE)
+      if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg)
+			    == FAILURE)
 	{
 	  gfc_unit *u;