2009-07-09 Basile Starynkevitch <basile@starynkevitch.net>

	MELT branch merged with trunk rev 149427



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@149430 138bc75d-0d04-0410-961f-82ee72b054a4

4 files changed, 54 insertions, 29 deletions

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index dda90a6c09b..7ea4129aed2 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,22 @@
+2009-07-08  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR libfortran/40330
+	PR libfortran/40662
+	* 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.
+	
 2009-06-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR libfortran/40576
diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
index 401cd827d9c..e40adb9b2a1 100644
--- a/libgfortran/io/format.c
+++ b/libgfortran/io/format.c
@@ -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;
 }
 
 
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index 9e1e45e252b..088969a0fca 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -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;
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 4ad1cf035d0..7d833b78013 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -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)