OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
455f19cb1c
gcc/libgfortran/io/format.c
Paul Brook d809264e86 format.c (parse_format_list): Set repeat count for P descriptors. 
* io/format.c (parse_format_list): Set repeat count for P descriptors.
	* write.c (output_float): Fix condition.  Correctly handle nonzero
	scale factor.
testsuite/
	* gfortran.dg/edit_real_1.f90: Add new tests.

From-SVN: r86952
2004-09-02 01:33:01 +00:00

1288 lines
24 KiB
C
Raw Blame History

/* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Libgfortran; see the file COPYING. If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA. */
/* format.c-- parse a FORMAT string into a binary format suitable for
* interpretation during I/O statements */
#include "config.h"
#include <ctype.h>
#include <string.h>
#include "libgfortran.h"
#include "io.h"
/* Number of format nodes that we can store statically before we have
* to resort to dynamic allocation. The root node is array[0]. */
#define FARRAY_SIZE 200
static fnode *avail, array[FARRAY_SIZE];
/* Local variables for checking format strings. The saved_token is
* used to back up by a single format token during the parsing process. */
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 };
/* Error messages */
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";
/* 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. */
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;
}
/* unget_char()-- Back up one character position. */
#define unget_char() { format_string--; format_string_len++; }
/* get_fnode()-- Allocate a new format node, inserting it into the
* current singly linked list. These are initially allocated from the
* static buffer. */
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;
}
/* free_fnode()-- Recursive function to free the given fnode and
* everything it points to. We only have to actually free something
* if it is outside of the static array. */
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);
}
}
/* free_fnodes()-- Free the current tree of fnodes. We only have to
* traverse the tree if some nodes were allocated dynamically. */
void
free_fnodes (void)
{
if (avail - array >= FARRAY_SIZE)
free_fnode (&array[0]);
avail = array;
memset(array, 0, sizeof(avail[0]) * FARRAY_SIZE);
}
/* format_lex()-- Simple lexical analyzer for getting the next token
* in a FORMAT string. We support a one-level token pushback in the
* saved_token variable. */
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;
/* Fall Through */
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; /* This is the length of the string */
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;
}
/* 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. */
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 ();
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);
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;
}
/* 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:
error = "Missing comma in format";
goto finished;
}
/* 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;
}
/* 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.
*
* After freeing any dynamically allocated fnodes, 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 (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;
/* Show the format */
p = strchr (buffer, '\0');
memcpy (p, ioparm.format + offset, width);
p += width;
*p++ = '\n';
/* Show where the problem is */
for (i = 1; i < j; i++)
*p++ = ' ';
*p++ = '^';
*p = '\0';
generate_error (ERROR_FORMAT, buffer);
}
/* parse_format()-- Parse a format string. */
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);
}
/* 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. */
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;
/* If r is NULL because no node was found, the whole tree will be used */
array[0].current = r;
array[0].count = 0;
}
/* 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. */
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;
}
/* Deal with a parenthesis node */
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;
}
/* next_format()-- Return the next format node. If the format list
* ends up being exhausted, we do reversion. Reversion is only
* allowed if the we've seen a data descriptor since the
* initialization or the last reversion. We return NULL if the there
* are no more data descriptors to return (which is an error
* condition). */
fnode *
next_format (void)
{
format_token t;
fnode *f;
if (saved_format != NULL)
{ /* Deal with a pushed-back format node */
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;
}
/* Push the first reverted token and return a colon node in case
* there are no more data items. */
saved_format = f;
return &colon_node;
}
/* If this is a data edit descriptor, then reversion has become OK. */
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;
}
/* 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). */
void
unget_format (fnode * f)
{
saved_format = f;
}
#if 0
static void dump_format1 (fnode * f);
/* dump_format0()-- Dump a single format node */
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;
}
}
/* dump_format1()-- Dump a string of format nodes */
static void
dump_format1 (fnode * f)
{
for (; f; f = f->next)
dump_format1 (f);
}
/* dump_format()-- Dump the whole format node tree */
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
Reference in New Issue View Git Blame Copy Permalink