-/* 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.
Libgfortran is distributed in the hope that it will be useful,
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
+<http://www.gnu.org/licenses/>. */
/* format.c-- parse a FORMAT string into a binary format suitable for
* interpretation during I/O statements */
-#include "config.h"
+#include "io.h"
#include <ctype.h>
#include <string.h>
-#include "libgfortran.h"
-#include "io.h"
-
-
-
-/* Number of format nodes that we can store statically before we have
- * to resort to dynamic allocation. The root node is array[0]. */
+#include <stdbool.h>
-#define FARRAY_SIZE 200
+#define FARRAY_SIZE 64
-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.
* 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;
}
/* 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
* 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;
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;
+ for (fa = fmt->array.next; fa; fa = fa_next)
+ {
+ fa_next = fa->next;
+ free_mem (fa);
+ }
-/* 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]);
-
- 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;
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 '.':
break;
case 'T':
- switch (next_char (0))
+ switch (next_char (fmt, 0))
{
case 'L':
token = FMT_TL;
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;
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;
break;
default:
token = FMT_B;
- unget_char ();
+ unget_char (fmt);
break;
}
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;
break;
case 'E':
- switch (next_char (0))
+ switch (next_char (fmt, 0))
{
case 'N':
token = FMT_EN;
break;
default:
token = FMT_E;
- unget_char ();
+ unget_char (fmt);
break;
}
-
break;
case 'G':
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:
* 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:
}
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)
{
goto data_desc;
}
- saved_token = t;
+ 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;
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:
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,
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 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:
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;
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:
goto finished;
default:
- error = unexpected_element;
+ fmt->error = unexpected_element;
goto finished;
}
data_desc:
switch (t)
{
- case FMT_P:
- t = format_lex ();
- if (t == FMT_POSINT)
- {
- error = "Repeat count cannot follow P descriptor";
- goto finished;
- }
-
- saved_token = t;
- get_fnode (&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:
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;
}
}
{
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;
+ tail->u.real.e = -1;
+ 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;
+ 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 ();
+ 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;
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;
}
}
{
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:
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:
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;
}
* 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;
-
- free_fnodes ();
+ fmt->format_string = f->source;
- 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;
p = strchr (buffer, '\0');
- memcpy (p, ioparm.format + offset, width);
+ memcpy (p, dtp->format + offset, width);
p += width;
*p++ = '\n';
*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);
}
* 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;
}
* 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;
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)
/* 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;
}
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;
}
* 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)
-{
- st_printf ("format = ");
- dump_format0 (&array[0]);
- st_printf ("\n");
-}
-
-
-void
-next_test (void)
+unget_format (st_parameter_dt *dtp, const fnode *f)
{
- 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
OSDN Git Service
