X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=libgfortran%2Fio%2Fformat.c;h=7e46e3a25df58456f2a972bf02af9e139af98ad9;hp=0f7a2e5bb842696fd6801b64a2b0763811150798;hb=be17d6bf45428b429e7c0751ef3c8660e43330c3;hpb=18f0b7df705aaa6f409645ea592934f2525e6333

diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
index 0f7a2e5bb84..7e46e3a25df 100644
--- a/libgfortran/io/format.c
+++ b/libgfortran/io/format.c
@@ -1,32 +1,28 @@
-/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
+/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
+   F2003 I/O support contributed by Jerry DeLisle
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
 
 Libgfortran is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
+the Free Software Foundation; either version 3, or (at your option)
 any later version.
 
-In addition to the permissions in the GNU General Public License, the
-Free Software Foundation gives you unlimited permission to link the
-compiled version of this file into combinations with other programs,
-and to distribute those combinations without any restriction coming
-from the use of this file.  (The General Public License restrictions
-do apply in other respects; for example, they cover modification of
-the file, and distribution when not linked into a combine
-executable.)
-
 Libgfortran is distributed in the hope that it will be useful,
 but WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 GNU General Public License for more details.
 
-You should have received a copy of the GNU General Public License
-along with Libgfortran; see the file COPYING.  If not, write to
-the Free Software Foundation, 51 Franklin Street, Fifth Floor,
-Boston, MA 02110-1301, USA.  */
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
 
 
 /* format.c-- parse a FORMAT string into a binary format suitable for
@@ -35,6 +31,7 @@ Boston, MA 02110-1301, USA.  */
 #include "io.h"
 #include <ctype.h>
 #include <string.h>
+#include <stdbool.h>
 
 #define FARRAY_SIZE 64
 
@@ -49,6 +46,7 @@ typedef struct format_data
 {
   char *format_string, *string;
   const char *error;
+  char error_element;
   format_token saved_token;
   int value, format_string_len, reversion_ok;
   fnode *avail;
@@ -61,16 +59,148 @@ format_data;
 static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
 				  NULL };
 
-/* Error messages */
+/* Error messages. */
 
 static const char posint_required[] = "Positive width required in format",
   period_required[] = "Period required in format",
   nonneg_required[] = "Nonnegative width required in format",
-  unexpected_element[] = "Unexpected element in format",
+  unexpected_element[] = "Unexpected element '%c' in format\n",
   unexpected_end[] = "Unexpected end of format string",
   bad_string[] = "Unterminated character constant in format",
   bad_hollerith[] = "Hollerith constant extends past the end of the format",
