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

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 54c058e..4960161 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+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.

diff --git a/gcc/testsuite/gfortran.dg/namelist_47.f90 b/gcc/testsuite/gfortran.dg/namelist_47.f90
new file mode 100644 (file)
index 0000000..bc9110f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/namelist_47.f90
@@ -0,0 +1,52 @@
+! { 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" } }

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 631d1ac..e5908bb 100644 (file)
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,17 @@
+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

diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index 89c55c7..802bf9e 100644 (file)
--- a/libgfortran/io/list_read.c
+++ b/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;