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
read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
int w, seen_dp, exponent;
int exponent_sign;
const char *p;
char *buffer;
char *out;
int seen_int_digit; /* Seen a digit before the decimal point? */
int seen_dec_digit; /* Seen a digit after the decimal point? */
seen_dp = 0;
seen_int_digit = 0;
seen_dec_digit = 0;
exponent_sign = 1;
exponent = 0;
w = f->u.w;
/* Read in the next block. */
p = read_block_form (dtp, &w);
if (p == NULL)
return;
p = eat_leading_spaces (&w, (char*) p);
if (w == 0)
goto zero;
/* In this buffer we're going to re-format the number cleanly to be parsed
by convert_real in the end; this assures we're using strtod from the
C library for parsing and thus probably get the best accuracy possible.
This process may add a '+0.0' in front of the number as well as change the
exponent because of an implicit decimal point or the like. Thus allocating
strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
original buffer had should be enough. */
buffer = gfc_alloca (w + 11);
out = buffer;
/* Optional sign */
if (*p == '-' || *p == '+')
{
if (*p == '-')
*(out++) = '-';
++p;
--w;
}
p = eat_leading_spaces (&w, (char*) p);
if (w == 0)
goto zero;
/* Check for Infinity or NaN. */
if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))))
{
int seen_paren = 0;
char *save = out;
/* Scan through the buffer keeping track of spaces and parenthesis. We
null terminate the string as soon as we see a left paren or if we are
BLANK_NULL mode. Leading spaces have already been skipped above,
trailing spaces are ignored by converting to '\0'. A space
between "NaN" and the optional perenthesis is not permitted. */
while (w > 0)
{
*out = tolower (*p);
switch (*p)
{
case ' ':
if (dtp->u.p.blank_status == BLANK_ZERO)
{
*out = '0';
break;
}
*out = '\0';
if (seen_paren == 1)
goto bad_float;
break;
case '(':
seen_paren++;
*out = '\0';
break;
case ')':
if (seen_paren++ != 1)
goto bad_float;
break;
default:
if (!isalnum (*out))
goto bad_float;
}
--w;
++p;
++out;
}
*out = '\0';
if (seen_paren != 0 && seen_paren != 2)
goto bad_float;
if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0))
{
if (seen_paren)
goto bad_float;
}
else if (strcmp (save, "nan") != 0)
goto bad_float;
convert_infnan (dtp, dest, buffer, length);
return;
}
/* Process the mantissa string. */
while (w > 0)
{
switch (*p)
{
case ',':
if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
goto bad_float;
/* Fall through. */
case '.':
if (seen_dp)
goto bad_float;
if (!seen_int_digit)
*(out++) = '0';
*(out++) = '.';
seen_dp = 1;
break;
case ' ':
if (dtp->u.p.blank_status == BLANK_ZERO)
{
*(out++) = '0';
goto found_digit;
}
else if (dtp->u.p.blank_status == BLANK_NULL)
break;
else
/* TODO: Should we check instead that there are only trailing
blanks here, as is done below for exponents? */
goto done;
/* Fall through. */
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
case '8':
case '9':
*(out++) = *p;
found_digit:
if (!seen_dp)
seen_int_digit = 1;
else
seen_dec_digit = 1;
break;
case '-':
case '+':
goto exponent;
case 'e':
case 'E':
case 'd':
case 'D':
case 'q':
case 'Q':
++p;
--w;
goto exponent;
default:
goto bad_float;
}
++p;
--w;
}
/* No exponent has been seen, so we use the current scale factor. */
exponent = - dtp->u.p.scale_factor;
goto done;
/* At this point the start of an exponent has been found. */
exponent:
p = eat_leading_spaces (&w, (char*) p);
if (*p == '-' || *p == '+')
{
if (*p == '-')
exponent_sign = -1;
++p;
--w;
}
/* At this point a digit string is required. We calculate the value
of the exponent in order to take account of the scale factor and
the d parameter before explict conversion takes place. */
if (w == 0)
goto bad_float;
if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
{
while (w > 0 && isdigit (*p))
{
exponent *= 10;
exponent += *p - '0';
++p;
--w;
}
/* Only allow trailing blanks. */
while (w > 0)
{
if (*p != ' ')
goto bad_float;
++p;
--w;
}
}
else /* BZ or BN status is enabled. */
{
while (w > 0)
{
if (*p == ' ')
{
if (dtp->u.p.blank_status == BLANK_ZERO)
exponent *= 10;
else
assert (dtp->u.p.blank_status == BLANK_NULL);
}
else if (!isdigit (*p))
goto bad_float;
else
{
exponent *= 10;
exponent += *p - '0';
}
++p;
--w;
}
}
exponent *= exponent_sign;
done:
/* Use the precision specified in the format if no decimal point has been
seen. */
if (!seen_dp)
exponent -= f->u.real.d;
/* Output a trailing '0' after decimal point if not yet found. */
if (seen_dp && !seen_dec_digit)
*(out++) = '0';
/* Handle input of style "E+NN" by inserting a 0 for the
significand. */
else if (!seen_int_digit && !seen_dec_digit)
{
notify_std (&dtp->common, GFC_STD_LEGACY,
"REAL input of style 'E+NN'");
*(out++) = '0';
}
/* Print out the exponent to finish the reformatted number. Maximum 4
digits for the exponent. */
if (exponent != 0)
{
int dig;
*(out++) = 'e';
if (exponent < 0)
{
*(out++) = '-';
exponent = - exponent;
}
assert (exponent < 10000);
for (dig = 3; dig >= 0; --dig)
{
out[dig] = (char) ('0' + exponent % 10);
exponent /= 10;
}
out += 4;
}
*(out++) = '\0';
/* Do the actual conversion. */
convert_real (dtp, dest, buffer, length);
return;
/* The value read is zero. */
zero:
switch (length)
{
case 4:
*((GFC_REAL_4 *) dest) = 0.0;
break;
case 8:
*((GFC_REAL_8 *) dest) = 0.0;
break;
#ifdef HAVE_GFC_REAL_10
case 10:
*((GFC_REAL_10 *) dest) = 0.0;
break;
#endif
#ifdef HAVE_GFC_REAL_16
case 16:
*((GFC_REAL_16 *) dest) = 0.0;
break;
#endif
default:
internal_error (&dtp->common, "Unsupported real kind during IO");
}
return;
bad_float:
generate_error (&dtp->common, LIBERROR_READ_VALUE,
"Bad value during floating point read");
next_record (dtp, 1);
return;
}
static void
edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
{
/* Complain about attempts to change the unchangeable. */
if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
u->flags.status != flags->status)
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot change STATUS parameter in OPEN statement");
if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot change ACCESS parameter in OPEN statement");
if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot change FORM parameter in OPEN statement");
if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)
&& opp->recl_in != u->recl)
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot change RECL parameter in OPEN statement");
if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action)
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot change ACTION parameter in OPEN statement");
/* Status must be OLD if present. */
if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
flags->status != STATUS_UNKNOWN)
{
if (flags->status == STATUS_SCRATCH)
notify_std (&opp->common, GFC_STD_GNU,
"OPEN statement must have a STATUS of OLD or UNKNOWN");
else
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"OPEN statement must have a STATUS of OLD or UNKNOWN");
}
if (u->flags.form == FORM_UNFORMATTED)
{
if (flags->delim != DELIM_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"DELIM parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->blank != BLANK_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"BLANK parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->pad != PAD_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"PAD parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->decimal != DECIMAL_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"DECIMAL parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->encoding != ENCODING_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"ENCODING parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->round != ROUND_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"ROUND parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->sign != SIGN_UNSPECIFIED)
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"SIGN parameter conflicts with UNFORMATTED form in "
"OPEN statement");
}
if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
{
/* Change the changeable: */
if (flags->blank != BLANK_UNSPECIFIED)
u->flags.blank = flags->blank;
if (flags->delim != DELIM_UNSPECIFIED)
u->flags.delim = flags->delim;
if (flags->pad != PAD_UNSPECIFIED)
u->flags.pad = flags->pad;
if (flags->decimal != DECIMAL_UNSPECIFIED)
u->flags.decimal = flags->decimal;
if (flags->encoding != ENCODING_UNSPECIFIED)
u->flags.encoding = flags->encoding;
if (flags->async != ASYNC_UNSPECIFIED)
u->flags.async = flags->async;
if (flags->round != ROUND_UNSPECIFIED)
u->flags.round = flags->round;
if (flags->sign != SIGN_UNSPECIFIED)
u->flags.sign = flags->sign;
}
/* Reposition the file if necessary. */
switch (flags->position)
{
case POSITION_UNSPECIFIED:
case POSITION_ASIS:
break;
case POSITION_REWIND:
if (sseek (u->s, 0, SEEK_SET) != 0)
goto seek_error;
u->current_record = 0;
u->last_record = 0;
test_endfile (u);
break;
case POSITION_APPEND:
if (sseek (u->s, 0, SEEK_END) < 0)
goto seek_error;
if (flags->access != ACCESS_STREAM)
u->current_record = 0;
u->endfile = AT_ENDFILE; /* We are at the end. */
break;
seek_error:
generate_error (&opp->common, LIBERROR_OS, NULL);
break;
}
unlock_unit (u);
}
void
st_open (st_parameter_open *opp)
{
unit_flags flags;
gfc_unit *u = NULL;
GFC_INTEGER_4 cf = opp->common.flags;
unit_convert conv;
library_start (&opp->common);
/* Decode options. */
flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
find_option (&opp->common, opp->access, opp->access_len,
access_opt, "Bad ACCESS parameter in OPEN statement");
flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
find_option (&opp->common, opp->action, opp->action_len,
action_opt, "Bad ACTION parameter in OPEN statement");
flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
find_option (&opp->common, opp->blank, opp->blank_len,
blank_opt, "Bad BLANK parameter in OPEN statement");
flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
find_option (&opp->common, opp->delim, opp->delim_len,
delim_opt, "Bad DELIM parameter in OPEN statement");
flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
find_option (&opp->common, opp->pad, opp->pad_len,
pad_opt, "Bad PAD parameter in OPEN statement");
flags.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
find_option (&opp->common, opp->decimal, opp->decimal_len,
decimal_opt, "Bad DECIMAL parameter in OPEN statement");
flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED :
find_option (&opp->common, opp->encoding, opp->encoding_len,
encoding_opt, "Bad ENCODING parameter in OPEN statement");
flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED :
find_option (&opp->common, opp->asynchronous, opp->asynchronous_len,
async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement");
flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED :
find_option (&opp->common, opp->round, opp->round_len,
round_opt, "Bad ROUND parameter in OPEN statement");
flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED :
find_option (&opp->common, opp->sign, opp->sign_len,
sign_opt, "Bad SIGN parameter in OPEN statement");
flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
find_option (&opp->common, opp->form, opp->form_len,
form_opt, "Bad FORM parameter in OPEN statement");
flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
find_option (&opp->common, opp->position, opp->position_len,
position_opt, "Bad POSITION parameter in OPEN statement");
flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
find_option (&opp->common, opp->status, opp->status_len,
status_opt, "Bad STATUS parameter in OPEN statement");
/* First, we check wether the convert flag has been set via environment
variable. This overrides the convert tag in the open statement. */
conv = get_unformatted_convert (opp->common.unit);
if (conv == GFC_CONVERT_NONE)
{
/* Nothing has been set by environment variable, check the convert tag. */
if (cf & IOPARM_OPEN_HAS_CONVERT)
conv = find_option (&opp->common, opp->convert, opp->convert_len,
convert_opt,
"Bad CONVERT parameter in OPEN statement");
else
conv = compile_options.convert;
}
/* We use big_endian, which is 0 on little-endian machines
and 1 on big-endian machines. */
switch (conv)
{
case GFC_CONVERT_NATIVE:
case GFC_CONVERT_SWAP:
break;
case GFC_CONVERT_BIG:
conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
break;
case GFC_CONVERT_LITTLE:
conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
break;
default:
internal_error (&opp->common, "Illegal value for CONVERT");
break;
}
flags.convert = conv;
if (flags.position != POSITION_UNSPECIFIED
&& flags.access == ACCESS_DIRECT)
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot use POSITION with direct access files");
if (flags.access == ACCESS_APPEND)
{
if (flags.position != POSITION_UNSPECIFIED
&& flags.position != POSITION_APPEND)
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Conflicting ACCESS and POSITION flags in"
" OPEN statement");
notify_std (&opp->common, GFC_STD_GNU,
"Extension: APPEND as a value for ACCESS in OPEN statement");
flags.access = ACCESS_SEQUENTIAL;
flags.position = POSITION_APPEND;
}
if (flags.position == POSITION_UNSPECIFIED)
flags.position = POSITION_ASIS;
if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
{
if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT))
opp->common.unit = get_unique_unit_number(opp);
else if (opp->common.unit < 0)
{
u = find_unit (opp->common.unit);
if (u == NULL) /* Negative unit and no NEWUNIT-created unit found. */
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Bad unit number in OPEN statement");
}
if (u == NULL)
u = find_or_create_unit (opp->common.unit);
if (u->s == NULL)
{
u = new_unit (opp, u, &flags);
if (u != NULL)
unlock_unit (u);
}
else
already_open (opp, u, &flags);
}
if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT)
&& (opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
*opp->newunit = opp->common.unit;
library_end ();
}
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;
}