-  reversion_error[] = "Exhausted data descriptors in format";
+  reversion_error[] = "Exhausted data descriptors in format",
+  zero_width[] = "Zero width in format descriptor";
+
+/* The following routines support caching format data from parsed format strings
+   into a hash table.  This avoids repeatedly parsing duplicate format strings
+   or format strings in I/O statements that are repeated in loops.  */
+
+
+/* Traverse the table and free all data.  */
+
+void
+free_format_hash_table (gfc_unit *u)
+{
+  size_t i;
+
+  /* free_format_data handles any NULL pointers.  */
+  for (i = 0; i < FORMAT_HASH_SIZE; i++)
+    {
+      if (u->format_hash_table[i].hashed_fmt != NULL)
+	{
+	  free_format_data (u->format_hash_table[i].hashed_fmt);
+	  free_mem (u->format_hash_table[i].key);
+	}
+      u->format_hash_table[i].key = NULL;
+      u->format_hash_table[i].key_len = 0;      
+      u->format_hash_table[i].hashed_fmt = NULL;
+    }
+}
+
+/* Traverse the format_data structure and reset the fnode counters.  */
+
+static void
+reset_node (fnode *fn)
+{
+  fnode *f;
+
+  fn->count = 0;
+  fn->current = NULL;
+  
+  if (fn->format != FMT_LPAREN)
+    return;
+
+  for (f = fn->u.child; f; f = f->next)
+    {
+      if (f->format == FMT_RPAREN)
+	break;
+      reset_node (f);
+    }
+}
+
+static void
+reset_fnode_counters (st_parameter_dt *dtp)
+{
+  fnode *f;
+  format_data *fmt;
+
+  fmt = dtp->u.p.fmt;
+
+  /* Clear this pointer at the head so things start at the right place.  */
+  fmt->array.array[0].current = NULL;
+
+  for (f = fmt->last->array[0].u.child; f; f = f->next)
+    reset_node (f);
+}
+
+
+/* A simple hashing function to generate an index into the hash table.  */
+
+static inline
+uint32_t format_hash (st_parameter_dt *dtp)
+{
+  char *key;
+  gfc_charlen_type key_len;
+  uint32_t hash = 0;
+  gfc_charlen_type i;
+
+  /* Hash the format string. Super simple, but what the heck!  */
+  key = dtp->format;
+  key_len = dtp->format_len;
+  for (i = 0; i < key_len; i++)
+    hash ^= key[i];
+  hash &= (FORMAT_HASH_SIZE - 1);
+  return hash;
+}
+
+
+static void
+save_parsed_format (st_parameter_dt *dtp)
+{
+  uint32_t hash;
+  gfc_unit *u;
+
+  hash = format_hash (dtp);
+  u = dtp->u.p.current_unit;
+
+  /* Index into the hash table.  We are simply replacing whatever is there
+     relying on probability.  */
+  if (u->format_hash_table[hash].hashed_fmt != NULL)
+    free_format_data (u->format_hash_table[hash].hashed_fmt);
+  u->format_hash_table[hash].hashed_fmt = NULL;
+
+  if (u->format_hash_table[hash].key != NULL)
+    free_mem (u->format_hash_table[hash].key);
+  u->format_hash_table[hash].key = get_mem (dtp->format_len);
+  memcpy (u->format_hash_table[hash].key, dtp->format, dtp->format_len);
+
+  u->format_hash_table[hash].key_len = dtp->format_len;
+  u->format_hash_table[hash].hashed_fmt = dtp->u.p.fmt;
+}
+
+
+static format_data *
+find_parsed_format (st_parameter_dt *dtp)
+{
+  uint32_t hash;
+  gfc_unit *u;
+
+  hash = format_hash (dtp);
+  u = dtp->u.p.current_unit;
+
+  if (u->format_hash_table[hash].key != NULL)
+    {
+      /* See if it matches.  */
+      if (u->format_hash_table[hash].key_len == dtp->format_len)
+	{
+	  /* So far so good.  */
+	  if (strncmp (u->format_hash_table[hash].key,
+	      dtp->format, dtp->format_len) == 0)
+	    return u->format_hash_table[hash].hashed_fmt;
+	}
+    }
+  return NULL;
+}
 
 
 /* next_char()-- Return the next character in the format string.
@@ -89,6 +219,7 @@ next_char (format_data *fmt, int literal)
 
       fmt->format_string_len--;
       c = toupper (*fmt->format_string++);
+      fmt->error_element = c;
     }
   while ((c == ' ' || c == '\t') && !literal);
 
@@ -139,10 +270,10 @@ get_fnode (format_data *fmt, fnode **head, fnode **tail, format_token t)
 /* free_format_data()-- Free all allocated format data.  */
 
 void
-free_format_data (st_parameter_dt *dtp)
+free_format_data (format_data *fmt)
 {
   fnode_array *fa, *fa_next;
-  format_data *fmt = dtp->u.p.fmt;
+
 
   if (fmt == NULL)
     return;
@@ -154,7 +285,7 @@ free_format_data (st_parameter_dt *dtp)
     }
 
   free_mem (fmt);
-  dtp->u.p.fmt = NULL;
+  fmt = NULL;
 }
 
 
