2010-01-15 Jerry DeLisle <jvdelisle@gcc.gnu.org>

[pf3gnuchains/gcc-fork.git] / libgfortran / io / format.c

diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
index e40adb9..13516d2 100644 (file)
--- a/libgfortran/io/format.c
+++ b/libgfortran/io/format.c
@@ -29,6 +29,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  * interpretation during I/O statements */
 
 #include "io.h"
+#include "format.h"
 #include <ctype.h>
 #include <string.h>
 #include <stdbool.h>
@@ -313,6 +314,10 @@ format_lex (format_data *fmt)
 
   switch (c)
     {
+    case '*':
+       token = FMT_STAR;
+       break;
+
     case '(':
       token = FMT_LPAREN;
       break;
@@ -560,6 +565,34 @@ format_lex (format_data *fmt)
        }
       break;
 
+    case 'R':
+      switch (next_char (fmt, 0))
+       {
+       case 'C':
+         token = FMT_RC;
+         break;
+       case 'D':
+         token = FMT_RD;
+         break;
+       case 'N':
+         token = FMT_RN;
+         break;
+       case 'P':
+         token = FMT_RP;
+         break;
+       case 'U':
+         token = FMT_RU;
+         break;
+       case 'Z':
+         token = FMT_RZ;
+         break;
+       default:
+         unget_char (fmt);
+         token = FMT_UNKNOWN;
+         break;
+       }
+      break;
+
     case -1:
       token = FMT_END;
       break;
@@ -595,6 +628,21 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok)
  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;
 
@@ -659,6 +707,13 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok)
          goto data_desc;
        }
 
+      if (t != FMT_COMMA && t != FMT_RPAREN && t != FMT_SLASH
+         && t != FMT_POSINT)
+       {
+         fmt->error = "Comma required after P descriptor";
+         goto finished;
+       }
+
       fmt->saved_token = t;
       goto optional_comma;
 
@@ -687,13 +742,25 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok)
       goto between_desc;
 
     case FMT_STRING:
-      /* TODO: Find out why is is necessary to turn off format caching.  */
+      /* TODO: Find out why it 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;
       goto optional_comma;
+      
+    case FMT_RC:
+    case FMT_RD:
+    case FMT_RN:
+    case FMT_RP:
+    case FMT_RU:
+    case FMT_RZ:
+      notify_std (&dtp->common, GFC_STD_F2003, "Fortran 2003: Round "
+                 "descriptor not allowed");
+      get_fnode (fmt, &head, &tail, t);
+      tail->repeat = 1;
+      goto between_desc;
 
     case FMT_DC:
     case FMT_DP:
@@ -792,19 +859,6 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok)
  data_desc:
   switch (t)
     {
-    case FMT_P:
-      t = format_lex (fmt);
-      if (t == FMT_POSINT)
-       {
-         fmt->error = "Repeat count cannot follow P descriptor";
-         goto finished;
-       }
-
-      fmt->saved_token = t;
-      get_fnode (fmt, &head, &tail, FMT_P);
-
-      goto optional_comma;
-
     case FMT_L:
       t = format_lex (fmt);
       if (t != FMT_POSINT)
@@ -881,7 +935,7 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok)
          tail->u.real.d = fmt->value;
          break;
        }
-      if (t == FMT_F || dtp->u.p.mode == WRITING)
+      if (t == FMT_F && dtp->u.p.mode == WRITING)
        {
          if (u != FMT_POSINT && u != FMT_ZERO)
            {
@@ -889,13 +943,10 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok)
              goto finished;
            }
        }
-      else
+      else if (u != FMT_POSINT)
        {
-         if (u != FMT_POSINT)
-           {
-             fmt->error = posint_required;
-             goto finished;
-           }
+         fmt->error = posint_required;
+         goto finished;
        }
 
       tail->u.real.w = fmt->value;
@@ -912,6 +963,7 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok)
            }
          fmt->saved_token = t;
          tail->u.real.d = 0;
+         tail->u.real.e = -1;
          break;
        }
 
@@ -923,11 +975,11 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok)
        }
 
       tail->u.real.d = fmt->value;
+      tail->u.real.e = -1;
 
-      if (t == FMT_D || t == FMT_F)
+      if (t2 == FMT_D || t2 == FMT_F)
        break;
 
-      tail->u.real.e = -1;
 
       /* Look for optional exponent */
       t = format_lex (fmt);
@@ -1160,13 +1212,18 @@ revert (st_parameter_dt *dtp)
 
 /* parse_format()-- Parse a format string.  */
 
+#define FORMAT_CACHE_STRING_LIMIT 256
+
 void
 parse_format (st_parameter_dt *dtp)
 {
   format_data *fmt;
   bool format_cache_ok;
 
-  format_cache_ok = !is_internal_unit (dtp);
+  /* Don't cache for internal units and set an arbitrary limit on the size of
+     format strings we will cache.  (Avoids memory issues.)  */
+  format_cache_ok = !is_internal_unit (dtp)
+                   && (dtp->format_len < FORMAT_CACHE_STRING_LIMIT );
 
   /* Lookup format string to see if it has already been parsed.  */
   if (format_cache_ok)
@@ -1252,8 +1309,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)