#include "config.h"
#include <ctype.h>
#include <string.h>
#include "libgfortran.h"
#include "io.h"
#define FARRAY_SIZE 200
static fnode *avail, array[FARRAY_SIZE];
static char *format_string, *string;
static const char *error;
static format_token saved_token;
static int value, format_string_len, reversion_ok;
static fnode *saved_format, colon_node = { FMT_COLON };
static 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 (int literal)
{
int c;
do
{
if (format_string_len == 0)
return -1;
format_string_len--;
c = toupper (*format_string++);
}
while (c == ' ' && !literal);
return c;
}
#define unget_char() { format_string--; format_string_len++; }
static fnode *
get_fnode (fnode ** head, fnode ** tail, format_token t)
{
fnode *f;
if (avail - array >= FARRAY_SIZE)
f = get_mem (sizeof (fnode));
else
{
f = 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 = format_string;
return f;
}
static void
free_fnode (fnode * f)
{
fnode *next;
for (; f; f = next)
{
next = f->next;
if (f->format == FMT_LPAREN)
free_fnode (f->u.child);
if (f < array || f >= array + FARRAY_SIZE)
free_mem (f);
}
}
void
free_fnodes (void)
{
if (avail - array >= FARRAY_SIZE)
free_fnode (&array[0]);
avail = array;
memset(array, 0, sizeof(avail[0]) * FARRAY_SIZE);
}
static format_token
format_lex (void)
{
format_token token;
int negative_flag;
int c;
char delim;
if (saved_token != FMT_NONE)
{
token = saved_token;
saved_token = FMT_NONE;
return token;
}
negative_flag = 0;
c = next_char (0);
switch (c)
{
case '-':
negative_flag = 1;
case '+':
c = next_char (0);
if (!isdigit (c))
{
token = FMT_UNKNOWN;
break;
}
value = c - '0';
for (;;)
{
c = next_char (0);
if (!isdigit (c))
break;
value = 10 * value + c - '0';
}
unget_char ();
if (negative_flag)
value = -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':
value = c - '0';
for (;;)
{
c = next_char (0);
if (!isdigit (c))
break;
value = 10 * value + c - '0';
}
unget_char ();
token = (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 (0))
{
case 'L':
token = FMT_TL;
break;
case 'R':
token = FMT_TR;
break;
default:
token = FMT_T;
unget_char ();
break;
}
break;
case '(':
token = FMT_LPAREN;
break;
case ')':
token = FMT_RPAREN;
break;
case 'X':
token = FMT_X;
break;
case 'S':
switch (next_char (0))
{
case 'S':
token = FMT_SS;
break;
case 'P':
token = FMT_SP;
break;
default:
token = FMT_S;
unget_char ();
break;
}
break;
case 'B':
switch (next_char (0))
{
case 'N':
token = FMT_BN;
break;
case 'Z':
token = FMT_BZ;
break;
default:
token = FMT_B;
unget_char ();
break;
}
break;
case '\'':
case '"':
delim = c;
string = format_string;
value = 0;
for (;;)
{
c = next_char (1);
if (c == -1)
{
token = FMT_BADSTRING;
error = bad_string;
break;
}
if (c == delim)
{
c = next_char (1);
if (c == -1)
{
token = FMT_BADSTRING;
error = bad_string;
break;
}
if (c != delim)
{
unget_char ();
token = FMT_STRING;
break;
}
}
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 (0))
{
case 'N':
token = FMT_EN;
break;
case 'S':
token = FMT_ES;
break;
default:
token = FMT_E;
unget_char ();
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 (void)
{
fnode *head, *tail;
format_token t, u, t2;
int repeat;
head = tail = NULL;
format_item:
t = format_lex ();
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:
case FMT_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:
error = "P descriptor requires leading scale factor";
goto finished;
case FMT_X:
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);
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);
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;
}
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;
}
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;
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_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;
case FMT_COLON:
goto optional_comma;
case FMT_END:
error = unexpected_end;
goto finished;
default:
error = "Missing comma in format";
goto finished;
}
optional_comma:
t = format_lex ();
switch (t)
{
case FMT_COMMA:
break;
case FMT_RPAREN:
goto finished;
default:
saved_token = t;
break;
}
goto format_item;
finished:
return head;
}
void
format_error (fnode * f, const char *message)
{
int width, i, j, offset;
char *p, buffer[300];
if (f != NULL)
format_string = f->source;
free_fnodes ();
st_sprintf (buffer, "%s\n", message);
j = format_string - ioparm.format;
offset = (j > 60) ? j - 40 : 0;
j -= offset;
width = ioparm.format_len - offset;
if (width > 80)
width = 80;
p = strchr (buffer, '\0');
memcpy (p, ioparm.format + offset, width);
p += width;
*p++ = '\n';
for (i = 1; i < j; i++)
*p++ = ' ';
*p++ = '^';
*p = '\0';
generate_error (ERROR_FORMAT, buffer);
}
void
parse_format (void)
{
format_string = ioparm.format;
format_string_len = ioparm.format_len;
saved_token = FMT_NONE;
error = NULL;
reversion_ok = 0;
g.reversion_flag = 0;
saved_format = NULL;
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);
}
static void
revert (void)
{
fnode *f, *r;
g.reversion_flag = 1;
r = NULL;
for (f = array[0].u.child; f; f = f->next)
if (f->format == FMT_LPAREN)
r = f;
array[0].current = r;
array[0].count = 0;
}
static fnode *
next_format0 (fnode * f)
{
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;
}
fnode *
next_format (void)
{
format_token t;
fnode *f;
if (saved_format != NULL)
{
f = saved_format;
saved_format = NULL;
goto done;
}
f = next_format0 (&array[0]);
if (f == NULL)
{
if (!reversion_ok)
{
return NULL;
}
reversion_ok = 0;
revert ();
f = next_format0 (&array[0]);
if (f == NULL)
{
format_error (NULL, reversion_error);
return NULL;
}
saved_format = f;
return &colon_node;
}
done:
t = f->format;
if (!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))
reversion_ok = 1;
return f;
}
void
unget_format (fnode * f)
{
saved_format = f;
}
#if 0
static void dump_format1 (fnode * f);
void
dump_format0 (fnode * f)
{
char *p;
int i;
switch (f->format)
{
case FMT_COLON:
st_printf (" :");
break;
case FMT_SLASH:
st_printf (" %d/", f->u.r);
break;
case FMT_DOLLAR:
st_printf (" $");
break;
case FMT_T:
st_printf (" T%d", f->u.n);
break;
case FMT_TR:
st_printf (" TR%d", f->u.n);
break;
case FMT_TL:
st_printf (" TL%d", f->u.n);
break;
case FMT_X:
st_printf (" %dX", f->u.n);
break;
case FMT_S:
st_printf (" S");
break;
case FMT_SS:
st_printf (" SS");
break;
case FMT_SP:
st_printf (" SP");
break;
case FMT_LPAREN:
if (f->repeat == 1)
st_printf (" (");
else
st_printf (" %d(", f->repeat);
dump_format1 (f->u.child);
st_printf (" )");
break;
case FMT_STRING:
st_printf (" '");
p = f->u.string.p;
for (i = f->u.string.length; i > 0; i--)
st_printf ("%c", *p++);
st_printf ("'");
break;
case FMT_P:
st_printf (" %dP", f->u.k);
break;
case FMT_I:
st_printf (" %dI%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
break;
case FMT_B:
st_printf (" %dB%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
break;
case FMT_O:
st_printf (" %dO%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
break;
case FMT_Z:
st_printf (" %dZ%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
break;
case FMT_BN:
st_printf (" BN");
break;
case FMT_BZ:
st_printf (" BZ");
break;
case FMT_D:
st_printf (" %dD%d.%d", f->repeat, f->u.real.w, f->u.real.d);
break;
case FMT_EN:
st_printf (" %dEN%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
f->u.real.e);
break;
case FMT_ES:
st_printf (" %dES%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
f->u.real.e);
break;
case FMT_F:
st_printf (" %dF%d.%d", f->repeat, f->u.real.w, f->u.real.d);
break;
case FMT_E:
st_printf (" %dE%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
f->u.real.e);
break;
case FMT_G:
st_printf (" %dG%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
f->u.real.e);
break;
case FMT_L:
st_printf (" %dL%d", f->repeat, f->u.w);
break;
case FMT_A:
st_printf (" %dA%d", f->repeat, f->u.w);
break;
default:
st_printf (" ???");
break;
}
}
static void
dump_format1 (fnode * f)
{
for (; f; f = f->next)
dump_format1 (f);
}
void
dump_format (void)
{
st_printf ("format = ");
dump_format0 (&array[0]);
st_printf ("\n");
}
void
next_test (void)
{
fnode *f;
int i;
for (i = 0; i < 20; i++)
{
f = next_format ();
if (f == NULL)
{
st_printf ("No format!\n");
break;
}
dump_format1 (f);
st_printf ("\n");
}
}
#endif