@@ -182,6 +313,18 @@ format_lex (format_data *fmt)
 
   switch (c)
     {
+    case '*':
+       token = FMT_STAR;
+       break;
+
+    case '(':
+      token = FMT_LPAREN;
+      break;
+
+    case ')':
+      token = FMT_RPAREN;
+      break;
+
     case '-':
       negative_flag = 1;
       /* Fall Through */
@@ -274,14 +417,6 @@ format_lex (format_data *fmt)
 
       break;
 
-    case '(':
-      token = FMT_LPAREN;
-      break;
-
-    case ')':
-      token = FMT_RPAREN;
-      break;
-
     case 'X':
       token = FMT_X;
       break;
@@ -395,7 +530,6 @@ format_lex (format_data *fmt)
 	  unget_char (fmt);
 	  break;
 	}
-
       break;
 
     case 'G':
@@ -415,7 +549,47 @@ format_lex (format_data *fmt)
       break;
 
     case 'D':
-      token = FMT_D;
+      switch (next_char (fmt, 0))
+	{
+	case 'P':
+	  token = FMT_DP;
+	  break;
+	case 'C':
+	  token = FMT_DC;
+	  break;
+	default:
+	  token = FMT_D;
+	  unget_char (fmt);
+	  break;
+	}
+      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:
@@ -436,14 +610,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 saveit;
 
   head = tail = NULL;
+  saveit = *save_ok;
 
   /* Get the next format item */
  format_item:
@@ -451,6 +627,21 @@ parse_format_list (st_parameter_dt *dtp)
  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;
 
@@ -460,7 +651,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;
 
@@ -487,7 +678,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;
 
@@ -515,6 +706,12 @@ parse_format_list (st_parameter_dt *dtp)
 	  goto data_desc;
 	}
 
+      if (t != FMT_COMMA && t != FMT_RPAREN && t != FMT_SLASH)
+	{
+	  fmt->error = "Comma required after P descriptor";
+	  goto finished;
+	}
+
       fmt->saved_token = t;
       goto optional_comma;
 
@@ -543,13 +740,31 @@ parse_format_list (st_parameter_dt *dtp)
       goto between_desc;
 
     case FMT_STRING:
+      /* 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:
+      notify_std (&dtp->common, GFC_STD_F2003, "Fortran 2003: DC or DP "
+		  "descriptor not allowed");
+    /* Fall through.  */
     case FMT_S:
     case FMT_SS:
     case FMT_SP:
@@ -607,7 +822,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;
@@ -643,19 +857,6 @@ parse_format_list (st_parameter_dt *dtp)
  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)
@@ -680,6 +881,12 @@ parse_format_list (st_parameter_dt *dtp)
 
     case FMT_A:
       t = format_lex (fmt);
+      if (t == FMT_ZERO)
+	{
+	  fmt->error = zero_width;
+	  goto finished;
+	}
+
       if (t != FMT_POSINT)
 	{
 	  fmt->saved_token = t;
@@ -701,6 +908,31 @@ parse_format_list (st_parameter_dt *dtp)
       tail->repeat = repeat;
 
       u = format_lex (fmt);
+      if (t == FMT_G && u == FMT_ZERO)
+	{
+	  if (notification_std (GFC_STD_F2008) == ERROR
+	      || dtp->u.p.mode == READING)
+	    {
+	      fmt->error = zero_width;
+	      goto finished;
+	    }
+	  tail->u.real.w = 0;
+	  u = format_lex (fmt);
+	  if (u != FMT_PERIOD)
+	    {
+	      fmt->saved_token = u;
+	      break;
+	    }
+
+	  u = format_lex (fmt);
+	  if (u != FMT_POSINT)
+	    {
+	      fmt->error = posint_required;
+	      goto finished;
+	    }
+	  tail->u.real.d = fmt->value;
+	  break;
+	}
       if (t == FMT_F || dtp->u.p.mode == WRITING)
 	{
 	  if (u != FMT_POSINT && u != FMT_ZERO)
@@ -732,6 +964,7 @@ parse_format_list (st_parameter_dt *dtp)
 	    }
 	  fmt->saved_token = t;
 	  tail->u.real.d = 0;
+	  tail->u.real.e = -1;
 	  break;
 	}
 
