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);
}
void
parse_format (st_parameter_dt *dtp)
{
format_data *fmt;
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);
else
fmt->error = "Missing initial left parenthesis in format";
if (fmt->error)
format_error (dtp, NULL, fmt->error);
}
static fnode *
parse_format_list (st_parameter_dt *dtp, bool *save_ok, bool *seen_dd)
{
fnode *head, *tail;
format_token t, u, t2;
int repeat;
format_data *fmt = dtp->u.p.fmt;
bool saveit, seen_data_desc = false;
head = tail = NULL;
saveit = *save_ok;
/* Get the next format item */
format_item:
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, &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:
repeat = fmt->value;
t = format_lex (fmt);
switch (t)
{
case FMT_LPAREN:
get_fnode (fmt, &head, &tail, FMT_LPAREN);
tail->repeat = repeat;
tail->u.child = parse_format_list (dtp, &saveit, &seen_data_desc);
*seen_dd = seen_data_desc;
if (fmt->error != NULL)
goto finished;
goto between_desc;
case FMT_SLASH:
get_fnode (fmt, &head, &tail, FMT_SLASH);
tail->repeat = repeat;
goto optional_comma;
case FMT_X:
get_fnode (fmt, &head, &tail, FMT_X);
tail->repeat = 1;
tail->u.k = fmt->value;
goto between_desc;
case FMT_P:
goto p_descriptor;
default:
goto data_desc;
}
case FMT_LPAREN:
get_fnode (fmt, &head, &tail, FMT_LPAREN);
tail->repeat = 1;
tail->u.child = parse_format_list (dtp, &saveit, &seen_data_desc);
*seen_dd = seen_data_desc;
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 (fmt);
if (t != FMT_P)
{
fmt->error = "Expected P edit descriptor in format";
goto finished;
}
p_descriptor:
get_fnode (fmt, &head, &tail, FMT_P);
tail->u.k = fmt->value;
tail->repeat = 1;
t = format_lex (fmt);
if (t == FMT_F || t == FMT_EN || t == FMT_ES || t == FMT_D
|| t == FMT_G || t == FMT_E)
{
repeat = 1;
goto data_desc;
}
if (t != FMT_COMMA && t != FMT_RPAREN && t != FMT_SLASH
&& t != FMT_POSINT)
{
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 */
fmt->error = "P descriptor requires leading scale factor";
goto finished;
case FMT_X:
/*
EXTENSION!
If we would be pedantic in the library, we would have to reject
an X descriptor without an integer prefix:
fmt->error = "X descriptor requires leading space count";
goto finished;
However, this is an extension supported by many Fortran compilers,
including Cray, HP, AIX, and IRIX. Therefore, we allow it in the
runtime library, and make the front end reject it if the compiler
is in pedantic mode. The interpretation of 'X' is '1X'.
*/
get_fnode (fmt, &head, &tail, FMT_X);
tail->repeat = 1;
tail->u.k = 1;
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_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 (fmt, &head, &tail, t);
tail->repeat = 1;
goto between_desc;
case FMT_COLON:
get_fnode (fmt, &head, &tail, FMT_COLON);
tail->repeat = 1;
goto optional_comma;
case FMT_SLASH:
get_fnode (fmt, &head, &tail, FMT_SLASH);
tail->repeat = 1;
tail->u.r = 1;
goto optional_comma;
case 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 (fmt);
if (t2 != FMT_POSINT)
{
fmt->error = posint_required;
goto finished;
}
get_fnode (fmt, &head, &tail, t);
tail->u.n = fmt->value;
tail->repeat = 1;
goto between_desc;
case FMT_I:
case FMT_B:
case FMT_O:
case FMT_Z:
case FMT_E:
case FMT_EN:
case FMT_ES:
case FMT_D:
case FMT_L:
case FMT_A:
case FMT_F:
case FMT_G:
repeat = 1;
*seen_dd = true;
goto data_desc;
case FMT_H:
get_fnode (fmt, &head, &tail, FMT_STRING);
if (fmt->format_string_len < 1)
{
fmt->error = bad_hollerith;
goto finished;
}
tail->u.string.p = fmt->format_string;
tail->u.string.length = 1;
tail->repeat = 1;
fmt->format_string++;
fmt->format_string_len--;
goto between_desc;
case FMT_END:
fmt->error = unexpected_end;
goto finished;
case FMT_BADSTRING:
goto finished;
case FMT_RPAREN:
goto finished;
default:
fmt->error = unexpected_element;
goto finished;
}
/* 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)
{
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 (fmt, &head, &tail, FMT_L);
tail->u.n = fmt->value;
tail->repeat = repeat;
break;
case FMT_A:
t = format_lex (fmt);
if (t == FMT_ZERO)
{
fmt->error = zero_width;
goto finished;
}
if (t != FMT_POSINT)
{
fmt->saved_token = t;
fmt->value = -1; /* Width not present */
}
get_fnode (fmt, &head, &tail, FMT_A);
tail->repeat = repeat;
tail->u.n = fmt->value;
break;
case FMT_D:
case FMT_E:
case FMT_F:
case FMT_G:
case FMT_EN:
case FMT_ES:
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) == NOTIFICATION_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)
{
fmt->error = nonneg_required;
goto finished;
}
}
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)
{
fmt->error = period_required;
goto finished;
}
fmt->saved_token = t;
tail->u.real.d = 0;
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;
if (t2 == FMT_D || t2 == FMT_F)
break;
/* Look for optional exponent */
t = format_lex (fmt);
if (t != FMT_E)
fmt->saved_token = t;
else
{
t = format_lex (fmt);
if (t != FMT_POSINT)
{
fmt->error = "Positive exponent width required in format";
goto finished;
}
tail->u.real.e = fmt->value;
}
break;
case FMT_H:
if (repeat > fmt->format_string_len)
{
fmt->error = bad_hollerith;
goto finished;
}
get_fnode (fmt, &head, &tail, FMT_STRING);
tail->u.string.p = fmt->format_string;
tail->u.string.length = repeat;
tail->repeat = 1;
fmt->format_string += fmt->value;
fmt->format_string_len -= repeat;
break;
case FMT_I:
case FMT_B:
case FMT_O:
case FMT_Z:
get_fnode (fmt, &head, &tail, t);
tail->repeat = repeat;
t = format_lex (fmt);
if (dtp->u.p.mode == READING)
{
if (t != FMT_POSINT)
{
fmt->error = posint_required;
goto finished;
}
}
else
{
if (t != FMT_ZERO && t != FMT_POSINT)
{
fmt->error = nonneg_required;
goto finished;
}
}
tail->u.integer.w = fmt->value;
tail->u.integer.m = -1;
t = format_lex (fmt);
if (t != FMT_PERIOD)
{
fmt->saved_token = t;
}
else
{
t = format_lex (fmt);
if (t != FMT_ZERO && t != FMT_POSINT)
{
fmt->error = nonneg_required;
goto finished;
}
tail->u.integer.m = fmt->value;
}
if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
{
fmt->error = "Minimum digits exceeds field width";
goto finished;
}
break;
default:
fmt->error = unexpected_element;
goto finished;
}
/* Between a descriptor and what comes next */
between_desc:
t = format_lex (fmt);
switch (t)
{
case FMT_COMMA:
goto format_item;
case FMT_RPAREN:
goto finished;
case FMT_SLASH:
case FMT_COLON:
get_fnode (fmt, &head, &tail, t);
tail->repeat = 1;
goto optional_comma;
case FMT_END:
fmt->error = unexpected_end;
goto finished;
default:
/* 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 (fmt);
switch (t)
{
case FMT_COMMA:
break;
case FMT_RPAREN:
goto finished;
default: /* Assume that we have another format item */
fmt->saved_token = t;
break;
}
goto format_item;
finished:
*save_ok = saveit;
return head;
}
void
parse_format (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);
/* 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 = xmalloc (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,
&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;
}
static try check_format(void) {
char *error,
*posint_required = "Positive width required",
*period_required = "Period required",
*nonneg_required = "Nonnegative width required",
*unexpected_element = "Unexpected element",
*unexpected_end = "Unexpected end of format string";
format_token l, c;
int m;
try r;
use_last_char = 0;
saved_token = FMT_NONE;
m = 0;
r = SUCCESS;
l = format_lex();
if (l != FMT_LPAREN) {
error = "Missing leading left parenthesis";
goto syntax;
}
/* In this state, the next thing has to be a format item */
format_item:
l = format_lex();
switch(l) {
case FMT_POSINT:
l = format_lex();
if (l == FMT_LPAREN) {
m++;
goto format_item;
}
if (l == FMT_SLASH) goto optional_comma;
goto data_desc;
case FMT_ZERO:
l = format_lex();
if (l != FMT_P) {
error = "Zero repeat count not allowed";
goto syntax;
}
goto p_descriptor;
case FMT_LPAREN:
m++;
goto format_item;
case FMT_RPAREN:
goto rparen;
case FMT_SIGNED_INT: /* Signed integer can only precede a P format */
l = format_lex();
if (l != FMT_P) {
error = "Expected P edit descriptor";
goto syntax;
}
goto data_desc;
case FMT_P: /* P and X require a prior number */
error = "P descriptor requires leading scale factor";
goto syntax;
case FMT_X:
error = "X descriptor requires leading space count";
goto syntax;
case FMT_SIGN:
case FMT_BLANK:
case FMT_CHAR:
goto between_desc;
case FMT_COLON:
case FMT_SLASH:
goto optional_comma;
case FMT_DOLLAR:
l = format_lex();
if (l != FMT_RPAREN || m > 0) {
error = "$ must the last specifier";
goto syntax;
}
goto finished;
case FMT_POS: case FMT_IBOZ: case FMT_F: case FMT_E: case FMT_EXT:
case FMT_G: case FMT_L: case FMT_A: case FMT_D:
goto data_desc;
case FMT_H:
repeat = 1;
goto handle_hollerith;
case FMT_END:
error = unexpected_end;
goto syntax;
default:
error = unexpected_element;
goto syntax;
}
/* In this state, t must currently be a data descriptor. Deal with
* things that can/must follow the descriptor */
data_desc:
switch(l) {
case FMT_SIGN:
case FMT_BLANK:
case FMT_X:
break;
case FMT_P:
p_descriptor:
if (g95_option.fmode != 0) {
l = format_lex();
if (l == FMT_POSINT) {
error = "Repeat count cannot follow P descriptor";
goto syntax;
}
saved_token = l;
}
goto optional_comma;
case FMT_POS:
case FMT_L:
l = format_lex();
if (l == FMT_POSINT) break;
error = posint_required;
goto syntax;
case FMT_A:
l = format_lex();
if (l != FMT_POSINT) saved_token = l;
break;
case FMT_D: case FMT_E:
case FMT_G: case FMT_EXT:
c = format_lex();
if (c != FMT_POSINT) {
error = posint_required;
goto syntax;
}
c = format_lex();
if (c != FMT_PERIOD) {
error = period_required;
goto syntax;
}
c = format_lex();
if (c != FMT_ZERO && c != FMT_POSINT) {
error = nonneg_required;
goto syntax;
}
if (l == FMT_D) break;
/* Look for optional exponent */
c = format_lex();
if (c != FMT_E) {
saved_token = c;
} else {
c = format_lex();
if (c != FMT_POSINT) {
error = "Positive exponent width required";
goto syntax;
}
}
break;
case FMT_F:
l = format_lex();
if (l != FMT_ZERO && l != FMT_POSINT) {
error = nonneg_required;
goto syntax;
}
l = format_lex();
if (l != FMT_PERIOD) {
error = period_required;
goto syntax;
}
l = format_lex();
if (l != FMT_ZERO && l != FMT_POSINT) {
error = nonneg_required;
goto syntax;
}
break;
case FMT_H:
handle_hollerith:
if (g95_option.fmode != 0) {
error = "The H format specifier is a deleted language feature";
goto syntax;
}
while(repeat>0) {
if (next_char(0) == '\0') {
error = unexpected_end;
goto syntax;
}
repeat--;
}
break;
case FMT_IBOZ:
l = format_lex();
if (l != FMT_ZERO && l != FMT_POSINT) {
error = nonneg_required;
goto syntax;
}
l = format_lex();
if (l != FMT_PERIOD) {
saved_token = l;
} else {
l = format_lex();
if (l != FMT_ZERO && l != FMT_POSINT) {
error = nonneg_required;
goto syntax;
}
}
break;
default:
error = unexpected_element;
goto syntax;
}
/* Between a descriptor and what comes next */
between_desc:
l = format_lex();
switch(l) {
case FMT_COMMA:
goto format_item;
case FMT_RPAREN:
rparen:
m--;
if (m < 0) goto finished;
goto between_desc;
case FMT_COLON:
case FMT_SLASH:
goto optional_comma;
case FMT_END:
error = unexpected_end;
goto syntax;
default:
error = "Missing comma";
goto syntax;
}
/* Optional comma is a weird between state where we've just finished
* reading a colon, slash or P descriptor. */
optional_comma:
l = format_lex();
switch(l) {
case FMT_COMMA:
break;
case FMT_RPAREN:
m--;
if (m < 0) goto finished;
goto between_desc;
default: /* Assume that we have another format item */
saved_token = l;
break;
}
goto format_item;
/* Something went wrong. If the format we're checking is a string,
* generate a warning, since the program is correct. If the format is
* in a FORMAT statement, this messes up parsing, which is an error. */
syntax:
if (mode != MODE_STRING)
g95_error("%s in format string at %L", error, &where);
else
g95_warning(100, "%s in format string at %L", error, &where);
r = FAILURE;
finished:
return r;
}
/* g95_match_format()-- Match a FORMAT statement. This amounts to
* actually parsing the format descriptors in order to correctly
* locate the end of the format string. */
match g95_match_format(void) {
g95_locus sta;
g95_expr *g;
if (g95_statement_label == NULL) {
g95_error("FORMAT statement at %C does not have a statement label");
return MATCH_ERROR;
}
g95_gobble_whitespace();
mode = MODE_FORMAT;
format_length = 0;
sta = where = new_where = g95_current_locus;
if (check_format() == FAILURE) return MATCH_ERROR;
if (g95_match_eos() != MATCH_YES) {
g95_syntax_error(ST_FORMAT);
return MATCH_ERROR;
}
/* The label doesn't get created until after the statement is done
* being matched, so we have to leave the string for later. */
g95_current_locus = sta; /* Back to the beginning */
g = g95_get_expr();
g->type = EXPR_CONSTANT;
g->ts.type = BT_CHARACTER;
g->ts.kind = g95_default_character_kind();
g->where = sta;
g->value.character.string = format_string = g95_getmem(format_length+1);
g->value.character.length = format_length;
g95_statement_label->format = g;
mode = MODE_COPY;
check_format(); /* Guaranteed to succeed */
g95_match_eos(); /* Guaranteed to succeed */
new_st.type = EXEC_NOP;
return MATCH_YES;
}
static fnode *
parse_format_list (void)
{
fnode *head, *tail;
format_token t, u, t2;
int repeat;
head = tail = NULL;
/* Get the next format item */
format_item:
t = format_lex ();
format_item_1:
switch (t)
{
case FMT_POSINT:
repeat = value;
t = format_lex ();
switch (t)
{
case FMT_LPAREN:
get_fnode (&head, &tail, FMT_LPAREN);
tail->repeat = repeat;
tail->u.child = parse_format_list ();
if (error != NULL)
goto finished;
goto between_desc;
case FMT_SLASH:
get_fnode (&head, &tail, FMT_SLASH);
tail->repeat = repeat;
goto optional_comma;
case FMT_X:
get_fnode (&head, &tail, FMT_X);
tail->repeat = 1;
tail->u.k = value;
goto between_desc;
case FMT_P:
goto p_descriptor;
default:
goto data_desc;
}
case FMT_LPAREN:
get_fnode (&head, &tail, FMT_LPAREN);
tail->repeat = 1;
tail->u.child = parse_format_list ();
if (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 ();
if (t != FMT_P)
{
error = "Expected P edit descriptor in format";
goto finished;
}
p_descriptor:
get_fnode (&head, &tail, FMT_P);
tail->u.k = value;
tail->repeat = 1;
t = format_lex ();
if (t == FMT_F || t == FMT_EN || t == FMT_ES || t == FMT_D
|| t == FMT_G || t == FMT_E)
{
repeat = 1;
goto data_desc;
}
saved_token = t;
goto optional_comma;
case FMT_P: /* P and X require a prior number */
error = "P descriptor requires leading scale factor";
goto finished;
case FMT_X:
/*
EXTENSION!
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";
goto finished;
However, this is an extension supported by many Fortran compilers,
including Cray, HP, AIX, and IRIX. Therefore, we allow it in the
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);
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;
tail->repeat = 1;
goto optional_comma;
case FMT_S:
case FMT_SS:
case FMT_SP:
case FMT_BN:
case FMT_BZ:
get_fnode (&head, &tail, t);
tail->repeat = 1;
goto between_desc;
case FMT_COLON:
get_fnode (&head, &tail, FMT_COLON);
tail->repeat = 1;
goto optional_comma;
case FMT_SLASH:
get_fnode (&head, &tail, FMT_SLASH);
tail->repeat = 1;
tail->u.r = 1;
goto optional_comma;
case FMT_DOLLAR:
get_fnode (&head, &tail, FMT_DOLLAR);
tail->repeat = 1;
notify_std (GFC_STD_GNU, "Extension: $ descriptor");
goto between_desc;
case FMT_T:
case FMT_TL:
case FMT_TR:
t2 = format_lex ();
if (t2 != FMT_POSINT)
{
error = posint_required;
goto finished;
}
get_fnode (&head, &tail, t);
tail->u.n = value;
tail->repeat = 1;
goto between_desc;
case FMT_I:
case FMT_B:
case FMT_O:
case FMT_Z:
case FMT_E:
case FMT_EN:
case FMT_ES:
case FMT_D:
case FMT_L:
case FMT_A:
case FMT_F:
case FMT_G:
repeat = 1;
goto data_desc;
case FMT_H:
get_fnode (&head, &tail, FMT_STRING);
if (format_string_len < 1)
{
error = bad_hollerith;
goto finished;
}
tail->u.string.p = format_string;
tail->u.string.length = 1;
tail->repeat = 1;
format_string++;
format_string_len--;
goto between_desc;
case FMT_END:
error = unexpected_end;
goto finished;
case FMT_BADSTRING:
goto finished;
case FMT_RPAREN:
goto finished;
default:
error = unexpected_element;
goto finished;
}
/* 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_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 ();
if (t != FMT_POSINT)
{
error = posint_required;
goto finished;
}
get_fnode (&head, &tail, FMT_L);
tail->u.n = value;
tail->repeat = repeat;
break;
case FMT_A:
t = format_lex ();
if (t != FMT_POSINT)
{
saved_token = t;
value = -1; /* Width not present */
}
get_fnode (&head, &tail, FMT_A);
tail->repeat = repeat;
tail->u.n = value;
break;
case FMT_D:
case FMT_E:
case FMT_F:
case FMT_G:
case FMT_EN:
case FMT_ES:
get_fnode (&head, &tail, t);
tail->repeat = repeat;
u = format_lex ();
if (t == FMT_F || g.mode == WRITING)
{
if (u != FMT_POSINT && u != FMT_ZERO)
{
error = nonneg_required;
goto finished;
}
}
else
{
if (u != FMT_POSINT)
{
error = posint_required;
goto finished;
}
}
tail->u.real.w = value;
t2 = t;
t = format_lex ();
if (t != FMT_PERIOD)
{
error = period_required;
goto finished;
}
t = format_lex ();
if (t != FMT_ZERO && t != FMT_POSINT)
{
error = nonneg_required;
goto finished;
}
tail->u.real.d = value;
if (t == FMT_D || t == FMT_F)
break;
tail->u.real.e = -1;
/* Look for optional exponent */
t = format_lex ();
if (t != FMT_E)
saved_token = t;
else
{
t = format_lex ();
if (t != FMT_POSINT)
{
error = "Positive exponent width required in format";
goto finished;
}
tail->u.real.e = value;
}
break;
case FMT_H:
if (repeat > format_string_len)
{
error = bad_hollerith;
goto finished;
}
get_fnode (&head, &tail, FMT_STRING);
tail->u.string.p = format_string;
tail->u.string.length = repeat;
tail->repeat = 1;
format_string += value;
format_string_len -= repeat;
break;
case FMT_I:
case FMT_B:
case FMT_O:
case FMT_Z:
get_fnode (&head, &tail, t);
tail->repeat = repeat;
t = format_lex ();
if (g.mode == READING)
{
if (t != FMT_POSINT)
{
error = posint_required;
goto finished;
}
}
else
{
if (t != FMT_ZERO && t != FMT_POSINT)
{
error = nonneg_required;
goto finished;
}
}
tail->u.integer.w = value;
tail->u.integer.m = -1;
t = format_lex ();
if (t != FMT_PERIOD)
{
saved_token = t;
}
else
{
t = format_lex ();
if (t != FMT_ZERO && t != FMT_POSINT)
{
error = nonneg_required;
goto finished;
}
tail->u.integer.m = value;
}
if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
{
error = "Minimum digits exceeds field width";
goto finished;
}
break;
default:
error = unexpected_element;
goto finished;
}
/* Between a descriptor and what comes next */
between_desc:
t = format_lex ();
switch (t)
{
case FMT_COMMA:
goto format_item;
case FMT_RPAREN:
goto finished;
case FMT_SLASH:
get_fnode (&head, &tail, FMT_SLASH);
tail->repeat = 1;
/* Fall Through */
case FMT_COLON:
goto optional_comma;
case FMT_END:
error = unexpected_end;
goto finished;
default:
/* 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 ();
switch (t)
{
case FMT_COMMA:
break;
case FMT_RPAREN:
goto finished;
default: /* Assume that we have another format item */
saved_token = t;
break;
}
goto format_item;
finished:
return head;
}
