[patch, libgfortran] [4.5 Regression] incorrect IO

[Jerry DeLisle <jvdelisle at verizon dot net>]

The attached patch fixes this PR.  I have not had time to produce a reduced test 
case.  For testing, I used CP2k directly in combination with valgrind to assure 
no memory leaks.  Without the patch, the CP2K test case 
Fist/regtest-5/wat_freq.inp fails to complete execution.

The cause of the failure is that embedded text strings within format strings are 
clobbered when writing.  This fix avoids this issue by disabling format caching 
when such strings are encountered.  I have added a TODO comment in format.c so 
that we can remember to look into this further as time allows.

Regression tested on x86-64-linux-gnu.  NIST tested.

OK for trunk.

Regards,

Jerry

2009-07-06  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libfortran/40330
	* io/io.h (st_parameter_dt): Define format_not_saved bit used to signal
	whether the parsed format data was previously saved. Used to determine
	if the current format data should be freed or not.
	* io/transfer.c (st_read_done): Use the format_not_saved bit.
	(st_write_done): Likewise.
	* io/format.c (parse_format_list): Add boolean pointer to arg list. This
	pointer is used to return status to the caller regarding whether it is
	safe to cache the parsed format data.  Currently, if a FMT_STRING token
	is encounetered, it is not safe to cache. Also, added a local boolean
	variable to hold this information as recursive calls to
	parse_format_list are made.  Remove previous save_format logic.
	(parse_format): Do not use the format caching facility if the current
	unit is an internal unit or if it is not safe to save parsed format
	data.

Index: io.h
===================================================================
--- io.h	(revision 149284)
+++ io.h	(working copy)
@@ -481,7 +481,9 @@ typedef struct st_parameter_dt
 	  unsigned at_eof : 1;
 	  /* Used for g0 floating point output.  */
 	  unsigned g0_no_blanks : 1;
-	  /* 15 unused bits.  */
+	  /* Used to signal use of free_format_data.  */
+	  unsigned format_not_saved : 1;
+	  /* 14 unused bits.  */
 
 	  char last_char;
 	  char nml_delim;
Index: transfer.c
===================================================================
--- transfer.c	(revision 149284)
+++ transfer.c	(working copy)
@@ -3251,7 +3251,7 @@ void
 st_read_done (st_parameter_dt *dtp)
 {
   finalize_transfer (dtp);
-  if (is_internal_unit (dtp))
+  if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
     free_format_data (dtp->u.p.fmt);
   free_ionml (dtp);
   if (dtp->u.p.current_unit != NULL)
@@ -3303,7 +3303,7 @@ st_write_done (st_parameter_dt *dtp)
 	break;
       }
 
-  if (is_internal_unit (dtp))
+  if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
     free_format_data (dtp->u.p.fmt);
   free_ionml (dtp);
   if (dtp->u.p.current_unit != NULL)
Index: format.c
===================================================================
--- format.c	(revision 149284)
+++ format.c	(working copy)
@@ -578,16 +578,16 @@ format_lex (format_data *fmt)
  * parenthesis node which contains the rest of the list. */
 
 static fnode *
