[patch, fortran] PR41075 Add unlimited format item [F2008]

[Jerry DeLisle <jvdelisle at verizon dot net>]

Hi folks,

The attached patch adds the unlimited format feature '*' to gfortran. 
This is an F2008 feature that basically defines an unlimited repeat 
count at the beginning of a left parenthesis with a format string.

The feature allows some handy input/output for example when an array 
size is not know until run time.  When used in conjunction with the g0 
edit descriptor, you can read/write just about anything all chunk-ed 
together.  I can see its usefulness for data serialization.

I have also attached a simple test case.  I should mention that right 
now I do not check for nested '*' in a format string.  I think it may be 
meaningless because you can never exhaust one to allow the other to take 
effect.  We probably want to think about that and I have not studied the 
F2008 standard in closer detail to see if there is indeed a constraint 
defined.

The attached test case needs to be dejagnu-ified.

Finally, of lesser import, I have modified several error checks to use 
the %L feature to give some better error loci.  No changes in testsuite 
are required.  I lumped them in here because they have been in the local 
tree for over a month.  Disallowing exponent width with D format 
specifier may be controversial, though correct.

Regression tested on x86-64.  OK for trunk:

Regards,

Jerry

2009-08-16  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/41075
	* scanner.c (gfc_next_char_literal): Add comment to improve
	readability.
	* io.c (enum format_token): Add FMT_STAR. (format_lex): Add case
	for '*'. (check_format): Check for left paren after '*'.  Change
	format checks to use %L to improve format string error locus.
	Disallow exponent width with D format specifier.

2009-08-16  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/41075
	* io/io.h (enum format_token): Add FMT_STAR.
	* io/format.c (format_lex): Add case for FMT_STAR.
	(parse_format_list): Parse FMT_STAR and check for left paren
	after. (next_format0): Modify helper function to check for
	unlimited format and return the repeated format node.  Update
	comments to clarify.

Index: gcc/fortran/scanner.c
===================================================================
--- gcc/fortran/scanner.c	(revision 150730)
+++ gcc/fortran/scanner.c	(working copy)
@@ -1139,7 +1139,7 @@ restart:
 	    }
 	}
     }
-  else
+  else /* Fixed form.  */
     {
       /* Fixed form continuation.  */
       if (!in_string && c == '!')
Index: gcc/fortran/io.c
===================================================================
--- gcc/fortran/io.c	(revision 150730)
+++ gcc/fortran/io.c	(working copy)
@@ -111,7 +111,7 @@ typedef enum
   FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN,
   FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
   FMT_E, FMT_EXT, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_ERROR, FMT_DC,
-  FMT_DP, FMT_T, FMT_TR, FMT_TL
+  FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR
 }
 format_token;
 
@@ -469,6 +469,10 @@ format_lex (void)
       token = FMT_END;
       break;
 
+    case '*':
+      token = FMT_STAR;
+      break;
+
     default:
       token = FMT_UNKNOWN;
       break;
@@ -533,6 +537,19 @@ format_item:
 format_item_1:
   switch (t)
     {
+    case FMT_STAR:
+      repeat = -1;
+      t = format_lex ();
+      if (t == FMT_ERROR)
+	goto fail;
+      if (t == FMT_LPAREN)
+	{
+	  level++;
+	  goto format_item;
+	}
+      error = _("Left parenthesis required after '*'");
+      goto syntax;
+
     case FMT_POSINT:
       repeat = value;
       t = format_lex ();
@@ -575,7 +592,7 @@ format_item_1:
     case FMT_X:
       /* X requires a prior number if we're being pedantic.  */
       if (gfc_notify_std (GFC_STD_GNU, "Extension: X descriptor "
-			  "requires leading space count at %C")
+			  "requires leading space count at %L", &format_locus)
 	  == FAILURE)
 	return FAILURE;
       goto between_desc;
@@ -598,12 +615,13 @@ format_item_1:
       if (t == FMT_ERROR)
 	goto fail;
 
-      if (gfc_notify_std (GFC_STD_GNU, "Extension: $ descriptor at %C")
-	  == FAILURE)
+      if (gfc_notify_std (GFC_STD_GNU, "Extension: $ descriptor at %L",
+	  &format_locus) == FAILURE)
 	return FAILURE;
       if (t != FMT_RPAREN || level > 0)
 	{
-	  gfc_warning ("$ should be the last specifier in format at %C");
+	  gfc_warning ("$ should be the last specifier in format at %L",
+		       &format_locus);
 	  goto optional_comma_1;
 	}
 
@@ -682,8 +700,10 @@ data_desc:
       switch (gfc_notification_std (GFC_STD_GNU))
 	{
 	  case WARNING:
+	    if (mode != MODE_FORMAT)
+	      format_locus.nextc += format_string_pos;
 	    gfc_warning ("Extension: Missing positive width after L "
-			 "descriptor at %C");
+			 "descriptor at %L", &format_locus);
 	    saved_token = t;
 	    break;
 
@@ -726,7 +746,7 @@ data_desc:
 	      goto syntax;
 	    }
 	  if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: 'G0' in "
-			      "format at %C") == FAILURE)
+			      "format at %L", &format_locus) == FAILURE)
 	    return FAILURE;
 	  u = format_lex ();
 	  if (u != FMT_PERIOD)
