[Patch, Fortran] PR56737 - Fixing a bug in the I/O format cache handling

[Tobias Burnus <burnus at net-b dot de>]

libgfortran parses the format string for formatted I/O and saves it in 
an internal representation. To speed up the I/O - for instance in a loop 
-, caching is used.

However, a pointer to format string is used for the processing of 
strings (normal string constants and Hollerith). That works well if the 
format string is a constant as then the pointer won't change between 
invocations. It often also works when the string is stack-allocated if 
either the character variable on the stack is never freed (for the same 
format string) - or multiple calls to the same format lead to the same 
stack location. (In general, the same stack location is unlikely but in 
typical I/O calls that's often the case. And static string constants are 
the rule.)

The bug dates back to the first caching implementation in GCC 4.5.

There are two possibilities:
a) To disable caching when a string (FMT_A or FMT_H) is in the format 
string.
b) To copy the format string

The attached patch does the latter. The current hashing algorithm avoids 
hash collisions by checking whether the value is exactly the same - and 
the value is given by the format string. Thus, instead of copying the 
string when storing the format in the cache, the patch copies it now 
before calling parse_format_list.

Bootstrapped and regtested on x86-64-gnu-linux.
OK for the trunk and the 4.6/4.7/4.8 branches?

Tobias

2013-03-28  Tobias Burnus  <burnus@net-b.de>

	PR fortran/56737
	* io/format.c (parse_format): With caching, copy
	dtp->format string.
	(save_parsed_format): Use dtp->format directy without
	copying.

2013-03-28  Tobias Burnus  <burnus@net-b.de>

	PR fortran/56737
	* testsuite/gfortran.dg/fmt_cache_3.f90: New.

diff --git a/gcc/testsuite/gfortran.dg/fmt_cache_3.f90 b/gcc/testsuite/gfortran.dg/fmt_cache_3.f90
new file mode 100644
index 0000000..ec8e1b3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/fmt_cache_3.f90
@@ -0,0 +1,80 @@
+! { dg-do run }
+!
+! PR fortran/56737
+!
+! Contributed by Jonathan Hogg
+!
+module hsl_mc73_single
+   implicit none
+   integer, parameter, private :: wp = kind(0.0)
+contains
+   subroutine mc73_fiedler(n,lirn,irn,ip,list)
+      integer,  intent (in) :: n
+      integer,  intent (in) :: lirn
+      integer,  intent (in) :: irn(*)
+      integer,  intent (in) :: ip(*)
+      integer, intent (out) :: list(*)
+
+      integer :: icntl(10)
+
+      call fiedler_graph(icntl)
+   end subroutine mc73_fiedler
+
+   subroutine mc73_order
+      integer :: icntl(10)
+
+      call fiedler_graph(icntl)
+   end subroutine mc73_order
+
+   subroutine fiedler_graph(icntl)
+      integer,  intent (in) :: icntl(10)
+
+      real (kind = wp)  :: tol
+      real (kind = wp)  :: tol1
+      real (kind = wp)  :: rtol
+
+      call multilevel_eig(tol,tol1,rtol,icntl)
+   end subroutine fiedler_graph
+
+   subroutine multilevel_eig(tol,tol1,rtol,icntl)
+      real (kind = wp), intent (in) :: tol,tol1,rtol
+      integer,  intent(in) :: icntl(10)
+
+      call level_print(6,'end of level ',1)
+   end subroutine multilevel_eig
+
+   subroutine level_print(mp,title1,level)
+      character (len = *), intent(in) :: title1
+      integer,  intent(in) :: mp,level
+      character(len=80) fmt
+      integer :: char_len1,char_len2
+
+      char_len1=len_trim(title1)
+
+      write (fmt,"('(',i4,'(1H ),6h===== ,a',i4,',i4,6h =====)')") &
+           level*3, char_len1
+!      print *, "fmt = ", fmt
+!      print *, "title1= ", title1
+!      print *, "level = ", level
+      write (66,fmt) title1,level
+   end subroutine level_print
+end module hsl_mc73_single
+
+program test
+   use hsl_mc73_single
+   implicit none
+   character(len=200) :: str(2)
+   integer, parameter :: wp = kind(0.0)
+
+   integer :: n, lirn
+   integer :: irn(1), ip(1), list(1)
+
+   str = ""
+   open (66, status='scratch')
+   call mc73_order
+   call mc73_fiedler(n,lirn,irn,ip,list)
+   rewind (66)
+   read (66, '(a)') str
+   close (66)
+   if (any (str /= "   ===== end of level   1 =====")) call abort()
+end program test
diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
index c64596b..db95e49 100644
--- a/libgfortran/io/format.c
+++ b/libgfortran/io/format.c
@@ -148,8 +148,7 @@ save_parsed_format (st_parameter_dt *dtp)
   u->format_hash_table[hash].hashed_fmt = NULL;
 
   free (u->format_hash_table[hash].key);
-  u->format_hash_table[hash].key = xmalloc (dtp->format_len);
-  memcpy (u->format_hash_table[hash].key, dtp->format, dtp->format_len);
+  u->format_hash_table[hash].key = dtp->format;
 
   u->format_hash_table[hash].key_len = dtp->format_len;
   u->format_hash_table[hash].hashed_fmt = dtp->u.p.fmt;
@@ -1223,6 +1222,13 @@ parse_format (st_parameter_dt *dtp)
 
   /* Not found so proceed as follows.  */
 
+  if (format_cache_ok)
+    {
+      char *fmt_string = xmalloc (dtp->format_len);
+      memcpy (fmt_string, dtp->format, dtp->format_len);
+      dtp->format = fmt_string;
+    }
+
   dtp->u.p.fmt = fmt = xmalloc (sizeof (format_data));
   fmt->format_string = dtp->format;
   fmt->format_string_len = dtp->format_len;
@@ -1257,6 +1263,8 @@ parse_format (st_parameter_dt *dtp)
   if (fmt->error)
     {
       format_error (dtp, NULL, fmt->error);
+      if (format_cache_ok)
+	free (dtp->format);
       free_format_hash_table (dtp->u.p.current_unit);
       return;
     }