X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=libgfortran%2Fio%2Fformat.c;h=4ab70e8c3adc4662984a0f28afb057c9b09537d1;hb=1fc8cb4337139f3aafcb14052788dd2d4613d3c8;hp=db5e0fe7372170aa63f31267722247027b28423a;hpb=b417ea8c5d4118ac4ba24787c9b3a5b3a82f0c86;p=pf3gnuchains%2Fgcc-fork.git
diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
index db5e0fe7372..4ab70e8c3ad 100644
--- a/libgfortran/io/format.c
+++ b/libgfortran/io/format.c
@@ -1,71 +1,206 @@
-/* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+/* 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, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, 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
+. */
/* format.c-- parse a FORMAT string into a binary format suitable for
* interpretation during I/O statements */
-#include "config.h"
+#include "io.h"
#include
#include
-#include "libgfortran.h"
-#include "io.h"
-
-
+#include
-/* Number of format nodes that we can store statically before we have
- * to resort to dynamic allocation. The root node is array[0]. */
+#define FARRAY_SIZE 64
-#define FARRAY_SIZE 200
-
-static fnode *avail, array[FARRAY_SIZE];
-
-/* Local variables for checking format strings. The saved_token is
- * used to back up by a single format token during the parsing process. */
+typedef struct fnode_array
+{
+ struct fnode_array *next;
+ fnode array[FARRAY_SIZE];
+}
+fnode_array;
-static char *format_string, *string;
-static const char *error;
-static format_token saved_token;
-static int value, format_string_len, reversion_ok;
+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;
+ const fnode *saved_format;
+ fnode_array *last;
+ fnode_array array;
+}
+format_data;
-static fnode *saved_format, colon_node = { FMT_COLON };
+static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
+ NULL };
-/* Error messages */
+/* Error messages. */
-static char posint_required[] = "Positive width required in format",
+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.
@@ -73,19 +208,20 @@ static char posint_required[] = "Positive width required in format",
* spaces are significant, otherwise they are not. */
static int
-next_char (int literal)
+next_char (format_data *fmt, int literal)
{
int c;
do
{
- if (format_string_len == 0)
+ if (fmt->format_string_len == 0)
return -1;
- format_string_len--;
- c = toupper (*format_string++);
+ fmt->format_string_len--;
+ c = toupper (*fmt->format_string++);
+ fmt->error_element = c;
}
- while (c == ' ' && !literal);
+ while ((c == ' ' || c == '\t') && !literal);
return c;
}
@@ -93,7 +229,8 @@ next_char (int literal)
/* unget_char()-- Back up one character position. */
-#define unget_char() { format_string--; format_string_len++; }
+#define unget_char(fmt) \
+ { fmt->format_string--; fmt->format_string_len++; }
/* get_fnode()-- Allocate a new format node, inserting it into the
@@ -101,17 +238,19 @@ next_char (int literal)
* static buffer. */
static fnode *
-get_fnode (fnode ** head, fnode ** tail, format_token t)
+get_fnode (format_data *fmt, fnode **head, fnode **tail, format_token t)
{
fnode *f;
- if (avail - array >= FARRAY_SIZE)
- f = get_mem (sizeof (fnode));
- else
+ if (fmt->avail == &fmt->last->array[FARRAY_SIZE])
{
- f = avail++;
- memset (f, '\0', sizeof (fnode));
+ fmt->last->next = get_mem (sizeof (fnode_array));
+ fmt->last = fmt->last->next;
+ fmt->last->next = NULL;
+ fmt->avail = &fmt->last->array[0];
}
+ f = fmt->avail++;
+ memset (f, '\0', sizeof (fnode));
if (*head == NULL)
*head = *tail = f;
@@ -123,97 +262,96 @@ get_fnode (fnode ** head, fnode ** tail, format_token t)
f->format = t;
f->repeat = -1;
- f->source = format_string;
+ f->source = fmt->format_string;
return f;
}
-/* free_fnode()-- Recursive function to free the given fnode and
- * everything it points to. We only have to actually free something
- * if it is outside of the static array. */
+/* free_format_data()-- Free all allocated format data. */
-static void
-free_fnode (fnode * f)
+void
+free_format_data (format_data *fmt)
{
- fnode *next;
+ fnode_array *fa, *fa_next;
- for (; f; f = next)
- {
- next = f->next;
-
- if (f->format == FMT_LPAREN)
- free_fnode (f->u.child);
- if (f < array || f >= array + FARRAY_SIZE)
- free_mem (f);
- }
-}
+ if (fmt == NULL)
+ return;
-/* free_fnodes()-- Free the current tree of fnodes. We only have to
- * traverse the tree if some nodes were allocated dynamically. */
-
-void
-free_fnodes (void)
-{
- if (avail - array >= FARRAY_SIZE)
- free_fnode (&array[0]);
+ for (fa = fmt->array.next; fa; fa = fa_next)
+ {
+ fa_next = fa->next;
+ free_mem (fa);
+ }
- avail = array;
- memset(array, 0, sizeof(avail[0]) * FARRAY_SIZE);
+ free_mem (fmt);
+ fmt = NULL;
}
/* format_lex()-- Simple lexical analyzer for getting the next token
* in a FORMAT string. We support a one-level token pushback in the
- * saved_token variable. */
+ * fmt->saved_token variable. */
static format_token
-format_lex (void)
+format_lex (format_data *fmt)
{
format_token token;
int negative_flag;
int c;
char delim;
- if (saved_token != FMT_NONE)
+ if (fmt->saved_token != FMT_NONE)
{
- token = saved_token;
- saved_token = FMT_NONE;
+ token = fmt->saved_token;
+ fmt->saved_token = FMT_NONE;
return token;
}
negative_flag = 0;
- c = next_char (0);
+ c = next_char (fmt, 0);
switch (c)
{
+ case '*':
+ token = FMT_STAR;
+ break;
+
+ case '(':
+ token = FMT_LPAREN;
+ break;
+
+ case ')':
+ token = FMT_RPAREN;
+ break;
+
case '-':
negative_flag = 1;
/* Fall Through */
case '+':
- c = next_char (0);
+ c = next_char (fmt, 0);
if (!isdigit (c))
{
token = FMT_UNKNOWN;
break;
}
- value = c - '0';
+ fmt->value = c - '0';
for (;;)
{
- c = next_char (0);
+ c = next_char (fmt, 0);
if (!isdigit (c))
break;
- value = 10 * value + c - '0';
+ fmt->value = 10 * fmt->value + c - '0';
}
- unget_char ();
+ unget_char (fmt);
if (negative_flag)
- value = -value;
+ fmt->value = -fmt->value;
token = FMT_SIGNED_INT;
break;
@@ -227,19 +365,19 @@ format_lex (void)
case '7':
case '8':
case '9':
- value = c - '0';
+ fmt->value = c - '0';
for (;;)
{
- c = next_char (0);
+ c = next_char (fmt, 0);
if (!isdigit (c))
break;
- value = 10 * value + c - '0';
+ fmt->value = 10 * fmt->value + c - '0';
}
- unget_char ();
- token = (value == 0) ? FMT_ZERO : FMT_POSINT;
+ unget_char (fmt);
+ token = (fmt->value == 0) ? FMT_ZERO : FMT_POSINT;
break;
case '.':
@@ -263,7 +401,7 @@ format_lex (void)
break;
case 'T':
- switch (next_char (0))
+ switch (next_char (fmt, 0))
{
case 'L':
token = FMT_TL;
@@ -273,26 +411,18 @@ format_lex (void)
break;
default:
token = FMT_T;
- unget_char ();
+ unget_char (fmt);
break;
}
break;
- case '(':
- token = FMT_LPAREN;
- break;
-
- case ')':
- token = FMT_RPAREN;
- break;
-
case 'X':
token = FMT_X;
break;
case 'S':
- switch (next_char (0))
+ switch (next_char (fmt, 0))
{
case 'S':
token = FMT_SS;
@@ -302,14 +432,14 @@ format_lex (void)
break;
default:
token = FMT_S;
- unget_char ();
+ unget_char (fmt);
break;
}
break;
case 'B':
- switch (next_char (0))
+ switch (next_char (fmt, 0))
{
case 'N':
token = FMT_BN;
@@ -319,7 +449,7 @@ format_lex (void)
break;
default:
token = FMT_B;
- unget_char ();
+ unget_char (fmt);
break;
}
@@ -329,39 +459,39 @@ format_lex (void)
case '"':
delim = c;
- string = format_string;
- value = 0; /* This is the length of the string */
+ fmt->string = fmt->format_string;
+ fmt->value = 0; /* This is the length of the string */
for (;;)
{
- c = next_char (1);
+ c = next_char (fmt, 1);
if (c == -1)
{
token = FMT_BADSTRING;
- error = bad_string;
+ fmt->error = bad_string;
break;
}
if (c == delim)
{
- c = next_char (1);
+ c = next_char (fmt, 1);
if (c == -1)
{
token = FMT_BADSTRING;
- error = bad_string;
+ fmt->error = bad_string;
break;
}
if (c != delim)
{
- unget_char ();
+ unget_char (fmt);
token = FMT_STRING;
break;
}
}
- value++;
+ fmt->value++;
}
break;
@@ -387,7 +517,7 @@ format_lex (void)
break;
case 'E':
- switch (next_char (0))
+ switch (next_char (fmt, 0))
{
case 'N':
token = FMT_EN;
@@ -397,10 +527,9 @@ format_lex (void)
break;
default:
token = FMT_E;
- unget_char ();
+ unget_char (fmt);
break;
}
-
break;
case 'G':
@@ -420,7 +549,47 @@ format_lex (void)
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:
@@ -441,43 +610,62 @@ format_lex (void)
* parenthesis node which contains the rest of the list. */
static fnode *
-parse_format_list (void)
+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:
- t = format_lex ();
+ t = format_lex (fmt);
+ 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 = value;
+ repeat = fmt->value;
- t = format_lex ();
+ t = format_lex (fmt);
switch (t)
{
case FMT_LPAREN:
- get_fnode (&head, &tail, FMT_LPAREN);
+ get_fnode (fmt, &head, &tail, FMT_LPAREN);
tail->repeat = repeat;
- tail->u.child = parse_format_list ();
- if (error != NULL)
+ tail->u.child = parse_format_list (dtp, &saveit);
+ if (fmt->error != NULL)
goto finished;
goto between_desc;
case FMT_SLASH:
- get_fnode (&head, &tail, FMT_SLASH);
+ get_fnode (fmt, &head, &tail, FMT_SLASH);
tail->repeat = repeat;
goto optional_comma;
case FMT_X:
- get_fnode (&head, &tail, FMT_X);
+ get_fnode (fmt, &head, &tail, FMT_X);
tail->repeat = 1;
- tail->u.k = value;
+ tail->u.k = fmt->value;
goto between_desc;
case FMT_P:
@@ -488,29 +676,29 @@ parse_format_list (void)
}
case FMT_LPAREN:
- get_fnode (&head, &tail, FMT_LPAREN);
+ get_fnode (fmt, &head, &tail, FMT_LPAREN);
tail->repeat = 1;
- tail->u.child = parse_format_list ();
- if (error != NULL)
+ tail->u.child = parse_format_list (dtp, &saveit);
+ if (fmt->error != NULL)
goto finished;
goto between_desc;
case FMT_SIGNED_INT: /* Signed integer can only precede a P format. */
case FMT_ZERO: /* Same for zero. */
- t = format_lex ();
+ t = format_lex (fmt);
if (t != FMT_P)
{
- error = "Expected P edit descriptor in format";
+ fmt->error = "Expected P edit descriptor in format";
goto finished;
}
p_descriptor:
- get_fnode (&head, &tail, FMT_P);
- tail->u.k = value;
+ get_fnode (fmt, &head, &tail, FMT_P);
+ tail->u.k = fmt->value;
tail->repeat = 1;
- t = format_lex ();
+ t = format_lex (fmt);
if (t == FMT_F || t == FMT_EN || t == FMT_ES || t == FMT_D
|| t == FMT_G || t == FMT_E)
{
@@ -518,11 +706,11 @@ parse_format_list (void)
goto data_desc;
}
- saved_token = t;
+ fmt->saved_token = t;
goto optional_comma;
case FMT_P: /* P and X require a prior number */
- error = "P descriptor requires leading scale factor";
+ fmt->error = "P descriptor requires leading scale factor";
goto finished;
case FMT_X:
@@ -532,7 +720,7 @@ parse_format_list (void)
If we would be pedantic in the library, we would have to reject
an X descriptor without an integer prefix:
- error = "X descriptor requires leading space count";
+ fmt->error = "X descriptor requires leading space count";
goto finished;
However, this is an extension supported by many Fortran compilers,
@@ -540,53 +728,74 @@ parse_format_list (void)
runtime library, and make the front end reject it if the compiler
is in pedantic mode. The interpretation of 'X' is '1X'.
*/
- get_fnode (&head, &tail, FMT_X);
+ get_fnode (fmt, &head, &tail, FMT_X);
tail->repeat = 1;
tail->u.k = 1;
goto between_desc;
case FMT_STRING:
- get_fnode (&head, &tail, FMT_STRING);
-
- tail->u.string.p = string;
- tail->u.string.length = value;
+ /* 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;
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:
case FMT_BN:
case FMT_BZ:
- get_fnode (&head, &tail, t);
+ get_fnode (fmt, &head, &tail, t);
tail->repeat = 1;
goto between_desc;
case FMT_COLON:
- get_fnode (&head, &tail, FMT_COLON);
+ get_fnode (fmt, &head, &tail, FMT_COLON);
+ tail->repeat = 1;
goto optional_comma;
case FMT_SLASH:
- get_fnode (&head, &tail, FMT_SLASH);
+ get_fnode (fmt, &head, &tail, FMT_SLASH);
tail->repeat = 1;
tail->u.r = 1;
goto optional_comma;
case FMT_DOLLAR:
- get_fnode (&head, &tail, FMT_DOLLAR);
+ get_fnode (fmt, &head, &tail, FMT_DOLLAR);
+ tail->repeat = 1;
+ notify_std (&dtp->common, GFC_STD_GNU, "Extension: $ descriptor");
goto between_desc;
case FMT_T:
case FMT_TL:
case FMT_TR:
- t2 = format_lex ();
+ t2 = format_lex (fmt);
if (t2 != FMT_POSINT)
{
- error = posint_required;
+ fmt->error = posint_required;
goto finished;
}
- get_fnode (&head, &tail, t);
- tail->u.n = value;
+ get_fnode (fmt, &head, &tail, t);
+ tail->u.n = fmt->value;
tail->repeat = 1;
goto between_desc;
@@ -606,25 +815,24 @@ parse_format_list (void)
goto data_desc;
case FMT_H:
- get_fnode (&head, &tail, FMT_STRING);
-
- if (format_string_len < 1)
+ get_fnode (fmt, &head, &tail, FMT_STRING);
+ if (fmt->format_string_len < 1)
{
- error = bad_hollerith;
+ fmt->error = bad_hollerith;
goto finished;
}
- tail->u.string.p = format_string;
+ tail->u.string.p = fmt->format_string;
tail->u.string.length = 1;
tail->repeat = 1;
- format_string++;
- format_string_len--;
+ fmt->format_string++;
+ fmt->format_string_len--;
goto between_desc;
case FMT_END:
- error = unexpected_end;
+ fmt->error = unexpected_end;
goto finished;
case FMT_BADSTRING:
@@ -634,7 +842,7 @@ parse_format_list (void)
goto finished;
default:
- error = unexpected_element;
+ fmt->error = unexpected_element;
goto finished;
}
@@ -644,42 +852,57 @@ parse_format_list (void)
switch (t)
{
case FMT_P:
- t = format_lex ();
+ t = format_lex (fmt);
if (t == FMT_POSINT)
{
- error = "Repeat count cannot follow P descriptor";
+ fmt->error = "Repeat count cannot follow P descriptor";
goto finished;
}
- saved_token = t;
- get_fnode (&head, &tail, FMT_P);
+ fmt->saved_token = t;
+ get_fnode (fmt, &head, &tail, FMT_P);
goto optional_comma;
case FMT_L:
- t = format_lex ();
+ t = format_lex (fmt);
if (t != FMT_POSINT)
{
- error = posint_required;
- goto finished;
+ if (notification_std(GFC_STD_GNU) == ERROR)
+ {
+ fmt->error = posint_required;
+ goto finished;
+ }
+ else
+ {
+ fmt->saved_token = t;
+ fmt->value = 1; /* Default width */
+ notify_std (&dtp->common, GFC_STD_GNU, posint_required);
+ }
}
- get_fnode (&head, &tail, FMT_L);
- tail->u.n = value;
+ get_fnode (fmt, &head, &tail, FMT_L);
+ tail->u.n = fmt->value;
tail->repeat = repeat;
break;
case FMT_A:
- t = format_lex ();
+ t = format_lex (fmt);
+ if (t == FMT_ZERO)
+ {
+ fmt->error = zero_width;
+ goto finished;
+ }
+
if (t != FMT_POSINT)
{
- saved_token = t;
- value = -1; /* Width not present */
+ fmt->saved_token = t;
+ fmt->value = -1; /* Width not present */
}
- get_fnode (&head, &tail, FMT_A);
+ get_fnode (fmt, &head, &tail, FMT_A);
tail->repeat = repeat;
- tail->u.n = value;
+ tail->u.n = fmt->value;
break;
case FMT_D:
@@ -688,15 +911,40 @@ parse_format_list (void)
case FMT_G:
case FMT_EN:
case FMT_ES:
- get_fnode (&head, &tail, t);
+ get_fnode (fmt, &head, &tail, t);
tail->repeat = repeat;
- u = format_lex ();
- if (t == FMT_F || g.mode == WRITING)
+ 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)
{
- error = nonneg_required;
+ fmt->error = nonneg_required;
goto finished;
}
}
@@ -704,28 +952,36 @@ parse_format_list (void)
{
if (u != FMT_POSINT)
{
- error = posint_required;
+ fmt->error = posint_required;
goto finished;
}
}
- tail->u.real.w = value;
+ tail->u.real.w = fmt->value;
t2 = t;
- t = format_lex ();
+ t = format_lex (fmt);
if (t != FMT_PERIOD)
{
- error = period_required;
- goto finished;
+ /* We treat a missing decimal descriptor as 0. Note: This is only
+ allowed if -std=legacy, otherwise an error occurs. */
+ if (compile_options.warn_std != 0)
+ {
+ fmt->error = period_required;
+ goto finished;
+ }
+ fmt->saved_token = t;
+ tail->u.real.d = 0;
+ break;
}
- t = format_lex ();
+ t = format_lex (fmt);
if (t != FMT_ZERO && t != FMT_POSINT)
{
- error = nonneg_required;
+ fmt->error = nonneg_required;
goto finished;
}
- tail->u.real.d = value;
+ tail->u.real.d = fmt->value;
if (t == FMT_D || t == FMT_F)
break;
@@ -733,38 +989,37 @@ parse_format_list (void)
tail->u.real.e = -1;
/* Look for optional exponent */
- t = format_lex ();
+ t = format_lex (fmt);
if (t != FMT_E)
- saved_token = t;
+ fmt->saved_token = t;
else
{
- t = format_lex ();
+ t = format_lex (fmt);
if (t != FMT_POSINT)
{
- error = "Positive exponent width required in format";
+ fmt->error = "Positive exponent width required in format";
goto finished;
}
- tail->u.real.e = value;
+ tail->u.real.e = fmt->value;
}
break;
case FMT_H:
- if (repeat > format_string_len)
+ if (repeat > fmt->format_string_len)
{
- error = bad_hollerith;
+ fmt->error = bad_hollerith;
goto finished;
}
- get_fnode (&head, &tail, FMT_STRING);
-
- tail->u.string.p = format_string;
+ get_fnode (fmt, &head, &tail, FMT_STRING);
+ tail->u.string.p = fmt->format_string;
tail->u.string.length = repeat;
tail->repeat = 1;
- format_string += value;
- format_string_len -= repeat;
+ fmt->format_string += fmt->value;
+ fmt->format_string_len -= repeat;
break;
@@ -772,16 +1027,16 @@ parse_format_list (void)
case FMT_B:
case FMT_O:
case FMT_Z:
- get_fnode (&head, &tail, t);
+ get_fnode (fmt, &head, &tail, t);
tail->repeat = repeat;
- t = format_lex ();
+ t = format_lex (fmt);
- if (g.mode == READING)
+ if (dtp->u.p.mode == READING)
{
if (t != FMT_POSINT)
{
- error = posint_required;
+ fmt->error = posint_required;
goto finished;
}
}
@@ -789,47 +1044,47 @@ parse_format_list (void)
{
if (t != FMT_ZERO && t != FMT_POSINT)
{
- error = nonneg_required;
+ fmt->error = nonneg_required;
goto finished;
}
}
- tail->u.integer.w = value;
+ tail->u.integer.w = fmt->value;
tail->u.integer.m = -1;
- t = format_lex ();
+ t = format_lex (fmt);
if (t != FMT_PERIOD)
{
- saved_token = t;
+ fmt->saved_token = t;
}
else
{
- t = format_lex ();
+ t = format_lex (fmt);
if (t != FMT_ZERO && t != FMT_POSINT)
{
- error = nonneg_required;
+ fmt->error = nonneg_required;
goto finished;
}
- tail->u.integer.m = value;
+ tail->u.integer.m = fmt->value;
}
if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
{
- error = "Minimum digits exceeds field width";
+ fmt->error = "Minimum digits exceeds field width";
goto finished;
}
break;
default:
- error = unexpected_element;
+ fmt->error = unexpected_element;
goto finished;
}
/* Between a descriptor and what comes next */
between_desc:
- t = format_lex ();
+ t = format_lex (fmt);
switch (t)
{
case FMT_COMMA:
@@ -839,27 +1094,24 @@ parse_format_list (void)
goto finished;
case FMT_SLASH:
- get_fnode (&head, &tail, FMT_SLASH);
- tail->repeat = 1;
-
- /* Fall Through */
-
case FMT_COLON:
+ get_fnode (fmt, &head, &tail, t);
+ tail->repeat = 1;
goto optional_comma;
case FMT_END:
- error = unexpected_end;
+ fmt->error = unexpected_end;
goto finished;
default:
- error = "Missing comma in format";
- goto finished;
+ /* Assume a missing comma, this is a GNU extension */
+ goto format_item_1;
}
/* Optional comma is a weird between state where we've just finished
reading a colon, slash or P descriptor. */
optional_comma:
- t = format_lex ();
+ t = format_lex (fmt);
switch (t)
{
case FMT_COMMA:
@@ -869,13 +1121,16 @@ parse_format_list (void)
goto finished;
default: /* Assume that we have another format item */
- saved_token = t;
+ fmt->saved_token = t;
break;
}
goto format_item;
finished:
+
+ *save_ok = saveit;
+
return head;
}
@@ -885,30 +1140,31 @@ parse_format_list (void)
* is assumed to happen at parse time, and the current location of the
* parser is shown.
*
- * After freeing any dynamically allocated fnodes, generate a message
- * showing where the problem is. We take extra care to print only the
- * relevant part of the format if it is longer than a standard 80
- * column display. */
+ * We generate a message showing where the problem is. We take extra
+ * care to print only the relevant part of the format if it is longer
+ * than a standard 80 column display. */
void
-format_error (fnode * f, const char *message)
+format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
{
int width, i, j, offset;
char *p, buffer[300];
+ format_data *fmt = dtp->u.p.fmt;
if (f != NULL)
- format_string = f->source;
+ fmt->format_string = f->source;
- free_fnodes ();
-
- st_sprintf (buffer, "%s\n", message);
+ if (message == unexpected_element)
+ sprintf (buffer, message, fmt->error_element);
+ else
+ sprintf (buffer, "%s\n", message);
- j = format_string - ioparm.format;
+ j = fmt->format_string - dtp->format;
offset = (j > 60) ? j - 40 : 0;
j -= offset;
- width = ioparm.format_len - offset;
+ width = dtp->format_len - offset;
if (width > 80)
width = 80;
@@ -917,7 +1173,7 @@ format_error (fnode * f, const char *message)
p = strchr (buffer, '\0');
- memcpy (p, ioparm.format + offset, width);
+ memcpy (p, dtp->format + offset, width);
p += width;
*p++ = '\n';
@@ -930,42 +1186,7 @@ format_error (fnode * f, const char *message)
*p++ = '^';
*p = '\0';
- generate_error (ERROR_FORMAT, buffer);
-}
-
-
-/* parse_format()-- Parse a format string. */
-
-void
-parse_format (void)
-{
- format_string = ioparm.format;
- format_string_len = ioparm.format_len;
-
- saved_token = FMT_NONE;
- error = NULL;
-
- /* Initialize variables used during traversal of the tree */
-
- reversion_ok = 0;
- g.reversion_flag = 0;
- saved_format = NULL;
-
- /* Allocate the first format node as the root of the tree */
-
- avail = array;
-
- avail->format = FMT_LPAREN;
- avail->repeat = 1;
- avail++;
-
- if (format_lex () == FMT_LPAREN)
- array[0].u.child = parse_format_list ();
- else
- error = "Missing initial left parenthesis in format";
-
- if (error)
- format_error (NULL, error);
+ generate_error (&dtp->common, LIBERROR_FORMAT, buffer);
}
@@ -977,22 +1198,93 @@ parse_format (void)
* level. */
static void
-revert (void)
+revert (st_parameter_dt *dtp)
{
fnode *f, *r;
+ format_data *fmt = dtp->u.p.fmt;
- g.reversion_flag = 1;
+ dtp->u.p.reversion_flag = 1;
r = NULL;
- for (f = array[0].u.child; f; f = f->next)
+ 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 */
- array[0].current = r;
- array[0].count = 0;
+ 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;
+ fmt->format_string_len = dtp->format_len;
+
+ fmt->string = NULL;
+ fmt->saved_token = FMT_NONE;
+ fmt->error = NULL;
+ fmt->value = 0;
+
+ /* 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. */
+
+ fmt->last = &fmt->array;
+ fmt->last->next = NULL;
+ fmt->avail = &fmt->array.array[0];
+
+ memset (fmt->avail, 0, sizeof (*fmt->avail));
+ fmt->avail->format = FMT_LPAREN;
+ fmt->avail->repeat = 1;
+ fmt->avail++;
+
+ if (format_lex (fmt) == FMT_LPAREN)
+ 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);
+ free_format_hash_table (dtp->u.p.current_unit);
+ return;
+ }
+
+ if (format_cache_ok)
+ save_parsed_format (dtp);
+ else
+ dtp->u.p.format_not_saved = 1;
}
@@ -1001,10 +1293,10 @@ revert (void)
* Parenthesis nodes are incremented after the list has been
* exhausted, other nodes are incremented before they are returned. */
-static fnode *
+static const fnode *
next_format0 (fnode * f)
{
- fnode *r;
+ const fnode *r;
if (f == NULL)
return NULL;
@@ -1019,8 +1311,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)
@@ -1041,46 +1348,45 @@ 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
- * initialization or the last reversion. We return NULL if the there
+ * 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). */
-fnode *
-next_format (void)
+const fnode *
+next_format (st_parameter_dt *dtp)
{
format_token t;
- fnode *f;
+ const fnode *f;
+ format_data *fmt = dtp->u.p.fmt;
- if (saved_format != NULL)
+ if (fmt->saved_format != NULL)
{ /* Deal with a pushed-back format node */
- f = saved_format;
- saved_format = NULL;
+ f = fmt->saved_format;
+ fmt->saved_format = NULL;
goto done;
}
- f = next_format0 (&array[0]);
+ f = next_format0 (&fmt->array.array[0]);
if (f == NULL)
{
- if (!reversion_ok)
- {
- return NULL;
- }
+ if (!fmt->reversion_ok)
+ return NULL;
- reversion_ok = 0;
- revert ();
+ fmt->reversion_ok = 0;
+ revert (dtp);
- f = next_format0 (&array[0]);
+ f = next_format0 (&fmt->array.array[0]);
if (f == NULL)
{
- format_error (NULL, reversion_error);
+ format_error (dtp, NULL, reversion_error);
return NULL;
}
/* Push the first reverted token and return a colon node in case
* there are no more data items. */
- saved_format = f;
+ fmt->saved_format = f;
return &colon_node;
}
@@ -1088,11 +1394,11 @@ next_format (void)
done:
t = f->format;
- if (!reversion_ok &&
+ if (!fmt->reversion_ok &&
(t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
t == FMT_A || t == FMT_D))
- reversion_ok = 1;
+ fmt->reversion_ok = 1;
return f;
}
@@ -1105,183 +1411,8 @@ next_format (void)
* which calls the library back with the data item (or not). */
void
-unget_format (fnode * f)
-{
- saved_format = f;
-}
-
-
-
-
-#if 0
-
-static void dump_format1 (fnode * f);
-
-/* dump_format0()-- Dump a single format node */
-
-void
-dump_format0 (fnode * f)
-{
- char *p;
- int i;
-
- switch (f->format)
- {
- case FMT_COLON:
- st_printf (" :");
- break;
- case FMT_SLASH:
- st_printf (" %d/", f->u.r);
- break;
- case FMT_DOLLAR:
- st_printf (" $");
- break;
- case FMT_T:
- st_printf (" T%d", f->u.n);
- break;
- case FMT_TR:
- st_printf (" TR%d", f->u.n);
- break;
- case FMT_TL:
- st_printf (" TL%d", f->u.n);
- break;
- case FMT_X:
- st_printf (" %dX", f->u.n);
- break;
- case FMT_S:
- st_printf (" S");
- break;
- case FMT_SS:
- st_printf (" SS");
- break;
- case FMT_SP:
- st_printf (" SP");
- break;
-
- case FMT_LPAREN:
- if (f->repeat == 1)
- st_printf (" (");
- else
- st_printf (" %d(", f->repeat);
-
- dump_format1 (f->u.child);
- st_printf (" )");
- break;
-
- case FMT_STRING:
- st_printf (" '");
- p = f->u.string.p;
- for (i = f->u.string.length; i > 0; i--)
- st_printf ("%c", *p++);
-
- st_printf ("'");
- break;
-
- case FMT_P:
- st_printf (" %dP", f->u.k);
- break;
- case FMT_I:
- st_printf (" %dI%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
- break;
-
- case FMT_B:
- st_printf (" %dB%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
- break;
-
- case FMT_O:
- st_printf (" %dO%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
- break;
-
- case FMT_Z:
- st_printf (" %dZ%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
- break;
-
- case FMT_BN:
- st_printf (" BN");
- break;
- case FMT_BZ:
- st_printf (" BZ");
- break;
- case FMT_D:
- st_printf (" %dD%d.%d", f->repeat, f->u.real.w, f->u.real.d);
- break;
-
- case FMT_EN:
- st_printf (" %dEN%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
- f->u.real.e);
- break;
-
- case FMT_ES:
- st_printf (" %dES%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
- f->u.real.e);
- break;
-
- case FMT_F:
- st_printf (" %dF%d.%d", f->repeat, f->u.real.w, f->u.real.d);
- break;
-
- case FMT_E:
- st_printf (" %dE%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
- f->u.real.e);
- break;
-
- case FMT_G:
- st_printf (" %dG%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
- f->u.real.e);
- break;
-
- case FMT_L:
- st_printf (" %dL%d", f->repeat, f->u.w);
- break;
- case FMT_A:
- st_printf (" %dA%d", f->repeat, f->u.w);
- break;
-
- default:
- st_printf (" ???");
- break;
- }
-}
-
-
-/* dump_format1()-- Dump a string of format nodes */
-
-static void
-dump_format1 (fnode * f)
-{
- for (; f; f = f->next)
- dump_format1 (f);
-}
-
-/* dump_format()-- Dump the whole format node tree */
-
-void
-dump_format (void)
+unget_format (st_parameter_dt *dtp, const fnode *f)
{
- st_printf ("format = ");
- dump_format0 (&array[0]);
- st_printf ("\n");
-}
-
-
-void
-next_test (void)
-{
- fnode *f;
- int i;
-
- for (i = 0; i < 20; i++)
- {
- f = next_format ();
- if (f == NULL)
- {
- st_printf ("No format!\n");
- break;
- }
-
- dump_format1 (f);
- st_printf ("\n");
- }
+ dtp->u.p.fmt->saved_format = f;
}
-#endif