-/* Copyright (C) 2002-2016 Free Software Foundation, Inc.
+/* Copyright (C) 2002-2018 Free Software Foundation, Inc.
Contributed by Andy Vaught
F2003 I/O support contributed by Jerry DeLisle
/* format.c-- parse a FORMAT string into a binary format suitable for
- * interpretation during I/O statements */
+ interpretation during I/O statements. */
#include "io.h"
#include "format.h"
#include <ctype.h>
#include <string.h>
-#include <stdlib.h>
static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
free (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].key_len = 0;
u->format_hash_table[i].hashed_fmt = NULL;
}
}
fn->count = 0;
fn->current = NULL;
-
+
if (fn->format != FMT_LPAREN)
return;
/* next_char()-- Return the next character in the format string.
- * Returns -1 when the string is done. If the literal flag is set,
- * spaces are significant, otherwise they are not. */
+ Returns -1 when the string is done. If the literal flag is set,
+ spaces are significant, otherwise they are not. */
static int
next_char (format_data *fmt, int literal)
/* get_fnode()-- Allocate a new format node, inserting it into the
- * current singly linked list. These are initially allocated from the
- * static buffer. */
+ current singly linked list. These are initially allocated from the
+ static buffer. */
static fnode *
get_fnode (format_data *fmt, fnode **head, fnode **tail, format_token t)
free_format_data (format_data *fmt)
{
fnode_array *fa, *fa_next;
-
+ fnode *fnp;
if (fmt == NULL)
return;
+ /* Free vlist descriptors in the fnode_array if one was allocated. */
+ for (fnp = fmt->array.array; fnp < &fmt->array.array[FARRAY_SIZE] &&
+ fnp->format != FMT_NONE; fnp++)
+ if (fnp->format == FMT_DT)
+ {
+ if (GFC_DESCRIPTOR_DATA(fnp->u.udf.vlist))
+ free (GFC_DESCRIPTOR_DATA(fnp->u.udf.vlist));
+ free (fnp->u.udf.vlist);
+ }
+
for (fa = fmt->array.next; fa; fa = fa_next)
{
fa_next = fa->next;
/* format_lex()-- Simple lexical analyzer for getting the next token
- * in a FORMAT string. We support a one-level token pushback in the
- * fmt->saved_token variable. */
+ in a FORMAT string. We support a one-level token pushback in the
+ fmt->saved_token variable. */
static format_token
format_lex (format_data *fmt)
case 'C':
token = FMT_DC;
break;
+ case 'T':
+ token = FMT_DT;
+ break;
default:
token = FMT_D;
unget_char (fmt);
/* parse_format_list()-- Parse a format list. Assumes that a left
- * paren has already been seen. Returns a list representing the
- * parenthesis node which contains the rest of the list. */
+ paren has already been seen. Returns a list representing the
+ parenthesis node which contains the rest of the list. */
static fnode *
parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
tail->u.string.length = fmt->value;
tail->repeat = 1;
goto optional_comma;
-
+
case FMT_RC:
case FMT_RD:
case FMT_RN:
case FMT_EN:
case FMT_ES:
case FMT_D:
+ case FMT_DT:
case FMT_L:
case FMT_A:
case FMT_F:
/* In this state, t must currently be a data descriptor. Deal with
things that can/must follow the descriptor */
data_desc:
+
switch (t)
{
case FMT_L:
t = format_lex (fmt);
if (t != FMT_POSINT)
{
- if (notification_std(GFC_STD_GNU) == NOTIFICATION_ERROR)
+ if (t == FMT_ZERO)
{
- fmt->error = posint_required;
- goto finished;
+ if (notification_std(GFC_STD_GNU) == NOTIFICATION_ERROR)
+ {
+ fmt->error = "Extension: Zero width after L descriptor";
+ goto finished;
+ }
+ else
+ notify_std (&dtp->common, GFC_STD_GNU,
+ "Zero width after L descriptor");
}
else
{
fmt->saved_token = t;
- fmt->value = 1; /* Default width */
- notify_std (&dtp->common, GFC_STD_GNU, posint_required);
+ notify_std (&dtp->common, GFC_STD_GNU,
+ "Positive width required with L descriptor");
}
+ fmt->value = 1; /* Default width */
}
-
get_fnode (fmt, &head, &tail, FMT_L);
tail->u.n = fmt->value;
tail->repeat = repeat;
}
break;
+ case FMT_DT:
+ *seen_dd = true;
+ get_fnode (fmt, &head, &tail, t);
+ tail->repeat = repeat;
+
+ t = format_lex (fmt);
+
+ /* Initialize the vlist to a zero size array. */
+ tail->u.udf.vlist= xmalloc (sizeof(gfc_array_i4));
+ GFC_DESCRIPTOR_DATA(tail->u.udf.vlist) = NULL;
+ GFC_DIMENSION_SET(tail->u.udf.vlist->dim[0],1, 0, 0);
+ if (t == FMT_STRING)
+ {
+ /* Get pointer to the optional format string. */
+ tail->u.udf.string = fmt->string;
+ tail->u.udf.string_len = fmt->value;
+ t = format_lex (fmt);
+ }
+ if (t == FMT_LPAREN)
+ {
+ /* Temporary buffer to hold the vlist values. */
+ GFC_INTEGER_4 temp[FARRAY_SIZE];
+ int i = 0;
+ loop:
+ t = format_lex (fmt);
+ if (t != FMT_POSINT)
+ {
+ fmt->error = posint_required;
+ goto finished;
+ }
+ /* Save the positive integer value. */
+ temp[i++] = fmt->value;
+ t = format_lex (fmt);
+ if (t == FMT_COMMA)
+ goto loop;
+ if (t == FMT_RPAREN)
+ {
+ /* We have parsed the complete vlist so initialize the
+ array descriptor and save it in the format node. */
+ gfc_array_i4 *vp = tail->u.udf.vlist;
+ GFC_DESCRIPTOR_DATA(vp) = xmalloc (i * sizeof(GFC_INTEGER_4));
+ GFC_DIMENSION_SET(vp->dim[0],1, i, 1);
+ memcpy (GFC_DESCRIPTOR_DATA(vp), temp, i * sizeof(GFC_INTEGER_4));
+ break;
+ }
+ fmt->error = unexpected_element;
+ goto finished;
+ }
+ fmt->saved_token = t;
+ break;
case FMT_H:
if (repeat > fmt->format_string_len)
{
/* format_error()-- Generate an error message for a format statement.
- * If the node that gives the location of the error is NULL, the error
- * is assumed to happen at parse time, and the current location of the
- * parser is shown.
- *
- * 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. */
+ If the node that gives the location of the error is NULL, the error
+ is assumed to happen at parse time, and the current location of the
+ parser is shown.
+
+ 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 (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. */
+ 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)
format_data *fmt;
bool format_cache_ok, seen_data_desc = false;
- /* 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);
+ /* Don't cache for internal units and set an arbitrary limit on the
+ size of format strings we will cache. (Avoids memory issues.)
+ Also, the format_hash_table resides in the current_unit, so
+ child_dtio procedures would overwrite the parent table */
+ format_cache_ok = !is_internal_unit (dtp)
+ && (dtp->u.p.current_unit->child_dtio == 0);
/* Lookup format string to see if it has already been parsed. */
if (format_cache_ok)
fmt->reversion_ok = 0;
fmt->saved_format = NULL;
+ /* Initialize the fnode_array. */
+
+ memset (&(fmt->array), 0, sizeof(fmt->array));
+
/* Allocate the first format node as the root of the tree. */
fmt->last = &fmt->array;
/* next_format0()-- Get the next format node without worrying about
- * reversion. Returns NULL when we hit the end of the list.
- * Parenthesis nodes are incremented after the list has been
- * exhausted, other nodes are incremented before they are returned. */
+ reversion. Returns NULL when we hit the end of the list.
+ Parenthesis nodes are incremented after the list has been
+ exhausted, other nodes are incremented before they are returned. */
static const fnode *
-next_format0 (fnode * f)
+next_format0 (fnode *f)
{
const fnode *r;
/* next_format()-- Return the next format node. If the format list
- * ends up being exhausted, we do reversion. Reversion is only
- * 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). */
+ ends up being exhausted, we do reversion. Reversion is only
+ 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). */
const fnode *
next_format (st_parameter_dt *dtp)
}
/* Push the first reverted token and return a colon node in case
- * there are no more data items. */
+ there are no more data items. */
fmt->saved_format = f;
return &colon_node;
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))
+ t == FMT_A || t == FMT_D || t == FMT_DT))
fmt->reversion_ok = 1;
return f;
}
/* unget_format()-- Push the given format back so that it will be
- * returned on the next call to next_format() without affecting
- * counts. This is necessary when we've encountered a data
- * descriptor, but don't know what the data item is yet. The format
- * node is pushed back, and we return control to the main program,
- * which calls the library back with the data item (or not). */
+ returned on the next call to next_format() without affecting
+ counts. This is necessary when we've encountered a data
+ descriptor, but don't know what the data item is yet. The format
+ node is pushed back, and we return control to the main program,
+ which calls the library back with the data item (or not). */
void
unget_format (st_parameter_dt *dtp, const fnode *f)