@@ -743,11 +976,11 @@ parse_format_list (st_parameter_dt *dtp)
 	}
 
       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);
@@ -775,7 +1008,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;
@@ -890,6 +1122,9 @@ parse_format_list (st_parameter_dt *dtp)
   goto format_item;
 
  finished:
+
+  *save_ok = saveit;
+  
   return head;
 }
 
@@ -913,7 +1148,10 @@ format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
   if (f != NULL)
     fmt->format_string = f->source;
 
-  sprintf (buffer, "%s\n", message);
+  if (message == unexpected_element)
+    sprintf (buffer, message, fmt->error_element);
+  else
+    sprintf (buffer, "%s\n", message);
 
   j = fmt->format_string - dtp->format;
 
@@ -946,12 +1184,59 @@ format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
 }
 
 
+/* revert()-- Do reversion of the format.  Control reverts to the left
+ * parenthesis that matches the rightmost right parenthesis.  From our
+ * tree structure, we are looking for the rightmost parenthesis node
+ * at the second level, the first level always being a single
+ * parenthesis node.  If this node doesn't exit, we use the top
+ * level. */
+
+static void
+revert (st_parameter_dt *dtp)
+{
+  fnode *f, *r;
+  format_data *fmt = dtp->u.p.fmt;
+
+  dtp->u.p.reversion_flag = 1;
+
+  r = NULL;
+
+  for (f = fmt->array.array[0].u.child; f; f = f->next)
+    if (f->format == FMT_LPAREN)
+      r = f;
+
+  /* If r is NULL because no node was found, the whole tree will be used */
+
+  fmt->array.array[0].current = r;
+  fmt->array.array[0].count = 0;
+}
+
 /* parse_format()-- Parse a format string.  */
 
 void
 parse_format (st_parameter_dt *dtp)
 {
   format_data *fmt;
+  bool format_cache_ok;
+
+  format_cache_ok = !is_internal_unit (dtp);
+
+  /* Lookup format string to see if it has already been parsed.  */
+  if (format_cache_ok)
+    {
+      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.  */
 
   dtp->u.p.fmt = fmt = get_mem (sizeof (format_data));
   fmt->format_string = dtp->format;
@@ -962,12 +1247,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;
@@ -979,40 +1264,21 @@ 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";
 
   if (fmt->error)
-    format_error (dtp, NULL, fmt->error);
-}
-
-
-/* revert()-- Do reversion of the format.  Control reverts to the left
- * parenthesis that matches the rightmost right parenthesis.  From our
- * tree structure, we are looking for the rightmost parenthesis node
- * at the second level, the first level always being a single
- * parenthesis node.  If this node doesn't exit, we use the top
- * level. */
-
-static void
-revert (st_parameter_dt *dtp)
-{
-  fnode *f, *r;
-  format_data *fmt = dtp->u.p.fmt;
-
-  dtp->u.p.reversion_flag = 1;
-
-  r = NULL;
-
-  for (f = fmt->array.array[0].u.child; f; f = f->next)
-    if (f->format == FMT_LPAREN)
-      r = f;
-
-  /* If r is NULL because no node was found, the whole tree will be used */
+    {
+      format_error (dtp, NULL, fmt->error);
+      free_format_hash_table (dtp->u.p.current_unit);
+      return;
+    }
 
-  fmt->array.array[0].current = r;
-  fmt->array.array[0].count = 0;
+  if (format_cache_ok)
+    save_parsed_format (dtp);
+  else
+    dtp->u.p.format_not_saved = 1;
 }
 
 
@@ -1039,8 +1305,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)
@@ -1061,7 +1342,7 @@ next_format0 (fnode * f)
 
 /* next_format()-- Return the next format node.  If the format list
  * ends up being exhausted, we do reversion.  Reversion is only
- * allowed if the we've seen a data descriptor since the
+ * allowed if we've seen a data descriptor since the
  * initialization or the last reversion.  We return NULL if there
  * are no more data descriptors to return (which is an error
  * condition). */