@@ -756,10 +776,14 @@ data_desc:
       if (u != FMT_PERIOD)
 	{
 	  /* Warn if -std=legacy, otherwise error.  */
+	  if (mode != MODE_FORMAT)
+	    format_locus.nextc += format_string_pos;
 	  if (gfc_option.warn_std != 0)
-	    gfc_error_now ("Period required in format specifier at %C");
+	    gfc_error_now ("Period required in format specifier at %L",
+			   &format_locus);
 	  else
-	    gfc_warning ("Period required in format specifier at %C");
+	    gfc_warning ("Period required in format specifier at %L",
+			 &format_locus);
 	  saved_token = u;
 	  break;
 	}
@@ -773,13 +797,18 @@ data_desc:
 	  goto syntax;
 	}
 
-      if (t == FMT_D)
-	break;
-
       /* Look for optional exponent.  */
       u = format_lex ();
       if (u == FMT_ERROR)
 	goto fail;
+
+      /* Optional exponent not allowed with D specifier.  */
+      if (t == FMT_D && u == FMT_E)
+	{
+	  error = _("Exponent width not allowed with D specifier");
+	  goto syntax;
+	}
+
       if (u != FMT_E)
 	{
 	  saved_token = u;
@@ -819,10 +848,15 @@ data_desc:
       if (t != FMT_PERIOD)
 	{
 	  /* Warn if -std=legacy, otherwise error.  */
+	  if (mode != MODE_FORMAT)
+	    format_locus.nextc += format_string_pos;
 	  if (gfc_option.warn_std != 0)
-	    gfc_error_now ("Period required in format specifier at %C");
-	  else
-	    gfc_warning ("Period required in format specifier at %C");
+	    {
+	      error = _("Period required in format specifier at %L");
+	      goto syntax;
+	    }
+	  gfc_warning ("Period required in format specifier at %L",
+		       &format_locus);
 	  saved_token = t;
 	  break;
 	}
@@ -840,8 +874,12 @@ data_desc:
 
     case FMT_H:
       if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
-	gfc_warning ("The H format specifier at %C is"
-		     " a Fortran 95 deleted feature");
+	{
+	  if (mode != MODE_FORMAT)
+	    format_locus.nextc += format_string_pos;
+	  gfc_warning ("The H format specifier at %L is"
+		       " a Fortran 95 deleted feature", &format_locus);
+	}
 
       if (mode == MODE_STRING)
 	{
@@ -891,7 +929,6 @@ data_desc:
 	      goto syntax;
 	    }
 	}
-
       break;
 
     default:
@@ -925,8 +962,10 @@ between_desc:
       goto syntax;
 
     default:
-      if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %C")
-	  == FAILURE)
+      if (mode != MODE_FORMAT)
+	format_locus.nextc += format_string_pos;
+      if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %L",
+	  &format_locus) == FAILURE)
 	return FAILURE;
       goto format_item_1;
     }
@@ -982,15 +1021,17 @@ extension_optional_comma:
       goto syntax;
 
     default:
-      if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %C")
-	  == FAILURE)
+      if (mode != MODE_FORMAT)
+	format_locus.nextc += format_string_pos;
+      if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %L",
+	  &format_locus) == FAILURE)
 	return FAILURE;
       saved_token = t;
       break;
     }
 
   goto format_item;
-
+  
 syntax:
   if (mode != MODE_FORMAT)
     format_locus.nextc += format_string_pos;
Index: libgfortran/io/io.h
===================================================================
--- libgfortran/io/io.h	(revision 150730)
+++ libgfortran/io/io.h	(working copy)
@@ -654,7 +654,7 @@ typedef enum
   FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
   FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
   FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
-  FMT_DP
+  FMT_DP, FMT_STAR
 }
 format_token;
 
Index: libgfortran/io/format.c
===================================================================
--- libgfortran/io/format.c	(revision 150730)
+++ libgfortran/io/format.c	(working copy)
@@ -313,6 +313,10 @@ format_lex (format_data *fmt)
 
   switch (c)
     {
+    case '*':
+       token = FMT_STAR;
+       break;
+
     case '(':
       token = FMT_LPAREN;
       break;
@@ -595,6 +599,21 @@ parse_format_list (st_parameter_dt *dtp, bool *sav
  format_item_1:
   switch (t)
     {
+    case FMT_STAR:
+      t = format_lex (fmt);
+      if (t != FMT_LPAREN)
+	{
+	  fmt->error = "Left parenthesis required after '*'";
+	  goto finished;
+	}
+      get_fnode (fmt, &head, &tail, FMT_LPAREN);
+      tail->repeat = -2;  /* Signifies unlimited format.  */
+      tail->u.child = parse_format_list (dtp, &saveit);
+      if (fmt->error != NULL)
+	goto finished;
+
+      goto between_desc;
+
     case FMT_POSINT:
       repeat = fmt->value;
 
@@ -1252,8 +1271,23 @@ next_format0 (fnode * f)
       return NULL;
     }
 
-  /* Deal with a parenthesis node */
+  /* Deal with a parenthesis node with unlimited format.  */
 
+  if (f->repeat == -2)  /* -2 signifies unlimited.  */
+  for (;;)
+    {
+      if (f->current == NULL)
+	f->current = f->u.child;
+
+      for (; f->current != NULL; f->current = f->current->next)
+	{
+	  r = next_format0 (f->current);
+	  if (r != NULL)
+	    return r;
+	}
+    }
+
+  /* Deal with a parenthesis node with specific repeat count.  */
   for (; f->count < f->repeat; f->count++)
     {
       if (f->current == NULL)

Attachment: unlimited_fmt_1.f08
Description: Text document