#include "config.h"
#include <ctype.h>
#include <string.h>
#include "libgfortran.h"
#include "io.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;
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 };
static const char posint_required[] = "Positive width required in format",
period_required[] = "Period required in format",
nonneg_required[] = "Nonnegative width required in format",
unexpected_element[] = "Unexpected element in format",
unexpected_end[] = "Unexpected end of format string",
bad_string[] = "Unterminated character constant in format",
bad_hollerith[] = "Hollerith constant extends past the end of the format",
reversion_error[] = "Exhausted data descriptors in format";
static int
next_char (format_data *fmt, int literal)
{
int c;
do
{
if (fmt->format_string_len == 0)
return -1;
fmt->format_string_len--;
c = toupper (*fmt->format_string++);
}
while (c == ' ' && !literal);
return c;
}
#define unget_char(fmt) \
{ fmt->format_string--; fmt->format_string_len++; }
static fnode *
get_fnode (format_data *fmt, fnode **head, fnode **tail, format_token t)
{
fnode *f;
if (fmt->avail == &fmt->last->array[FARRAY_SIZE])
{
fmt->last->next = get_mem (sizeof (fnode_array));
fmt->last = fmt->last->next;
fmt->last->next = NULL;
fmt->avail = &fmt->last->array[0];
}
f = fmt->avail++;
memset (f, '\0', sizeof (fnode));
if (*head == NULL)
*head = *tail = f;
else
{
(*tail)->next = f;
*tail = f;
}
f->format = t;
f->repeat = -1;
f->source = fmt->format_string;
return f;
}
void
free_format_data (st_parameter_dt *dtp)
{
fnode_array *fa, *fa_next;
format_data *fmt = dtp->u.p.fmt;
if (fmt == NULL)
return;
for (fa = fmt->array.next; fa; fa = fa_next)
{
fa_next = fa->next;
free_mem (fa);
}
free_mem (fmt);
dtp->u.p.fmt = NULL;
}
static format_token
format_lex (format_data *fmt)
{
format_token token;
int negative_flag;
int c;
char delim;
if (fmt->saved_token != FMT_NONE)
{
token = fmt->saved_token;
fmt->saved_token = FMT_NONE;
return token;
}
negative_flag = 0;
c = next_char (fmt, 0);
switch (c)
{
case '-':
negative_flag = 1;
case '+':
c = next_char (fmt, 0);
if (!isdigit (c))
{
token = FMT_UNKNOWN;
break;
}
fmt->value = c - '0';
for (;;)
{
c = next_char (fmt, 0);
if (!isdigit (c))
break;
fmt->value = 10 * fmt->value + c - '0';
}
unget_char (fmt);
if (negative_flag)
fmt->value = -fmt->value;
token = FMT_SIGNED_INT;
break;
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
case '8':
case '9':
fmt->value = c - '0';
for (;;)
{
c = next_char (fmt, 0);
if (!isdigit (c))
break;
fmt->value = 10 * fmt->value + c - '0';
}
unget_char (fmt);
token = (fmt->value == 0) ? FMT_ZERO : FMT_POSINT;
break;
case '.':
token = FMT_PERIOD;
break;
case ',':
token = FMT_COMMA;
break;
case ':':
token = FMT_COLON;
break;
case '/':
token = FMT_SLASH;
break;
case '$':
token = FMT_DOLLAR;
break;
case 'T':
switch (next_char (fmt, 0))
{
case 'L':
token = FMT_TL;
break;
case 'R':
token = FMT_TR;
break;
default:
token = FMT_T;
unget_char (fmt);
break;
}
break;
case '(':
token = FMT_LPAREN;
break;
case ')':
token = FMT_RPAREN;
break;
case 'X':
token = FMT_X;
break;
case 'S':
switch (next_char (fmt, 0))
{
case 'S':
token = FMT_SS;
break;
case 'P':
token = FMT_SP;
break;
default:
token = FMT_S;
unget_char (fmt);
break;
}
break;
case 'B':
switch (next_char (fmt, 0))
{
case 'N':
token = FMT_BN;
break;
case 'Z':
token = FMT_BZ;
break;
default:
token = FMT_B;
unget_char (fmt);
break;
}
break;
case '\'':
case '"':
delim = c;
fmt->string = fmt->format_string;
fmt->value = 0;
for (;;)
{
c = next_char (fmt, 1);
if (c == -1)
{
token = FMT_BADSTRING;
fmt->error = bad_string;
break;
}
if (c == delim)
{
c = next_char (fmt, 1);
if (c == -1)
{
token = FMT_BADSTRING;
fmt->error = bad_string;
break;
}
if (c != delim)
{
unget_char (fmt);
token = FMT_STRING;
break;
}
}
fmt->value++;
}
break;
case 'P':
token = FMT_P;
break;
case 'I':
token = FMT_I;
break;
case 'O':
token = FMT_O;
break;
case 'Z':
token = FMT_Z;
break;
case 'F':
token = FMT_F;
break;
case 'E':
switch (next_char (fmt, 0))
{
case 'N':
token = FMT_EN;
break;
case 'S':
token = FMT_ES;
break;
default:
token = FMT_E;
unget_char (fmt);
break;
}
break;
case 'G':
token = FMT_G;
break;
case 'H':
token = FMT_H;
break;
case 'L':
token = FMT_L;
break;
case 'A':
token = FMT_A;
break;
case 'D':
token = FMT_D;
break;
case -1:
token = FMT_END;
break;
default:
token = FMT_UNKNOWN;
break;
}
return token;
}
static fnode *
parse_format_list (st_parameter_dt *dtp)
{
fnode *head, *tail;
format_token t, u, t2;
int repeat;
format_data *fmt = dtp->u.p.fmt;
head = tail = NULL;
format_item:
t = format_lex (fmt);
format_item_1:
switch (t)
{
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);
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);
if (fmt->error != NULL)
goto finished;
goto between_desc;
case FMT_SIGNED_INT:
case FMT_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;
}
fmt->saved_token = t;
goto optional_comma;
case FMT_P:
fmt->error = "P descriptor requires leading scale factor";
goto finished;
case FMT_X:
get_fnode (fmt, &head, &tail, FMT_X);
tail->repeat = 1;
tail->u.k = 1;
goto between_desc;
case FMT_STRING:
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_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;
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;
}
data_desc:
switch (t)
{
case FMT_P:
t = format_lex (fmt);
if (t == FMT_POSINT)
{
fmt->error = "Repeat count cannot follow P descriptor";
goto finished;
}
fmt->saved_token = t;
get_fnode (fmt, &head, &tail, FMT_P);
goto optional_comma;
case FMT_L:
t = format_lex (fmt);
if (t != FMT_POSINT)
{
if (notification_std(GFC_STD_GNU) == ERROR)
{
fmt->error = posint_required;
goto finished;
}
else
{
fmt->saved_token = t;
fmt->value = 1;
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_POSINT)
{
fmt->saved_token = t;
fmt->value = -1;
}
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_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)
{
if (compile_options.warn_std != 0)
{
fmt->error = period_required;
goto finished;
}
fmt->saved_token = t;
tail->u.real.d = 0;
break;
}
t = format_lex (fmt);
if (t != FMT_ZERO && t != FMT_POSINT)
{
fmt->error = nonneg_required;
goto finished;
}
tail->u.real.d = fmt->value;
if (t == FMT_D || t == FMT_F)
break;
tail->u.real.e = -1;
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_desc:
t = format_lex (fmt);
switch (t)
{
case FMT_COMMA:
goto format_item;
case FMT_RPAREN:
goto finished;
case FMT_SLASH:
get_fnode (fmt, &head, &tail, FMT_SLASH);
tail->repeat = 1;
goto optional_comma;
case FMT_COLON:
get_fnode (fmt, &head, &tail, FMT_COLON);
tail->repeat = 1;
goto optional_comma;
case FMT_END:
fmt->error = unexpected_end;
goto finished;
default:
goto format_item_1;
}
optional_comma:
t = format_lex (fmt);
switch (t)
{
case FMT_COMMA:
break;
case FMT_RPAREN:
goto finished;
default:
fmt->saved_token = t;
break;
}
goto format_item;
finished:
return head;
}
void
format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
{
int width, i, j, offset;
char *p, buffer[300];
format_data *fmt = dtp->u.p.fmt;
if (f != NULL)
fmt->format_string = f->source;
st_sprintf (buffer, "%s\n", message);
j = fmt->format_string - dtp->format;
offset = (j > 60) ? j - 40 : 0;
j -= offset;
width = dtp->format_len - offset;
if (width > 80)
width = 80;
p = strchr (buffer, '\0');
memcpy (p, dtp->format + offset, width);
p += width;
*p++ = '\n';
for (i = 1; i < j; i++)
*p++ = ' ';
*p++ = '^';
*p = '\0';
generate_error (&dtp->common, ERROR_FORMAT, buffer);
}
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;
fmt->reversion_ok = 0;
fmt->saved_format = NULL;
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 void
revert (st_parameter_dt *dtp)
{
fnode *f, *r;
format_data *fmt = dtp->u.p.fmt;
dtp->u.p.reversion_flag = 1;
r = NULL;
for (f = fmt->array.array[0].u.child; f; f = f->next)
if (f->format == FMT_LPAREN)
r = f;
fmt->array.array[0].current = r;
fmt->array.array[0].count = 0;
}
static const fnode *
next_format0 (fnode * f)
{
const fnode *r;
if (f == NULL)
return NULL;
if (f->format != FMT_LPAREN)
{
f->count++;
if (f->count <= f->repeat)
return f;
f->count = 0;
return NULL;
}
for (; f->count < f->repeat; f->count++)
{
if (f->current == NULL)
f->current = f->u.child;
for (; f->current != NULL; f->current = f->current->next)
{
r = next_format0 (f->current);
if (r != NULL)
return r;
}
}
f->count = 0;
return NULL;
}
const fnode *
next_format (st_parameter_dt *dtp)
{
format_token t;
const fnode *f;
format_data *fmt = dtp->u.p.fmt;
if (fmt->saved_format != NULL)
{
f = fmt->saved_format;
fmt->saved_format = NULL;
goto done;
}
f = next_format0 (&fmt->array.array[0]);
if (f == NULL)
{
if (!fmt->reversion_ok)
return NULL;
fmt->reversion_ok = 0;
revert (dtp);
f = next_format0 (&fmt->array.array[0]);
if (f == NULL)
{
format_error (dtp, NULL, reversion_error);
return NULL;
}
fmt->saved_format = f;
return &colon_node;
}
done:
t = f->format;
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))
fmt->reversion_ok = 1;
return f;
}
void
unget_format (st_parameter_dt *dtp, const fnode *f)
{
dtp->u.p.fmt->saved_format = f;
}