-parse_format_list (st_parameter_dt *dtp)
+parse_format_list (st_parameter_dt *dtp, bool *save_ok)
 {
   fnode *head, *tail;
   format_token t, u, t2;
   int repeat;
   format_data *fmt = dtp->u.p.fmt;
-  bool save_format;
+  bool saveit;
 
   head = tail = NULL;
-  save_format = !is_internal_unit (dtp);
+  saveit = *save_ok;
 
   /* Get the next format item */
  format_item:
@@ -604,7 +604,7 @@ parse_format_list (st_parameter_dt *dtp)
 	case FMT_LPAREN:
 	  get_fnode (fmt, &head, &tail, FMT_LPAREN);
 	  tail->repeat = repeat;
-	  tail->u.child = parse_format_list (dtp);
+	  tail->u.child = parse_format_list (dtp, &saveit);
 	  if (fmt->error != NULL)
 	    goto finished;
 
@@ -631,7 +631,7 @@ parse_format_list (st_parameter_dt *dtp)
     case FMT_LPAREN:
       get_fnode (fmt, &head, &tail, FMT_LPAREN);
       tail->repeat = 1;
-      tail->u.child = parse_format_list (dtp);
+      tail->u.child = parse_format_list (dtp, &saveit);
       if (fmt->error != NULL)
 	goto finished;
 
@@ -687,8 +687,9 @@ parse_format_list (st_parameter_dt *dtp)
       goto between_desc;
 
     case FMT_STRING:
+      /* TODO: Find out why is is necessary to turn off format caching.  */
+      saveit = false;
       get_fnode (fmt, &head, &tail, FMT_STRING);
-
       tail->u.string.p = fmt->string;
       tail->u.string.length = fmt->value;
       tail->repeat = 1;
@@ -698,7 +699,6 @@ parse_format_list (st_parameter_dt *dtp)
     case FMT_DP:
       notify_std (&dtp->common, GFC_STD_F2003, "Fortran 2003: DC or DP "
 		  "descriptor not allowed");
-      save_format = true;
     /* Fall through.  */
     case FMT_S:
     case FMT_SS:
@@ -724,10 +724,8 @@ parse_format_list (st_parameter_dt *dtp)
       get_fnode (fmt, &head, &tail, FMT_DOLLAR);
       tail->repeat = 1;
       notify_std (&dtp->common, GFC_STD_GNU, "Extension: $ descriptor");
-      save_format = false;
       goto between_desc;
 
-
     case FMT_T:
     case FMT_TL:
     case FMT_TR:
@@ -759,7 +757,6 @@ parse_format_list (st_parameter_dt *dtp)
 
     case FMT_H:
       get_fnode (fmt, &head, &tail, FMT_STRING);
-
       if (fmt->format_string_len < 1)
 	{
 	  fmt->error = bad_hollerith;
@@ -822,7 +819,6 @@ parse_format_list (st_parameter_dt *dtp)
 	      fmt->saved_token = t;
 	      fmt->value = 1;	/* Default width */
 	      notify_std (&dtp->common, GFC_STD_GNU, posint_required);
-	      save_format = false;
 	    }
 	}
 
@@ -959,7 +955,6 @@ parse_format_list (st_parameter_dt *dtp)
 	}
 
       get_fnode (fmt, &head, &tail, FMT_STRING);
-
       tail->u.string.p = fmt->format_string;
       tail->u.string.length = repeat;
       tail->repeat = 1;
@@ -1074,6 +1069,9 @@ parse_format_list (st_parameter_dt *dtp)
   goto format_item;
 
  finished:
+
+  *save_ok = saveit;
+  
   return head;
 }
 
@@ -1166,18 +1164,23 @@ void
 parse_format (st_parameter_dt *dtp)
 {
   format_data *fmt;
+  bool format_cache_ok;
 
-  /* Lookup format string to see if it has already been parsed.  */
-
-  dtp->u.p.fmt = find_parsed_format (dtp);
+  format_cache_ok = !is_internal_unit (dtp);
 
-  if (dtp->u.p.fmt != NULL)
+  /* Lookup format string to see if it has already been parsed.  */
+  if (format_cache_ok)
     {
-      dtp->u.p.fmt->reversion_ok = 0;
-      dtp->u.p.fmt->saved_token = FMT_NONE;
-      dtp->u.p.fmt->saved_format = NULL;
-      reset_fnode_counters (dtp);
-      return;
+      dtp->u.p.fmt = find_parsed_format (dtp);
+
+      if (dtp->u.p.fmt != NULL)
+	{
+	  dtp->u.p.fmt->reversion_ok = 0;
+	  dtp->u.p.fmt->saved_token = FMT_NONE;
+	  dtp->u.p.fmt->saved_format = NULL;
+	  reset_fnode_counters (dtp);
+	  return;
+	}
     }
 
   /* Not found so proceed as follows.  */
@@ -1191,12 +1194,12 @@ parse_format (st_parameter_dt *dtp)
   fmt->error = NULL;
   fmt->value = 0;
 
-  /* Initialize variables used during traversal of the tree */
+  /* Initialize variables used during traversal of the tree.  */
 
   fmt->reversion_ok = 0;
   fmt->saved_format = NULL;
 
-  /* Allocate the first format node as the root of the tree */
+  /* Allocate the first format node as the root of the tree.  */
 
   fmt->last = &fmt->array;
   fmt->last->next = NULL;
@@ -1208,7 +1211,7 @@ parse_format (st_parameter_dt *dtp)
   fmt->avail++;
 
   if (format_lex (fmt) == FMT_LPAREN)
-    fmt->array.array[0].u.child = parse_format_list (dtp);
+    fmt->array.array[0].u.child = parse_format_list (dtp, &format_cache_ok);
   else
     fmt->error = "Missing initial left parenthesis in format";
 
@@ -1219,9 +1222,10 @@ parse_format (st_parameter_dt *dtp)
       return;
     }
 
-  /* TODO: Interim fix for PR40508. Revise this for PR40330.  */
-  if (!is_internal_unit(dtp))
+  if (format_cache_ok)
     save_parsed_format (dtp);
+  else
+    dtp->u.p.format_not_saved = 1;
 }