-/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
- Free Software Foundation, Inc.
+/* Copyright (C) 2002-2017 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).
+This file is part of the GNU Fortran 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
* interpretation during I/O statements */
#include "io.h"
+#include "format.h"
#include <ctype.h>
#include <string.h>
-#include <stdbool.h>
-#define FARRAY_SIZE 64
-
-typedef struct fnode_array
-{
- struct fnode_array *next;
- fnode array[FARRAY_SIZE];
-}
-fnode_array;
-
-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 const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
NULL };
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);
+ 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;
/* 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)
+ for (f = fmt->array.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)
+static uint32_t
+format_hash (st_parameter_dt *dtp)
{
char *key;
gfc_charlen_type key_len;
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);
+ free (u->format_hash_table[hash].key);
+ u->format_hash_table[hash].key = dtp->format;
u->format_hash_table[hash].key_len = dtp->format_len;
u->format_hash_table[hash].hashed_fmt = dtp->u.p.fmt;
if (fmt->avail == &fmt->last->array[FARRAY_SIZE])
{
- fmt->last->next = get_mem (sizeof (fnode_array));
+ fmt->last->next = xmalloc (sizeof (fnode_array));
fmt->last = fmt->last->next;
fmt->last->next = NULL;
fmt->avail = &fmt->last->array[0];
}
+/* free_format()-- Free allocated format string. */
+void
+free_format (st_parameter_dt *dtp)
+{
+ if ((dtp->common.flags & IOPARM_DT_HAS_FORMAT) && dtp->format)
+ {
+ free (dtp->format);
+ dtp->format = NULL;
+ }
+}
+
+
/* free_format_data()-- Free all allocated format data. */
void
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->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;
- free_mem (fa);
+ free (fa);
}
- free_mem (fmt);
+ free (fmt);
fmt = NULL;
}
case 'C':
token = FMT_DC;
break;
+ case 'T':
+ token = FMT_DT;
+ break;
default:
token = FMT_D;
unget_char (fmt);
* parenthesis node which contains the rest of the list. */
static fnode *
-parse_format_list (st_parameter_dt *dtp, bool *save_ok)
+parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
{
fnode *head, *tail;
format_token t, u, t2;
int repeat;
format_data *fmt = dtp->u.p.fmt;
- bool saveit;
+ bool seen_data_desc = false;
head = tail = NULL;
- saveit = *save_ok;
/* Get the next format item */
format_item:
}
get_fnode (fmt, &head, &tail, FMT_LPAREN);
tail->repeat = -2; /* Signifies unlimited format. */
- tail->u.child = parse_format_list (dtp, &saveit);
+ tail->u.child = parse_format_list (dtp, &seen_data_desc);
+ *seen_dd = seen_data_desc;
if (fmt->error != NULL)
goto finished;
-
+ if (!seen_data_desc)
+ {
+ fmt->error = "'*' requires at least one associated data descriptor";
+ goto finished;
+ }
goto between_desc;
case FMT_POSINT:
case FMT_LPAREN:
get_fnode (fmt, &head, &tail, FMT_LPAREN);
tail->repeat = repeat;
- tail->u.child = parse_format_list (dtp, &saveit);
+ tail->u.child = parse_format_list (dtp, &seen_data_desc);
+ *seen_dd = seen_data_desc;
if (fmt->error != NULL)
goto finished;
case FMT_LPAREN:
get_fnode (fmt, &head, &tail, FMT_LPAREN);
tail->repeat = 1;
- tail->u.child = parse_format_list (dtp, &saveit);
+ tail->u.child = parse_format_list (dtp, &seen_data_desc);
+ *seen_dd = seen_data_desc;
if (fmt->error != NULL)
goto finished;
goto data_desc;
}
- if (t != FMT_COMMA && t != FMT_RPAREN && t != FMT_SLASH)
+ if (t != FMT_COMMA && t != FMT_RPAREN && t != FMT_SLASH
+ && t != FMT_POSINT)
{
fmt->error = "Comma required after P descriptor";
goto finished;
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_EN:
case FMT_ES:
case FMT_D:
+ case FMT_DT:
case FMT_L:
case FMT_A:
case FMT_F:
case FMT_G:
repeat = 1;
+ *seen_dd = true;
goto data_desc;
case FMT_H:
/* 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:
+ *seen_dd = true;
t = format_lex (fmt);
if (t != FMT_POSINT)
{
- if (notification_std(GFC_STD_GNU) == 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_A:
+ *seen_dd = true;
t = format_lex (fmt);
if (t == FMT_ZERO)
{
case FMT_G:
case FMT_EN:
case FMT_ES:
+ *seen_dd = true;
get_fnode (fmt, &head, &tail, t);
tail->repeat = repeat;
u = format_lex (fmt);
if (t == FMT_G && u == FMT_ZERO)
{
- if (notification_std (GFC_STD_F2008) == ERROR
+ *seen_dd = true;
+ if (notification_std (GFC_STD_F2008) == NOTIFICATION_ERROR
|| dtp->u.p.mode == READING)
{
fmt->error = zero_width;
}
if (t == FMT_F && dtp->u.p.mode == WRITING)
{
+ *seen_dd = true;
if (u != FMT_POSINT && u != FMT_ZERO)
{
fmt->error = nonneg_required;
tail->u.real.e = -1;
if (t2 == FMT_D || t2 == FMT_F)
- break;
-
+ {
+ *seen_dd = true;
+ break;
+ }
/* Look for optional exponent */
t = format_lex (fmt);
}
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)
{
case FMT_B:
case FMT_O:
case FMT_Z:
+ *seen_dd = true;
get_fnode (fmt, &head, &tail, t);
tail->repeat = repeat;
finished:
- *save_ok = saveit;
-
return head;
}
void
format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
{
- int width, i, j, offset;
- char *p, buffer[300];
+ int width, i, offset;
+#define BUFLEN 300
+ char *p, buffer[BUFLEN];
format_data *fmt = dtp->u.p.fmt;
if (f != NULL)
- fmt->format_string = f->source;
+ p = f->source;
+ else /* This should not happen. */
+ p = dtp->format;
if (message == unexpected_element)
- sprintf (buffer, message, fmt->error_element);
+ snprintf (buffer, BUFLEN, message, fmt->error_element);
else
- sprintf (buffer, "%s\n", message);
+ snprintf (buffer, BUFLEN, "%s\n", message);
- j = fmt->format_string - dtp->format;
+ /* Get the offset into the format string where the error occurred. */
+ offset = dtp->format_len - (fmt->reversion_ok ?
+ (int) strlen(p) : fmt->format_string_len);
- offset = (j > 60) ? j - 40 : 0;
-
- j -= offset;
- width = dtp->format_len - offset;
+ width = dtp->format_len;
if (width > 80)
width = 80;
p = strchr (buffer, '\0');
- memcpy (p, dtp->format + offset, width);
+ if (dtp->format)
+ memcpy (p, dtp->format, width);
p += width;
*p++ = '\n';
/* Show where the problem is */
- for (i = 1; i < j; i++)
+ for (i = 1; i < offset; i++)
*p++ = ' ';
*p++ = '^';
parse_format (st_parameter_dt *dtp)
{
format_data *fmt;
- bool format_cache_ok;
+ bool format_cache_ok, seen_data_desc = false;
- 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)
/* Not found so proceed as follows. */
- dtp->u.p.fmt = fmt = get_mem (sizeof (format_data));
+ char *fmt_string = fc_strdup_notrim (dtp->format, dtp->format_len);
+ dtp->format = fmt_string;
+
+ dtp->u.p.fmt = fmt = xmalloc (sizeof (format_data));
fmt->format_string = dtp->format;
fmt->format_string_len = dtp->format_len;
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;
fmt->avail++;
if (format_lex (fmt) == FMT_LPAREN)
- fmt->array.array[0].u.child = parse_format_list (dtp, &format_cache_ok);
+ fmt->array.array[0].u.child = parse_format_list (dtp, &seen_data_desc);
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;
+
+ if (fmt->error)
+ format_error (dtp, NULL, fmt->error);
}
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;
}
projects / thirdparty / gcc.git / blobdiff