-/* Copyright (C) 2002-2016 Free Software Foundation, Inc.
+/* Copyright (C) 2002-2024 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,
/* Error messages. */
-static const char posint_required[] = "Positive width required in format",
+static const char posint_required[] = "Positive integer required in format",
period_required[] = "Period required in format",
nonneg_required[] = "Nonnegative width required in format",
unexpected_element[] = "Unexpected element '%c' in format\n",
/* 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)
return -1;
fmt->format_string_len--;
- c = toupper (*fmt->format_string++);
+ c = safe_toupper (*fmt->format_string++);
fmt->error_element = c;
}
while ((c == ' ' || c == '\t') && !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)
return;
/* Free vlist descriptors in the fnode_array if one was allocated. */
- for (fnp = fmt->array.array; fnp->format != FMT_NONE; fnp++)
+ 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 (GFC_DESCRIPTOR_DATA(fnp->u.udf.vlist));
free (fnp->u.udf.vlist);
}
/* 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 = next_char (fmt, 0);
- if (!isdigit (c))
+ if (!safe_isdigit (c))
{
token = FMT_UNKNOWN;
break;
for (;;)
{
c = next_char (fmt, 0);
- if (!isdigit (c))
+ if (!safe_isdigit (c))
break;
fmt->value = 10 * fmt->value + c - '0';
for (;;)
{
c = next_char (fmt, 0);
- if (!isdigit (c))
+ if (!safe_isdigit (c))
break;
fmt->value = 10 * fmt->value + c - '0';
/* 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)
int repeat;
format_data *fmt = dtp->u.p.fmt;
bool seen_data_desc = false;
+ int standard;
head = tail = NULL;
tail->repeat = repeat;
u = format_lex (fmt);
- if (t == FMT_G && u == FMT_ZERO)
+
+ /* Processing for zero width formats. */
+ if (u == FMT_ZERO)
{
- *seen_dd = true;
- if (notification_std (GFC_STD_F2008) == NOTIFICATION_ERROR
+ if (t == FMT_F)
+ standard = GFC_STD_F95;
+ else if (t == FMT_G)
+ standard = GFC_STD_F2008;
+ else
+ standard = GFC_STD_F2018;
+
+ if (notification_std (standard) == NOTIFICATION_ERROR
|| dtp->u.p.mode == READING)
{
fmt->error = zero_width;
goto finished;
}
tail->u.real.w = 0;
+
+ /* Look for the dot seperator. */
u = format_lex (fmt);
if (u != FMT_PERIOD)
{
break;
}
+ /* Look for the precision. */
u = format_lex (fmt);
- if (u != FMT_POSINT)
+ if (u != FMT_ZERO && u != FMT_POSINT)
{
- fmt->error = posint_required;
+ fmt->error = nonneg_required;
goto finished;
}
tail->u.real.d = fmt->value;
+
+ /* Look for optional exponent, not allowed for FMT_D */
+ if (t == FMT_D)
+ break;
+ u = format_lex (fmt);
+ if (u != FMT_E)
+ fmt->saved_token = u;
+ else
+ {
+ u = format_lex (fmt);
+ if (u != FMT_POSINT)
+ {
+ if (u == FMT_ZERO)
+ {
+ notify_std (&dtp->common, GFC_STD_F2018,
+ "Positive exponent width required");
+ }
+ else
+ {
+ fmt->error = "Positive exponent width required in "
+ "format string at %L";
+ goto finished;
+ }
+ }
+ tail->u.real.e = fmt->value;
+ }
break;
}
- if (t == FMT_F && dtp->u.p.mode == WRITING)
+
+ /* Processing for positive width formats. */
+ if (u == FMT_POSINT)
{
- *seen_dd = true;
- if (u != FMT_POSINT && u != FMT_ZERO)
+ tail->u.real.w = fmt->value;
+
+ /* Look for the dot separator. Because of legacy behaviors
+ we do some look ahead for missing things. */
+ t2 = t;
+ t = format_lex (fmt);
+ if (t != FMT_PERIOD)
{
- fmt->error = nonneg_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;
}
- }
- else if (u != FMT_POSINT)
- {
- fmt->error = posint_required;
- goto finished;
- }
- tail->u.real.w = fmt->value;
- t2 = t;
- t = format_lex (fmt);
- if (t != FMT_PERIOD)
- {
- /* 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)
+ /* If we made it here, we should have the dot so look for the
+ precision. */
+ t = format_lex (fmt);
+ if (t != FMT_ZERO && t != FMT_POSINT)
{
- fmt->error = period_required;
+ fmt->error = nonneg_required;
goto finished;
}
- fmt->saved_token = t;
- tail->u.real.d = 0;
+ tail->u.real.d = fmt->value;
tail->u.real.e = -1;
- break;
- }
- t = format_lex (fmt);
- if (t != FMT_ZERO && t != FMT_POSINT)
- {
- fmt->error = nonneg_required;
- goto finished;
- }
-
- tail->u.real.d = fmt->value;
- tail->u.real.e = -1;
+ /* Done with D and F formats. */
+ if (t2 == FMT_D || t2 == FMT_F)
+ {
+ *seen_dd = true;
+ break;
+ }
- if (t2 == FMT_D || t2 == FMT_F)
- {
- *seen_dd = true;
+ /* Look for optional exponent */
+ u = format_lex (fmt);
+ if (u != FMT_E)
+ fmt->saved_token = u;
+ else
+ {
+ u = format_lex (fmt);
+ if (u != FMT_POSINT)
+ {
+ if (u == FMT_ZERO)
+ {
+ notify_std (&dtp->common, GFC_STD_F2018,
+ "Positive exponent width required");
+ }
+ else
+ {
+ fmt->error = "Positive exponent width required in "
+ "format string at %L";
+ goto finished;
+ }
+ }
+ tail->u.real.e = fmt->value;
+ }
break;
}
- /* Look for optional exponent */
- t = format_lex (fmt);
- if (t != FMT_E)
- fmt->saved_token = t;
- else
+ /* Old DEC codes may not have width or precision specified. */
+ if (dtp->u.p.mode == WRITING && (dtp->common.flags & IOPARM_DT_DEC_EXT))
{
- t = format_lex (fmt);
- if (t != FMT_POSINT)
- {
- fmt->error = "Positive exponent width required in format";
- goto finished;
- }
-
- tail->u.real.e = fmt->value;
+ tail->u.real.w = DEFAULT_WIDTH;
+ tail->u.real.d = 0;
+ tail->u.real.e = -1;
+ fmt->saved_token = u;
}
-
break;
+
case FMT_DT:
*seen_dd = true;
get_fnode (fmt, &head, &tail, t);
t = format_lex (fmt);
- /* Initialize the vlist to a zero size array. */
- tail->u.udf.vlist= xmalloc (sizeof(gfc_array_i4));
+ /* Initialize the vlist to a zero size, rank-one array. */
+ tail->u.udf.vlist= xmalloc (sizeof(gfc_array_i4)
+ + sizeof (descriptor_dimension));
GFC_DESCRIPTOR_DATA(tail->u.udf.vlist) = NULL;
GFC_DIMENSION_SET(tail->u.udf.vlist->dim[0],1, 0, 0);
{
/* 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_full_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));
{
if (t != FMT_POSINT)
{
+ if (dtp->common.flags & IOPARM_DT_DEC_EXT)
+ {
+ tail->u.integer.w = DEFAULT_WIDTH;
+ tail->u.integer.m = -1;
+ fmt->saved_token = t;
+ break;
+ }
fmt->error = posint_required;
goto finished;
}
{
if (t != FMT_ZERO && t != FMT_POSINT)
{
+ if (dtp->common.flags & IOPARM_DT_DEC_EXT)
+ {
+ tail->u.integer.w = DEFAULT_WIDTH;
+ tail->u.integer.m = -1;
+ fmt->saved_token = t;
+ break;
+ }
fmt->error = nonneg_required;
goto finished;
}
/* 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)
/* 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;
/* 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)