fa347f2232
2008-01-05 Jerry DeLisle <jvdelisle@gcc.gnu.org> PR libfortran/34676 * io/list_read.c (next_char): Only save the EOF condition for later if advance="no". From-SVN: r131337
2930 lines
60 KiB
C
2930 lines
60 KiB
C
/* Copyright (C) 2002, 2003, 2004, 2005, 2007 Free Software Foundation, Inc.
|
|
Contributed by Andy Vaught
|
|
Namelist input contributed by Paul Thomas
|
|
|
|
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.
|
|
|
|
In addition to the permissions in the GNU General Public License, the
|
|
Free Software Foundation gives you unlimited permission to link the
|
|
compiled version of this file into combinations with other programs,
|
|
and to distribute those combinations without any restriction coming
|
|
from the use of this file. (The General Public License restrictions
|
|
do apply in other respects; for example, they cover modification of
|
|
the file, and distribution when not linked into a combine
|
|
executable.)
|
|
|
|
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, 51 Franklin Street, Fifth Floor,
|
|
Boston, MA 02110-1301, USA. */
|
|
|
|
|
|
#include "io.h"
|
|
#include <string.h>
|
|
#include <ctype.h>
|
|
|
|
|
|
/* List directed input. Several parsing subroutines are practically
|
|
reimplemented from formatted input, the reason being that there are
|
|
all kinds of small differences between formatted and list directed
|
|
parsing. */
|
|
|
|
|
|
/* Subroutines for reading characters from the input. Because a
|
|
repeat count is ambiguous with an integer, we have to read the
|
|
whole digit string before seeing if there is a '*' which signals
|
|
the repeat count. Since we can have a lot of potential leading
|
|
zeros, we have to be able to back up by arbitrary amount. Because
|
|
the input might not be seekable, we have to buffer the data
|
|
ourselves. */
|
|
|
|
#define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
|
|
case '5': case '6': case '7': case '8': case '9'
|
|
|
|
#define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
|
|
case '\r'
|
|
|
|
/* This macro assumes that we're operating on a variable. */
|
|
|
|
#define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
|
|
|| c == '\t' || c == '\r')
|
|
|
|
/* Maximum repeat count. Less than ten times the maximum signed int32. */
|
|
|
|
#define MAX_REPEAT 200000000
|
|
|
|
|
|
/* Save a character to a string buffer, enlarging it as necessary. */
|
|
|
|
static void
|
|
push_char (st_parameter_dt *dtp, char c)
|
|
{
|
|
char *new;
|
|
|
|
if (dtp->u.p.saved_string == NULL)
|
|
{
|
|
if (dtp->u.p.scratch == NULL)
|
|
dtp->u.p.scratch = get_mem (SCRATCH_SIZE);
|
|
dtp->u.p.saved_string = dtp->u.p.scratch;
|
|
memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE);
|
|
dtp->u.p.saved_length = SCRATCH_SIZE;
|
|
dtp->u.p.saved_used = 0;
|
|
}
|
|
|
|
if (dtp->u.p.saved_used >= dtp->u.p.saved_length)
|
|
{
|
|
dtp->u.p.saved_length = 2 * dtp->u.p.saved_length;
|
|
new = get_mem (2 * dtp->u.p.saved_length);
|
|
|
|
memset (new, 0, 2 * dtp->u.p.saved_length);
|
|
|
|
memcpy (new, dtp->u.p.saved_string, dtp->u.p.saved_used);
|
|
if (dtp->u.p.saved_string != dtp->u.p.scratch)
|
|
free_mem (dtp->u.p.saved_string);
|
|
|
|
dtp->u.p.saved_string = new;
|
|
}
|
|
|
|
dtp->u.p.saved_string[dtp->u.p.saved_used++] = c;
|
|
}
|
|
|
|
|
|
/* Free the input buffer if necessary. */
|
|
|
|
static void
|
|
free_saved (st_parameter_dt *dtp)
|
|
{
|
|
if (dtp->u.p.saved_string == NULL)
|
|
return;
|
|
|
|
if (dtp->u.p.saved_string != dtp->u.p.scratch)
|
|
free_mem (dtp->u.p.saved_string);
|
|
|
|
dtp->u.p.saved_string = NULL;
|
|
dtp->u.p.saved_used = 0;
|
|
}
|
|
|
|
|
|
/* Free the line buffer if necessary. */
|
|
|
|
static void
|
|
free_line (st_parameter_dt *dtp)
|
|
{
|
|
if (dtp->u.p.line_buffer == NULL)
|
|
return;
|
|
|
|
free_mem (dtp->u.p.line_buffer);
|
|
dtp->u.p.line_buffer = NULL;
|
|
}
|
|
|
|
|
|
static char
|
|
next_char (st_parameter_dt *dtp)
|
|
{
|
|
int length;
|
|
gfc_offset record;
|
|
char c, *p;
|
|
|
|
if (dtp->u.p.last_char != '\0')
|
|
{
|
|
dtp->u.p.at_eol = 0;
|
|
c = dtp->u.p.last_char;
|
|
dtp->u.p.last_char = '\0';
|
|
goto done;
|
|
}
|
|
|
|
/* Read from line_buffer if enabled. */
|
|
|
|
if (dtp->u.p.line_buffer_enabled)
|
|
{
|
|
dtp->u.p.at_eol = 0;
|
|
|
|
c = dtp->u.p.line_buffer[dtp->u.p.item_count];
|
|
if (c != '\0' && dtp->u.p.item_count < 64)
|
|
{
|
|
dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0';
|
|
dtp->u.p.item_count++;
|
|
goto done;
|
|
}
|
|
|
|
dtp->u.p.item_count = 0;
|
|
dtp->u.p.line_buffer_enabled = 0;
|
|
}
|
|
|
|
/* Handle the end-of-record and end-of-file conditions for
|
|
internal array unit. */
|
|
if (is_array_io (dtp))
|
|
{
|
|
if (dtp->u.p.at_eof)
|
|
longjmp (*dtp->u.p.eof_jump, 1);
|
|
|
|
/* Check for "end-of-record" condition. */
|
|
if (dtp->u.p.current_unit->bytes_left == 0)
|
|
{
|
|
int finished;
|
|
|
|
c = '\n';
|
|
record = next_array_record (dtp, dtp->u.p.current_unit->ls,
|
|
&finished);
|
|
|
|
/* Check for "end-of-file" condition. */
|
|
if (finished)
|
|
{
|
|
dtp->u.p.at_eof = 1;
|
|
goto done;
|
|
}
|
|
|
|
record *= dtp->u.p.current_unit->recl;
|
|
if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
|
|
longjmp (*dtp->u.p.eof_jump, 1);
|
|
|
|
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
|
|
goto done;
|
|
}
|
|
}
|
|
|
|
/* Get the next character and handle end-of-record conditions. */
|
|
|
|
length = 1;
|
|
|
|
p = salloc_r (dtp->u.p.current_unit->s, &length);
|
|
|
|
if (is_stream_io (dtp))
|
|
dtp->u.p.current_unit->strm_pos++;
|
|
|
|
if (is_internal_unit (dtp))
|
|
{
|
|
if (is_array_io (dtp))
|
|
{
|
|
/* End of record is handled in the next pass through, above. The
|
|
check for NULL here is cautionary. */
|
|
if (p == NULL)
|
|
{
|
|
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
|
|
return '\0';
|
|
}
|
|
|
|
dtp->u.p.current_unit->bytes_left--;
|
|
c = *p;
|
|
}
|
|
else
|
|
{
|
|
if (p == NULL)
|
|
longjmp (*dtp->u.p.eof_jump, 1);
|
|
if (length == 0)
|
|
c = '\n';
|
|
else
|
|
c = *p;
|
|
}
|
|
}
|
|
else
|
|
{
|
|
if (p == NULL)
|
|
{
|
|
generate_error (&dtp->common, LIBERROR_OS, NULL);
|
|
return '\0';
|
|
}
|
|
if (length == 0)
|
|
{
|
|
if (dtp->u.p.advance_status == ADVANCE_NO)
|
|
{
|
|
if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
|
|
longjmp (*dtp->u.p.eof_jump, 1);
|
|
dtp->u.p.current_unit->endfile = AT_ENDFILE;
|
|
c = '\n';
|
|
}
|
|
else
|
|
longjmp (*dtp->u.p.eof_jump, 1);
|
|
}
|
|
else
|
|
c = *p;
|
|
}
|
|
done:
|
|
dtp->u.p.at_eol = (c == '\n' || c == '\r');
|
|
return c;
|
|
}
|
|
|
|
|
|
/* Push a character back onto the input. */
|
|
|
|
static void
|
|
unget_char (st_parameter_dt *dtp, char c)
|
|
{
|
|
dtp->u.p.last_char = c;
|
|
}
|
|
|
|
|
|
/* Skip over spaces in the input. Returns the nonspace character that
|
|
terminated the eating and also places it back on the input. */
|
|
|
|
static char
|
|
eat_spaces (st_parameter_dt *dtp)
|
|
{
|
|
char c;
|
|
|
|
do
|
|
{
|
|
c = next_char (dtp);
|
|
}
|
|
while (c == ' ' || c == '\t');
|
|
|
|
unget_char (dtp, c);
|
|
return c;
|
|
}
|
|
|
|
|
|
/* This function reads characters through to the end of the current line and
|
|
just ignores them. */
|
|
|
|
static void
|
|
eat_line (st_parameter_dt *dtp)
|
|
{
|
|
char c;
|
|
if (!is_internal_unit (dtp))
|
|
do
|
|
c = next_char (dtp);
|
|
while (c != '\n');
|
|
}
|
|
|
|
|
|
/* Skip over a separator. Technically, we don't always eat the whole
|
|
separator. This is because if we've processed the last input item,
|
|
then a separator is unnecessary. Plus the fact that operating
|
|
systems usually deliver console input on a line basis.
|
|
|
|
The upshot is that if we see a newline as part of reading a
|
|
separator, we stop reading. If there are more input items, we
|
|
continue reading the separator with finish_separator() which takes
|
|
care of the fact that we may or may not have seen a comma as part
|
|
of the separator. */
|
|
|
|
static void
|
|
eat_separator (st_parameter_dt *dtp)
|
|
{
|
|
char c, n;
|
|
|
|
eat_spaces (dtp);
|
|
dtp->u.p.comma_flag = 0;
|
|
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
case ',':
|
|
dtp->u.p.comma_flag = 1;
|
|
eat_spaces (dtp);
|
|
break;
|
|
|
|
case '/':
|
|
dtp->u.p.input_complete = 1;
|
|
break;
|
|
|
|
case '\r':
|
|
dtp->u.p.at_eol = 1;
|
|
n = next_char(dtp);
|
|
if (n == '\n')
|
|
{
|
|
if (dtp->u.p.namelist_mode)
|
|
{
|
|
do
|
|
c = next_char (dtp);
|
|
while (c == '\n' || c == '\r' || c == ' ');
|
|
unget_char (dtp, c);
|
|
}
|
|
}
|
|
else
|
|
unget_char (dtp, n);
|
|
break;
|
|
|
|
case '\n':
|
|
dtp->u.p.at_eol = 1;
|
|
if (dtp->u.p.namelist_mode)
|
|
{
|
|
do
|
|
{
|
|
c = next_char (dtp);
|
|
if (c == '!')
|
|
{
|
|
eat_line (dtp);
|
|
c = next_char (dtp);
|
|
}
|
|
}
|
|
while (c == '\n' || c == '\r' || c == ' ');
|
|
unget_char (dtp, c);
|
|
}
|
|
break;
|
|
|
|
case '!':
|
|
if (dtp->u.p.namelist_mode)
|
|
{ /* Eat a namelist comment. */
|
|
do
|
|
c = next_char (dtp);
|
|
while (c != '\n');
|
|
|
|
break;
|
|
}
|
|
|
|
/* Fall Through... */
|
|
|
|
default:
|
|
unget_char (dtp, c);
|
|
break;
|
|
}
|
|
}
|
|
|
|
|
|
/* Finish processing a separator that was interrupted by a newline.
|
|
If we're here, then another data item is present, so we finish what
|
|
we started on the previous line. */
|
|
|
|
static void
|
|
finish_separator (st_parameter_dt *dtp)
|
|
{
|
|
char c;
|
|
|
|
restart:
|
|
eat_spaces (dtp);
|
|
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
case ',':
|
|
if (dtp->u.p.comma_flag)
|
|
unget_char (dtp, c);
|
|
else
|
|
{
|
|
c = eat_spaces (dtp);
|
|
if (c == '\n' || c == '\r')
|
|
goto restart;
|
|
}
|
|
|
|
break;
|
|
|
|
case '/':
|
|
dtp->u.p.input_complete = 1;
|
|
if (!dtp->u.p.namelist_mode)
|
|
return;
|
|
break;
|
|
|
|
case '\n':
|
|
case '\r':
|
|
goto restart;
|
|
|
|
case '!':
|
|
if (dtp->u.p.namelist_mode)
|
|
{
|
|
do
|
|
c = next_char (dtp);
|
|
while (c != '\n');
|
|
|
|
goto restart;
|
|
}
|
|
|
|
default:
|
|
unget_char (dtp, c);
|
|
break;
|
|
}
|
|
}
|
|
|
|
|
|
/* This function is needed to catch bad conversions so that namelist can
|
|
attempt to see if dtp->u.p.saved_string contains a new object name rather
|
|
than a bad value. */
|
|
|
|
static int
|
|
nml_bad_return (st_parameter_dt *dtp, char c)
|
|
{
|
|
if (dtp->u.p.namelist_mode)
|
|
{
|
|
dtp->u.p.nml_read_error = 1;
|
|
unget_char (dtp, c);
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
/* Convert an unsigned string to an integer. The length value is -1
|
|
if we are working on a repeat count. Returns nonzero if we have a
|
|
range problem. As a side effect, frees the dtp->u.p.saved_string. */
|
|
|
|
static int
|
|
convert_integer (st_parameter_dt *dtp, int length, int negative)
|
|
{
|
|
char c, *buffer, message[100];
|
|
int m;
|
|
GFC_INTEGER_LARGEST v, max, max10;
|
|
|
|
buffer = dtp->u.p.saved_string;
|
|
v = 0;
|
|
|
|
max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
|
|
max10 = max / 10;
|
|
|
|
for (;;)
|
|
{
|
|
c = *buffer++;
|
|
if (c == '\0')
|
|
break;
|
|
c -= '0';
|
|
|
|
if (v > max10)
|
|
goto overflow;
|
|
v = 10 * v;
|
|
|
|
if (v > max - c)
|
|
goto overflow;
|
|
v += c;
|
|
}
|
|
|
|
m = 0;
|
|
|
|
if (length != -1)
|
|
{
|
|
if (negative)
|
|
v = -v;
|
|
set_integer (dtp->u.p.value, v, length);
|
|
}
|
|
else
|
|
{
|
|
dtp->u.p.repeat_count = v;
|
|
|
|
if (dtp->u.p.repeat_count == 0)
|
|
{
|
|
sprintf (message, "Zero repeat count in item %d of list input",
|
|
dtp->u.p.item_count);
|
|
|
|
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
|
|
m = 1;
|
|
}
|
|
}
|
|
|
|
free_saved (dtp);
|
|
return m;
|
|
|
|
overflow:
|
|
if (length == -1)
|
|
sprintf (message, "Repeat count overflow in item %d of list input",
|
|
dtp->u.p.item_count);
|
|
else
|
|
sprintf (message, "Integer overflow while reading item %d",
|
|
dtp->u.p.item_count);
|
|
|
|
free_saved (dtp);
|
|
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
|
|
|
|
return 1;
|
|
}
|
|
|
|
|
|
/* Parse a repeat count for logical and complex values which cannot
|
|
begin with a digit. Returns nonzero if we are done, zero if we
|
|
should continue on. */
|
|
|
|
static int
|
|
parse_repeat (st_parameter_dt *dtp)
|
|
{
|
|
char c, message[100];
|
|
int repeat;
|
|
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
CASE_DIGITS:
|
|
repeat = c - '0';
|
|
break;
|
|
|
|
CASE_SEPARATORS:
|
|
unget_char (dtp, c);
|
|
eat_separator (dtp);
|
|
return 1;
|
|
|
|
default:
|
|
unget_char (dtp, c);
|
|
return 0;
|
|
}
|
|
|
|
for (;;)
|
|
{
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
CASE_DIGITS:
|
|
repeat = 10 * repeat + c - '0';
|
|
|
|
if (repeat > MAX_REPEAT)
|
|
{
|
|
sprintf (message,
|
|
"Repeat count overflow in item %d of list input",
|
|
dtp->u.p.item_count);
|
|
|
|
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
|
|
return 1;
|
|
}
|
|
|
|
break;
|
|
|
|
case '*':
|
|
if (repeat == 0)
|
|
{
|
|
sprintf (message,
|
|
"Zero repeat count in item %d of list input",
|
|
dtp->u.p.item_count);
|
|
|
|
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
|
|
return 1;
|
|
}
|
|
|
|
goto done;
|
|
|
|
default:
|
|
goto bad_repeat;
|
|
}
|
|
}
|
|
|
|
done:
|
|
dtp->u.p.repeat_count = repeat;
|
|
return 0;
|
|
|
|
bad_repeat:
|
|
|
|
eat_line (dtp);
|
|
free_saved (dtp);
|
|
sprintf (message, "Bad repeat count in item %d of list input",
|
|
dtp->u.p.item_count);
|
|
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
|
|
return 1;
|
|
}
|
|
|
|
|
|
/* To read a logical we have to look ahead in the input stream to make sure
|
|
there is not an equal sign indicating a variable name. To do this we use
|
|
line_buffer to point to a temporary buffer, pushing characters there for
|
|
possible later reading. */
|
|
|
|
static void
|
|
l_push_char (st_parameter_dt *dtp, char c)
|
|
{
|
|
if (dtp->u.p.line_buffer == NULL)
|
|
{
|
|
dtp->u.p.line_buffer = get_mem (SCRATCH_SIZE);
|
|
memset (dtp->u.p.line_buffer, 0, SCRATCH_SIZE);
|
|
}
|
|
|
|
dtp->u.p.line_buffer[dtp->u.p.item_count++] = c;
|
|
}
|
|
|
|
|
|
/* Read a logical character on the input. */
|
|
|
|
static void
|
|
read_logical (st_parameter_dt *dtp, int length)
|
|
{
|
|
char c, message[100];
|
|
int i, v;
|
|
|
|
if (parse_repeat (dtp))
|
|
return;
|
|
|
|
c = tolower (next_char (dtp));
|
|
l_push_char (dtp, c);
|
|
switch (c)
|
|
{
|
|
case 't':
|
|
v = 1;
|
|
c = next_char (dtp);
|
|
l_push_char (dtp, c);
|
|
|
|
if (!is_separator(c))
|
|
goto possible_name;
|
|
|
|
unget_char (dtp, c);
|
|
break;
|
|
case 'f':
|
|
v = 0;
|
|
c = next_char (dtp);
|
|
l_push_char (dtp, c);
|
|
|
|
if (!is_separator(c))
|
|
goto possible_name;
|
|
|
|
unget_char (dtp, c);
|
|
break;
|
|
case '.':
|
|
c = tolower (next_char (dtp));
|
|
switch (c)
|
|
{
|
|
case 't':
|
|
v = 1;
|
|
break;
|
|
case 'f':
|
|
v = 0;
|
|
break;
|
|
default:
|
|
goto bad_logical;
|
|
}
|
|
|
|
break;
|
|
|
|
CASE_SEPARATORS:
|
|
unget_char (dtp, c);
|
|
eat_separator (dtp);
|
|
return; /* Null value. */
|
|
|
|
default:
|
|
goto bad_logical;
|
|
}
|
|
|
|
dtp->u.p.saved_type = BT_LOGICAL;
|
|
dtp->u.p.saved_length = length;
|
|
|
|
/* Eat trailing garbage. */
|
|
do
|
|
{
|
|
c = next_char (dtp);
|
|
}
|
|
while (!is_separator (c));
|
|
|
|
unget_char (dtp, c);
|
|
eat_separator (dtp);
|
|
dtp->u.p.item_count = 0;
|
|
dtp->u.p.line_buffer_enabled = 0;
|
|
set_integer ((int *) dtp->u.p.value, v, length);
|
|
free_line (dtp);
|
|
|
|
return;
|
|
|
|
possible_name:
|
|
|
|
for(i = 0; i < 63; i++)
|
|
{
|
|
c = next_char (dtp);
|
|
if (is_separator(c))
|
|
{
|
|
/* All done if this is not a namelist read. */
|
|
if (!dtp->u.p.namelist_mode)
|
|
goto logical_done;
|
|
|
|
unget_char (dtp, c);
|
|
eat_separator (dtp);
|
|
c = next_char (dtp);
|
|
if (c != '=')
|
|
{
|
|
unget_char (dtp, c);
|
|
goto logical_done;
|
|
}
|
|
}
|
|
|
|
l_push_char (dtp, c);
|
|
if (c == '=')
|
|
{
|
|
dtp->u.p.nml_read_error = 1;
|
|
dtp->u.p.line_buffer_enabled = 1;
|
|
dtp->u.p.item_count = 0;
|
|
return;
|
|
}
|
|
|
|
}
|
|
|
|
bad_logical:
|
|
|
|
free_line (dtp);
|
|
|
|
if (nml_bad_return (dtp, c))
|
|
return;
|
|
|
|
eat_line (dtp);
|
|
free_saved (dtp);
|
|
sprintf (message, "Bad logical value while reading item %d",
|
|
dtp->u.p.item_count);
|
|
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
|
|
return;
|
|
|
|
logical_done:
|
|
|
|
dtp->u.p.item_count = 0;
|
|
dtp->u.p.line_buffer_enabled = 0;
|
|
dtp->u.p.saved_type = BT_LOGICAL;
|
|
dtp->u.p.saved_length = length;
|
|
set_integer ((int *) dtp->u.p.value, v, length);
|
|
free_saved (dtp);
|
|
free_line (dtp);
|
|
}
|
|
|
|
|
|
/* Reading integers is tricky because we can actually be reading a
|
|
repeat count. We have to store the characters in a buffer because
|
|
we could be reading an integer that is larger than the default int
|
|
used for repeat counts. */
|
|
|
|
static void
|
|
read_integer (st_parameter_dt *dtp, int length)
|
|
{
|
|
char c, message[100];
|
|
int negative;
|
|
|
|
negative = 0;
|
|
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
case '-':
|
|
negative = 1;
|
|
/* Fall through... */
|
|
|
|
case '+':
|
|
c = next_char (dtp);
|
|
goto get_integer;
|
|
|
|
CASE_SEPARATORS: /* Single null. */
|
|
unget_char (dtp, c);
|
|
eat_separator (dtp);
|
|
return;
|
|
|
|
CASE_DIGITS:
|
|
push_char (dtp, c);
|
|
break;
|
|
|
|
default:
|
|
goto bad_integer;
|
|
}
|
|
|
|
/* Take care of what may be a repeat count. */
|
|
|
|
for (;;)
|
|
{
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
CASE_DIGITS:
|
|
push_char (dtp, c);
|
|
break;
|
|
|
|
case '*':
|
|
push_char (dtp, '\0');
|
|
goto repeat;
|
|
|
|
CASE_SEPARATORS: /* Not a repeat count. */
|
|
goto done;
|
|
|
|
default:
|
|
goto bad_integer;
|
|
}
|
|
}
|
|
|
|
repeat:
|
|
if (convert_integer (dtp, -1, 0))
|
|
return;
|
|
|
|
/* Get the real integer. */
|
|
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
CASE_DIGITS:
|
|
break;
|
|
|
|
CASE_SEPARATORS:
|
|
unget_char (dtp, c);
|
|
eat_separator (dtp);
|
|
return;
|
|
|
|
case '-':
|
|
negative = 1;
|
|
/* Fall through... */
|
|
|
|
case '+':
|
|
c = next_char (dtp);
|
|
break;
|
|
}
|
|
|
|
get_integer:
|
|
if (!isdigit (c))
|
|
goto bad_integer;
|
|
push_char (dtp, c);
|
|
|
|
for (;;)
|
|
{
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
CASE_DIGITS:
|
|
push_char (dtp, c);
|
|
break;
|
|
|
|
CASE_SEPARATORS:
|
|
goto done;
|
|
|
|
default:
|
|
goto bad_integer;
|
|
}
|
|
}
|
|
|
|
bad_integer:
|
|
|
|
if (nml_bad_return (dtp, c))
|
|
return;
|
|
|
|
eat_line (dtp);
|
|
free_saved (dtp);
|
|
sprintf (message, "Bad integer for item %d in list input",
|
|
dtp->u.p.item_count);
|
|
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
|
|
|
|
return;
|
|
|
|
done:
|
|
unget_char (dtp, c);
|
|
eat_separator (dtp);
|
|
|
|
push_char (dtp, '\0');
|
|
if (convert_integer (dtp, length, negative))
|
|
{
|
|
free_saved (dtp);
|
|
return;
|
|
}
|
|
|
|
free_saved (dtp);
|
|
dtp->u.p.saved_type = BT_INTEGER;
|
|
}
|
|
|
|
|
|
/* Read a character variable. */
|
|
|
|
static void
|
|
read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
|
|
{
|
|
char c, quote, message[100];
|
|
|
|
quote = ' '; /* Space means no quote character. */
|
|
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
CASE_DIGITS:
|
|
push_char (dtp, c);
|
|
break;
|
|
|
|
CASE_SEPARATORS:
|
|
unget_char (dtp, c); /* NULL value. */
|
|
eat_separator (dtp);
|
|
return;
|
|
|
|
case '"':
|
|
case '\'':
|
|
quote = c;
|
|
goto get_string;
|
|
|
|
default:
|
|
if (dtp->u.p.namelist_mode)
|
|
{
|
|
if (dtp->u.p.current_unit->flags.delim == DELIM_APOSTROPHE
|
|
|| dtp->u.p.current_unit->flags.delim == DELIM_QUOTE
|
|
|| c == '&' || c == '$' || c == '/')
|
|
{
|
|
unget_char (dtp, c);
|
|
return;
|
|
}
|
|
|
|
/* Check to see if we are seeing a namelist object name by using the
|
|
line buffer and looking ahead for an '=' or '('. */
|
|
l_push_char (dtp, c);
|
|
|
|
int i;
|
|
for(i = 0; i < 63; i++)
|
|
{
|
|
c = next_char (dtp);
|
|
if (is_separator(c))
|
|
{
|
|
unget_char (dtp, c);
|
|
eat_separator (dtp);
|
|
c = next_char (dtp);
|
|
if (c != '=')
|
|
{
|
|
l_push_char (dtp, c);
|
|
dtp->u.p.item_count = 0;
|
|
dtp->u.p.line_buffer_enabled = 1;
|
|
goto get_string;
|
|
}
|
|
}
|
|
|
|
l_push_char (dtp, c);
|
|
|
|
if (c == '=' || c == '(')
|
|
{
|
|
dtp->u.p.item_count = 0;
|
|
dtp->u.p.nml_read_error = 1;
|
|
dtp->u.p.line_buffer_enabled = 1;
|
|
return;
|
|
}
|
|
}
|
|
|
|
/* The string is too long to be a valid object name so assume that it
|
|
is a string to be read in as a value. */
|
|
dtp->u.p.item_count = 0;
|
|
dtp->u.p.line_buffer_enabled = 1;
|
|
goto get_string;
|
|
}
|
|
|
|
push_char (dtp, c);
|
|
goto get_string;
|
|
}
|
|
|
|
/* Deal with a possible repeat count. */
|
|
|
|
for (;;)
|
|
{
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
CASE_DIGITS:
|
|
push_char (dtp, c);
|
|
break;
|
|
|
|
CASE_SEPARATORS:
|
|
unget_char (dtp, c);
|
|
goto done; /* String was only digits! */
|
|
|
|
case '*':
|
|
push_char (dtp, '\0');
|
|
goto got_repeat;
|
|
|
|
default:
|
|
push_char (dtp, c);
|
|
goto get_string; /* Not a repeat count after all. */
|
|
}
|
|
}
|
|
|
|
got_repeat:
|
|
if (convert_integer (dtp, -1, 0))
|
|
return;
|
|
|
|
/* Now get the real string. */
|
|
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
CASE_SEPARATORS:
|
|
unget_char (dtp, c); /* Repeated NULL values. */
|
|
eat_separator (dtp);
|
|
return;
|
|
|
|
case '"':
|
|
case '\'':
|
|
quote = c;
|
|
break;
|
|
|
|
default:
|
|
push_char (dtp, c);
|
|
break;
|
|
}
|
|
|
|
get_string:
|
|
for (;;)
|
|
{
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
case '"':
|
|
case '\'':
|
|
if (c != quote)
|
|
{
|
|
push_char (dtp, c);
|
|
break;
|
|
}
|
|
|
|
/* See if we have a doubled quote character or the end of
|
|
the string. */
|
|
|
|
c = next_char (dtp);
|
|
if (c == quote)
|
|
{
|
|
push_char (dtp, quote);
|
|
break;
|
|
}
|
|
|
|
unget_char (dtp, c);
|
|
goto done;
|
|
|
|
CASE_SEPARATORS:
|
|
if (quote == ' ')
|
|
{
|
|
unget_char (dtp, c);
|
|
goto done;
|
|
}
|
|
|
|
if (c != '\n' && c != '\r')
|
|
push_char (dtp, c);
|
|
break;
|
|
|
|
default:
|
|
push_char (dtp, c);
|
|
break;
|
|
}
|
|
}
|
|
|
|
/* At this point, we have to have a separator, or else the string is
|
|
invalid. */
|
|
done:
|
|
c = next_char (dtp);
|
|
if (is_separator (c))
|
|
{
|
|
unget_char (dtp, c);
|
|
eat_separator (dtp);
|
|
dtp->u.p.saved_type = BT_CHARACTER;
|
|
free_line (dtp);
|
|
}
|
|
else
|
|
{
|
|
free_saved (dtp);
|
|
sprintf (message, "Invalid string input in item %d",
|
|
dtp->u.p.item_count);
|
|
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
|
|
}
|
|
}
|
|
|
|
|
|
/* Parse a component of a complex constant or a real number that we
|
|
are sure is already there. This is a straight real number parser. */
|
|
|
|
static int
|
|
parse_real (st_parameter_dt *dtp, void *buffer, int length)
|
|
{
|
|
char c, message[100];
|
|
int m, seen_dp;
|
|
|
|
c = next_char (dtp);
|
|
if (c == '-' || c == '+')
|
|
{
|
|
push_char (dtp, c);
|
|
c = next_char (dtp);
|
|
}
|
|
|
|
if (!isdigit (c) && c != '.')
|
|
{
|
|
if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
|
|
goto inf_nan;
|
|
else
|
|
goto bad;
|
|
}
|
|
|
|
push_char (dtp, c);
|
|
|
|
seen_dp = (c == '.') ? 1 : 0;
|
|
|
|
for (;;)
|
|
{
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
CASE_DIGITS:
|
|
push_char (dtp, c);
|
|
break;
|
|
|
|
case '.':
|
|
if (seen_dp)
|
|
goto bad;
|
|
|
|
seen_dp = 1;
|
|
push_char (dtp, c);
|
|
break;
|
|
|
|
case 'e':
|
|
case 'E':
|
|
case 'd':
|
|
case 'D':
|
|
push_char (dtp, 'e');
|
|
goto exp1;
|
|
|
|
case '-':
|
|
case '+':
|
|
push_char (dtp, 'e');
|
|
push_char (dtp, c);
|
|
c = next_char (dtp);
|
|
goto exp2;
|
|
|
|
CASE_SEPARATORS:
|
|
unget_char (dtp, c);
|
|
goto done;
|
|
|
|
default:
|
|
goto done;
|
|
}
|
|
}
|
|
|
|
exp1:
|
|
c = next_char (dtp);
|
|
if (c != '-' && c != '+')
|
|
push_char (dtp, '+');
|
|
else
|
|
{
|
|
push_char (dtp, c);
|
|
c = next_char (dtp);
|
|
}
|
|
|
|
exp2:
|
|
if (!isdigit (c))
|
|
goto bad;
|
|
|
|
push_char (dtp, c);
|
|
|
|
for (;;)
|
|
{
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
CASE_DIGITS:
|
|
push_char (dtp, c);
|
|
break;
|
|
|
|
CASE_SEPARATORS:
|
|
unget_char (dtp, c);
|
|
goto done;
|
|
|
|
default:
|
|
goto done;
|
|
}
|
|
}
|
|
|
|
done:
|
|
unget_char (dtp, c);
|
|
push_char (dtp, '\0');
|
|
|
|
m = convert_real (dtp, buffer, dtp->u.p.saved_string, length);
|
|
free_saved (dtp);
|
|
|
|
return m;
|
|
|
|
inf_nan:
|
|
/* Match INF and Infinity. */
|
|
if ((c == 'i' || c == 'I')
|
|
&& ((c = next_char (dtp)) == 'n' || c == 'N')
|
|
&& ((c = next_char (dtp)) == 'f' || c == 'F'))
|
|
{
|
|
c = next_char (dtp);
|
|
if ((c != 'i' && c != 'I')
|
|
|| ((c == 'i' || c == 'I')
|
|
&& ((c = next_char (dtp)) == 'n' || c == 'N')
|
|
&& ((c = next_char (dtp)) == 'i' || c == 'I')
|
|
&& ((c = next_char (dtp)) == 't' || c == 'T')
|
|
&& ((c = next_char (dtp)) == 'y' || c == 'Y')
|
|
&& (c = next_char (dtp))))
|
|
{
|
|
if (is_separator (c))
|
|
unget_char (dtp, c);
|
|
push_char (dtp, 'i');
|
|
push_char (dtp, 'n');
|
|
push_char (dtp, 'f');
|
|
goto done;
|
|
}
|
|
} /* Match NaN. */
|
|
else if (((c = next_char (dtp)) == 'a' || c == 'A')
|
|
&& ((c = next_char (dtp)) == 'n' || c == 'N')
|
|
&& (c = next_char (dtp)))
|
|
{
|
|
if (is_separator (c))
|
|
unget_char (dtp, c);
|
|
push_char (dtp, 'n');
|
|
push_char (dtp, 'a');
|
|
push_char (dtp, 'n');
|
|
goto done;
|
|
}
|
|
|
|
bad:
|
|
|
|
if (nml_bad_return (dtp, c))
|
|
return 0;
|
|
|
|
eat_line (dtp);
|
|
free_saved (dtp);
|
|
sprintf (message, "Bad floating point number for item %d",
|
|
dtp->u.p.item_count);
|
|
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
|
|
|
|
return 1;
|
|
}
|
|
|
|
|
|
/* Reading a complex number is straightforward because we can tell
|
|
what it is right away. */
|
|
|
|
static void
|
|
read_complex (st_parameter_dt *dtp, int kind, size_t size)
|
|
{
|
|
char message[100];
|
|
char c;
|
|
|
|
if (parse_repeat (dtp))
|
|
return;
|
|
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
case '(':
|
|
break;
|
|
|
|
CASE_SEPARATORS:
|
|
unget_char (dtp, c);
|
|
eat_separator (dtp);
|
|
return;
|
|
|
|
default:
|
|
goto bad_complex;
|
|
}
|
|
|
|
eat_spaces (dtp);
|
|
if (parse_real (dtp, dtp->u.p.value, kind))
|
|
return;
|
|
|
|
eol_1:
|
|
eat_spaces (dtp);
|
|
c = next_char (dtp);
|
|
if (c == '\n' || c== '\r')
|
|
goto eol_1;
|
|
else
|
|
unget_char (dtp, c);
|
|
|
|
if (next_char (dtp) != ',')
|
|
goto bad_complex;
|
|
|
|
eol_2:
|
|
eat_spaces (dtp);
|
|
c = next_char (dtp);
|
|
if (c == '\n' || c== '\r')
|
|
goto eol_2;
|
|
else
|
|
unget_char (dtp, c);
|
|
|
|
if (parse_real (dtp, dtp->u.p.value + size / 2, kind))
|
|
return;
|
|
|
|
eat_spaces (dtp);
|
|
if (next_char (dtp) != ')')
|
|
goto bad_complex;
|
|
|
|
c = next_char (dtp);
|
|
if (!is_separator (c))
|
|
goto bad_complex;
|
|
|
|
unget_char (dtp, c);
|
|
eat_separator (dtp);
|
|
|
|
free_saved (dtp);
|
|
dtp->u.p.saved_type = BT_COMPLEX;
|
|
return;
|
|
|
|
bad_complex:
|
|
|
|
if (nml_bad_return (dtp, c))
|
|
return;
|
|
|
|
eat_line (dtp);
|
|
free_saved (dtp);
|
|
sprintf (message, "Bad complex value in item %d of list input",
|
|
dtp->u.p.item_count);
|
|
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
|
|
}
|
|
|
|
|
|
/* Parse a real number with a possible repeat count. */
|
|
|
|
static void
|
|
read_real (st_parameter_dt *dtp, int length)
|
|
{
|
|
char c, message[100];
|
|
int seen_dp;
|
|
int is_inf;
|
|
|
|
seen_dp = 0;
|
|
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
CASE_DIGITS:
|
|
push_char (dtp, c);
|
|
break;
|
|
|
|
case '.':
|
|
push_char (dtp, c);
|
|
seen_dp = 1;
|
|
break;
|
|
|
|
case '+':
|
|
case '-':
|
|
goto got_sign;
|
|
|
|
CASE_SEPARATORS:
|
|
unget_char (dtp, c); /* Single null. */
|
|
eat_separator (dtp);
|
|
return;
|
|
|
|
case 'i':
|
|
case 'I':
|
|
case 'n':
|
|
case 'N':
|
|
goto inf_nan;
|
|
|
|
default:
|
|
goto bad_real;
|
|
}
|
|
|
|
/* Get the digit string that might be a repeat count. */
|
|
|
|
for (;;)
|
|
{
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
CASE_DIGITS:
|
|
push_char (dtp, c);
|
|
break;
|
|
|
|
case '.':
|
|
if (seen_dp)
|
|
goto bad_real;
|
|
|
|
seen_dp = 1;
|
|
push_char (dtp, c);
|
|
goto real_loop;
|
|
|
|
case 'E':
|
|
case 'e':
|
|
case 'D':
|
|
case 'd':
|
|
goto exp1;
|
|
|
|
case '+':
|
|
case '-':
|
|
push_char (dtp, 'e');
|
|
push_char (dtp, c);
|
|
c = next_char (dtp);
|
|
goto exp2;
|
|
|
|
case '*':
|
|
push_char (dtp, '\0');
|
|
goto got_repeat;
|
|
|
|
CASE_SEPARATORS:
|
|
if (c != '\n' && c != ',' && c != '\r')
|
|
unget_char (dtp, c);
|
|
goto done;
|
|
|
|
default:
|
|
goto bad_real;
|
|
}
|
|
}
|
|
|
|
got_repeat:
|
|
if (convert_integer (dtp, -1, 0))
|
|
return;
|
|
|
|
/* Now get the number itself. */
|
|
|
|
c = next_char (dtp);
|
|
if (is_separator (c))
|
|
{ /* Repeated null value. */
|
|
unget_char (dtp, c);
|
|
eat_separator (dtp);
|
|
return;
|
|
}
|
|
|
|
if (c != '-' && c != '+')
|
|
push_char (dtp, '+');
|
|
else
|
|
{
|
|
got_sign:
|
|
push_char (dtp, c);
|
|
c = next_char (dtp);
|
|
}
|
|
|
|
if (!isdigit (c) && c != '.')
|
|
{
|
|
if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
|
|
goto inf_nan;
|
|
else
|
|
goto bad_real;
|
|
}
|
|
|
|
if (c == '.')
|
|
{
|
|
if (seen_dp)
|
|
goto bad_real;
|
|
else
|
|
seen_dp = 1;
|
|
}
|
|
|
|
push_char (dtp, c);
|
|
|
|
real_loop:
|
|
for (;;)
|
|
{
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
CASE_DIGITS:
|
|
push_char (dtp, c);
|
|
break;
|
|
|
|
CASE_SEPARATORS:
|
|
goto done;
|
|
|
|
case '.':
|
|
if (seen_dp)
|
|
goto bad_real;
|
|
|
|
seen_dp = 1;
|
|
push_char (dtp, c);
|
|
break;
|
|
|
|
case 'E':
|
|
case 'e':
|
|
case 'D':
|
|
case 'd':
|
|
goto exp1;
|
|
|
|
case '+':
|
|
case '-':
|
|
push_char (dtp, 'e');
|
|
push_char (dtp, c);
|
|
c = next_char (dtp);
|
|
goto exp2;
|
|
|
|
default:
|
|
goto bad_real;
|
|
}
|
|
}
|
|
|
|
exp1:
|
|
push_char (dtp, 'e');
|
|
|
|
c = next_char (dtp);
|
|
if (c != '+' && c != '-')
|
|
push_char (dtp, '+');
|
|
else
|
|
{
|
|
push_char (dtp, c);
|
|
c = next_char (dtp);
|
|
}
|
|
|
|
exp2:
|
|
if (!isdigit (c))
|
|
goto bad_real;
|
|
push_char (dtp, c);
|
|
|
|
for (;;)
|
|
{
|
|
c = next_char (dtp);
|
|
|
|
switch (c)
|
|
{
|
|
CASE_DIGITS:
|
|
push_char (dtp, c);
|
|
break;
|
|
|
|
CASE_SEPARATORS:
|
|
goto done;
|
|
|
|
default:
|
|
goto bad_real;
|
|
}
|
|
}
|
|
|
|
done:
|
|
unget_char (dtp, c);
|
|
eat_separator (dtp);
|
|
push_char (dtp, '\0');
|
|
if (convert_real (dtp, dtp->u.p.value, dtp->u.p.saved_string, length))
|
|
return;
|
|
|
|
free_saved (dtp);
|
|
dtp->u.p.saved_type = BT_REAL;
|
|
return;
|
|
|
|
inf_nan:
|
|
l_push_char (dtp, c);
|
|
is_inf = 0;
|
|
|
|
/* Match INF and Infinity. */
|
|
if (c == 'i' || c == 'I')
|
|
{
|
|
c = next_char (dtp);
|
|
l_push_char (dtp, c);
|
|
if (c != 'n' && c != 'N')
|
|
goto unwind;
|
|
c = next_char (dtp);
|
|
l_push_char (dtp, c);
|
|
if (c != 'f' && c != 'F')
|
|
goto unwind;
|
|
c = next_char (dtp);
|
|
l_push_char (dtp, c);
|
|
if (!is_separator (c))
|
|
{
|
|
if (c != 'i' && c != 'I')
|
|
goto unwind;
|
|
c = next_char (dtp);
|
|
l_push_char (dtp, c);
|
|
if (c != 'n' && c != 'N')
|
|
goto unwind;
|
|
c = next_char (dtp);
|
|
l_push_char (dtp, c);
|
|
if (c != 'i' && c != 'I')
|
|
goto unwind;
|
|
c = next_char (dtp);
|
|
l_push_char (dtp, c);
|
|
if (c != 't' && c != 'T')
|
|
goto unwind;
|
|
c = next_char (dtp);
|
|
l_push_char (dtp, c);
|
|
if (c != 'y' && c != 'Y')
|
|
goto unwind;
|
|
c = next_char (dtp);
|
|
l_push_char (dtp, c);
|
|
}
|
|
is_inf = 1;
|
|
} /* Match NaN. */
|
|
else
|
|
{
|
|
c = next_char (dtp);
|
|
l_push_char (dtp, c);
|
|
if (c != 'a' && c != 'A')
|
|
goto unwind;
|
|
c = next_char (dtp);
|
|
l_push_char (dtp, c);
|
|
if (c != 'n' && c != 'N')
|
|
goto unwind;
|
|
c = next_char (dtp);
|
|
l_push_char (dtp, c);
|
|
}
|
|
|
|
if (!is_separator (c))
|
|
goto unwind;
|
|
|
|
if (dtp->u.p.namelist_mode)
|
|
{
|
|
if (c == ' ' || c =='\n' || c == '\r')
|
|
{
|
|
do
|
|
c = next_char (dtp);
|
|
while (c == ' ' || c =='\n' || c == '\r');
|
|
|
|
l_push_char (dtp, c);
|
|
|
|
if (c == '=')
|
|
goto unwind;
|
|
}
|
|
}
|
|
|
|
if (is_inf)
|
|
{
|
|
push_char (dtp, 'i');
|
|
push_char (dtp, 'n');
|
|
push_char (dtp, 'f');
|
|
}
|
|
else
|
|
{
|
|
push_char (dtp, 'n');
|
|
push_char (dtp, 'a');
|
|
push_char (dtp, 'n');
|
|
}
|
|
|
|
dtp->u.p.item_count = 0;
|
|
dtp->u.p.line_buffer_enabled = 0;
|
|
free_line (dtp);
|
|
goto done;
|
|
|
|
unwind:
|
|
if (dtp->u.p.namelist_mode)
|
|
{
|
|
dtp->u.p.nml_read_error = 1;
|
|
dtp->u.p.line_buffer_enabled = 1;
|
|
dtp->u.p.item_count = 0;
|
|
return;
|
|
}
|
|
|
|
bad_real:
|
|
|
|
if (nml_bad_return (dtp, c))
|
|
return;
|
|
|
|
eat_line (dtp);
|
|
free_saved (dtp);
|
|
sprintf (message, "Bad real number in item %d of list input",
|
|
dtp->u.p.item_count);
|
|
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
|
|
}
|
|
|
|
|
|
/* Check the current type against the saved type to make sure they are
|
|
compatible. Returns nonzero if incompatible. */
|
|
|
|
static int
|
|
check_type (st_parameter_dt *dtp, bt type, int len)
|
|
{
|
|
char message[100];
|
|
|
|
if (dtp->u.p.saved_type != BT_NULL && dtp->u.p.saved_type != type)
|
|
{
|
|
sprintf (message, "Read type %s where %s was expected for item %d",
|
|
type_name (dtp->u.p.saved_type), type_name (type),
|
|
dtp->u.p.item_count);
|
|
|
|
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
|
|
return 1;
|
|
}
|
|
|
|
if (dtp->u.p.saved_type == BT_NULL || dtp->u.p.saved_type == BT_CHARACTER)
|
|
return 0;
|
|
|
|
if (dtp->u.p.saved_length != len)
|
|
{
|
|
sprintf (message,
|
|
"Read kind %d %s where kind %d is required for item %d",
|
|
dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
|
|
dtp->u.p.item_count);
|
|
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
|
|
return 1;
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
|
|
/* Top level data transfer subroutine for list reads. Because we have
|
|
to deal with repeat counts, the data item is always saved after
|
|
reading, usually in the dtp->u.p.value[] array. If a repeat count is
|
|
greater than one, we copy the data item multiple times. */
|
|
|
|
static void
|
|
list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
|
|
size_t size)
|
|
{
|
|
char c;
|
|
int m;
|
|
jmp_buf eof_jump;
|
|
|
|
dtp->u.p.namelist_mode = 0;
|
|
|
|
dtp->u.p.eof_jump = &eof_jump;
|
|
if (setjmp (eof_jump))
|
|
{
|
|
generate_error (&dtp->common, LIBERROR_END, NULL);
|
|
goto cleanup;
|
|
}
|
|
|
|
if (dtp->u.p.first_item)
|
|
{
|
|
dtp->u.p.first_item = 0;
|
|
dtp->u.p.input_complete = 0;
|
|
dtp->u.p.repeat_count = 1;
|
|
dtp->u.p.at_eol = 0;
|
|
|
|
c = eat_spaces (dtp);
|
|
if (is_separator (c))
|
|
{
|
|
/* Found a null value. */
|
|
eat_separator (dtp);
|
|
dtp->u.p.repeat_count = 0;
|
|
|
|
/* eat_separator sets this flag if the separator was a comma. */
|
|
if (dtp->u.p.comma_flag)
|
|
goto cleanup;
|
|
|
|
/* eat_separator sets this flag if the separator was a \n or \r. */
|
|
if (dtp->u.p.at_eol)
|
|
finish_separator (dtp);
|
|
else
|
|
goto cleanup;
|
|
}
|
|
|
|
}
|
|
else
|
|
{
|
|
if (dtp->u.p.input_complete)
|
|
goto cleanup;
|
|
|
|
if (dtp->u.p.repeat_count > 0)
|
|
{
|
|
if (check_type (dtp, type, kind))
|
|
return;
|
|
goto set_value;
|
|
}
|
|
|
|
if (dtp->u.p.at_eol)
|
|
finish_separator (dtp);
|
|
else
|
|
{
|
|
eat_spaces (dtp);
|
|
/* Trailing spaces prior to end of line. */
|
|
if (dtp->u.p.at_eol)
|
|
finish_separator (dtp);
|
|
}
|
|
|
|
dtp->u.p.saved_type = BT_NULL;
|
|
dtp->u.p.repeat_count = 1;
|
|
}
|
|
|
|
switch (type)
|
|
{
|
|
case BT_INTEGER:
|
|
read_integer (dtp, kind);
|
|
break;
|
|
case BT_LOGICAL:
|
|
read_logical (dtp, kind);
|
|
break;
|
|
case BT_CHARACTER:
|
|
read_character (dtp, kind);
|
|
break;
|
|
case BT_REAL:
|
|
read_real (dtp, kind);
|
|
break;
|
|
case BT_COMPLEX:
|
|
read_complex (dtp, kind, size);
|
|
break;
|
|
default:
|
|
internal_error (&dtp->common, "Bad type for list read");
|
|
}
|
|
|
|
if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_NULL)
|
|
dtp->u.p.saved_length = size;
|
|
|
|
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
|
|
goto cleanup;
|
|
|
|
set_value:
|
|
switch (dtp->u.p.saved_type)
|
|
{
|
|
case BT_COMPLEX:
|
|
case BT_INTEGER:
|
|
case BT_REAL:
|
|
case BT_LOGICAL:
|
|
memcpy (p, dtp->u.p.value, size);
|
|
break;
|
|
|
|
case BT_CHARACTER:
|
|
if (dtp->u.p.saved_string)
|
|
{
|
|
m = ((int) size < dtp->u.p.saved_used)
|
|
? (int) size : dtp->u.p.saved_used;
|
|
memcpy (p, dtp->u.p.saved_string, m);
|
|
}
|
|
else
|
|
/* Just delimiters encountered, nothing to copy but SPACE. */
|
|
m = 0;
|
|
|
|
if (m < (int) size)
|
|
memset (((char *) p) + m, ' ', size - m);
|
|
break;
|
|
|
|
case BT_NULL:
|
|
break;
|
|
}
|
|
|
|
if (--dtp->u.p.repeat_count <= 0)
|
|
free_saved (dtp);
|
|
|
|
cleanup:
|
|
dtp->u.p.eof_jump = NULL;
|
|
}
|
|
|
|
|
|
void
|
|
list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
|
|
size_t size, size_t nelems)
|
|
{
|
|
size_t elem;
|
|
char *tmp;
|
|
|
|
tmp = (char *) p;
|
|
|
|
/* Big loop over all the elements. */
|
|
for (elem = 0; elem < nelems; elem++)
|
|
{
|
|
dtp->u.p.item_count++;
|
|
list_formatted_read_scalar (dtp, type, tmp + size*elem, kind, size);
|
|
}
|
|
}
|
|
|
|
|
|
/* Finish a list read. */
|
|
|
|
void
|
|
finish_list_read (st_parameter_dt *dtp)
|
|
{
|
|
char c;
|
|
|
|
free_saved (dtp);
|
|
|
|
if (dtp->u.p.at_eol)
|
|
{
|
|
dtp->u.p.at_eol = 0;
|
|
return;
|
|
}
|
|
|
|
do
|
|
{
|
|
c = next_char (dtp);
|
|
}
|
|
while (c != '\n');
|
|
}
|
|
|
|
/* NAMELIST INPUT
|
|
|
|
void namelist_read (st_parameter_dt *dtp)
|
|
calls:
|
|
static void nml_match_name (char *name, int len)
|
|
static int nml_query (st_parameter_dt *dtp)
|
|
static int nml_get_obj_data (st_parameter_dt *dtp,
|
|
namelist_info **prev_nl, char *)
|
|
calls:
|
|
static void nml_untouch_nodes (st_parameter_dt *dtp)
|
|
static namelist_info * find_nml_node (st_parameter_dt *dtp,
|
|
char * var_name)
|
|
static int nml_parse_qualifier(descriptor_dimension * ad,
|
|
array_loop_spec * ls, int rank, char *)
|
|
static void nml_touch_nodes (namelist_info * nl)
|
|
static int nml_read_obj (namelist_info *nl, index_type offset,
|
|
namelist_info **prev_nl, char *,
|
|
index_type clow, index_type chigh)
|
|
calls:
|
|
-itself- */
|
|
|
|
/* Inputs a rank-dimensional qualifier, which can contain
|
|
singlets, doublets, triplets or ':' with the standard meanings. */
|
|
|
|
static try
|
|
nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
|
|
array_loop_spec *ls, int rank, char *parse_err_msg,
|
|
int *parsed_rank)
|
|
{
|
|
int dim;
|
|
int indx;
|
|
int neg;
|
|
int null_flag;
|
|
int is_array_section, is_char;
|
|
char c;
|
|
|
|
is_char = 0;
|
|
is_array_section = 0;
|
|
dtp->u.p.expanded_read = 0;
|
|
|
|
/* See if this is a character substring qualifier we are looking for. */
|
|
if (rank == -1)
|
|
{
|
|
rank = 1;
|
|
is_char = 1;
|
|
}
|
|
|
|
/* The next character in the stream should be the '('. */
|
|
|
|
c = next_char (dtp);
|
|
|
|
/* Process the qualifier, by dimension and triplet. */
|
|
|
|
for (dim=0; dim < rank; dim++ )
|
|
{
|
|
for (indx=0; indx<3; indx++)
|
|
{
|
|
free_saved (dtp);
|
|
eat_spaces (dtp);
|
|
neg = 0;
|
|
|
|
/* Process a potential sign. */
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
case '-':
|
|
neg = 1;
|
|
break;
|
|
|
|
case '+':
|
|
break;
|
|
|
|
default:
|
|
unget_char (dtp, c);
|
|
break;
|
|
}
|
|
|
|
/* Process characters up to the next ':' , ',' or ')'. */
|
|
for (;;)
|
|
{
|
|
c = next_char (dtp);
|
|
|
|
switch (c)
|
|
{
|
|
case ':':
|
|
is_array_section = 1;
|
|
break;
|
|
|
|
case ',': case ')':
|
|
if ((c==',' && dim == rank -1)
|
|
|| (c==')' && dim < rank -1))
|
|
{
|
|
if (is_char)
|
|
sprintf (parse_err_msg, "Bad substring qualifier");
|
|
else
|
|
sprintf (parse_err_msg, "Bad number of index fields");
|
|
goto err_ret;
|
|
}
|
|
break;
|
|
|
|
CASE_DIGITS:
|
|
push_char (dtp, c);
|
|
continue;
|
|
|
|
case ' ': case '\t':
|
|
eat_spaces (dtp);
|
|
c = next_char (dtp);
|
|
break;
|
|
|
|
default:
|
|
if (is_char)
|
|
sprintf (parse_err_msg,
|
|
"Bad character in substring qualifier");
|
|
else
|
|
sprintf (parse_err_msg, "Bad character in index");
|
|
goto err_ret;
|
|
}
|
|
|
|
if ((c == ',' || c == ')') && indx == 0
|
|
&& dtp->u.p.saved_string == 0)
|
|
{
|
|
if (is_char)
|
|
sprintf (parse_err_msg, "Null substring qualifier");
|
|
else
|
|
sprintf (parse_err_msg, "Null index field");
|
|
goto err_ret;
|
|
}
|
|
|
|
if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
|
|
|| (indx == 2 && dtp->u.p.saved_string == 0))
|
|
{
|
|
if (is_char)
|
|
sprintf (parse_err_msg, "Bad substring qualifier");
|
|
else
|
|
sprintf (parse_err_msg, "Bad index triplet");
|
|
goto err_ret;
|
|
}
|
|
|
|
if (is_char && !is_array_section)
|
|
{
|
|
sprintf (parse_err_msg,
|
|
"Missing colon in substring qualifier");
|
|
goto err_ret;
|
|
}
|
|
|
|
/* If '( : ? )' or '( ? : )' break and flag read failure. */
|
|
null_flag = 0;
|
|
if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
|
|
|| (indx==1 && dtp->u.p.saved_string == 0))
|
|
{
|
|
null_flag = 1;
|
|
break;
|
|
}
|
|
|
|
/* Now read the index. */
|
|
if (convert_integer (dtp, sizeof(ssize_t), neg))
|
|
{
|
|
if (is_char)
|
|
sprintf (parse_err_msg, "Bad integer substring qualifier");
|
|
else
|
|
sprintf (parse_err_msg, "Bad integer in index");
|
|
goto err_ret;
|
|
}
|
|
break;
|
|
}
|
|
|
|
/* Feed the index values to the triplet arrays. */
|
|
if (!null_flag)
|
|
{
|
|
if (indx == 0)
|
|
memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
|
|
if (indx == 1)
|
|
memcpy (&ls[dim].end, dtp->u.p.value, sizeof(ssize_t));
|
|
if (indx == 2)
|
|
memcpy (&ls[dim].step, dtp->u.p.value, sizeof(ssize_t));
|
|
}
|
|
|
|
/* Singlet or doublet indices. */
|
|
if (c==',' || c==')')
|
|
{
|
|
if (indx == 0)
|
|
{
|
|
memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
|
|
|
|
/* If -std=f95/2003 or an array section is specified,
|
|
do not allow excess data to be processed. */
|
|
if (is_array_section == 1
|
|
|| compile_options.allow_std < GFC_STD_GNU)
|
|
ls[dim].end = ls[dim].start;
|
|
else
|
|
dtp->u.p.expanded_read = 1;
|
|
}
|
|
|
|
/* Check for non-zero rank. */
|
|
if (is_array_section == 1 && ls[dim].start != ls[dim].end)
|
|
*parsed_rank = 1;
|
|
|
|
break;
|
|
}
|
|
}
|
|
|
|
/* Check the values of the triplet indices. */
|
|
if ((ls[dim].start > (ssize_t)ad[dim].ubound)
|
|
|| (ls[dim].start < (ssize_t)ad[dim].lbound)
|
|
|| (ls[dim].end > (ssize_t)ad[dim].ubound)
|
|
|| (ls[dim].end < (ssize_t)ad[dim].lbound))
|
|
{
|
|
if (is_char)
|
|
sprintf (parse_err_msg, "Substring out of range");
|
|
else
|
|
sprintf (parse_err_msg, "Index %d out of range", dim + 1);
|
|
goto err_ret;
|
|
}
|
|
|
|
if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
|
|
|| (ls[dim].step == 0))
|
|
{
|
|
sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
|
|
goto err_ret;
|
|
}
|
|
|
|
/* Initialise the loop index counter. */
|
|
ls[dim].idx = ls[dim].start;
|
|
}
|
|
eat_spaces (dtp);
|
|
return SUCCESS;
|
|
|
|
err_ret:
|
|
|
|
return FAILURE;
|
|
}
|
|
|
|
static namelist_info *
|
|
find_nml_node (st_parameter_dt *dtp, char * var_name)
|
|
{
|
|
namelist_info * t = dtp->u.p.ionml;
|
|
while (t != NULL)
|
|
{
|
|
if (strcmp (var_name, t->var_name) == 0)
|
|
{
|
|
t->touched = 1;
|
|
return t;
|
|
}
|
|
t = t->next;
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
/* Visits all the components of a derived type that have
|
|
not explicitly been identified in the namelist input.
|
|
touched is set and the loop specification initialised
|
|
to default values */
|
|
|
|
static void
|
|
nml_touch_nodes (namelist_info * nl)
|
|
{
|
|
index_type len = strlen (nl->var_name) + 1;
|
|
int dim;
|
|
char * ext_name = (char*)get_mem (len + 1);
|
|
memcpy (ext_name, nl->var_name, len-1);
|
|
memcpy (ext_name + len - 1, "%", 2);
|
|
for (nl = nl->next; nl; nl = nl->next)
|
|
{
|
|
if (strncmp (nl->var_name, ext_name, len) == 0)
|
|
{
|
|
nl->touched = 1;
|
|
for (dim=0; dim < nl->var_rank; dim++)
|
|
{
|
|
nl->ls[dim].step = 1;
|
|
nl->ls[dim].end = nl->dim[dim].ubound;
|
|
nl->ls[dim].start = nl->dim[dim].lbound;
|
|
nl->ls[dim].idx = nl->ls[dim].start;
|
|
}
|
|
}
|
|
else
|
|
break;
|
|
}
|
|
free_mem (ext_name);
|
|
return;
|
|
}
|
|
|
|
/* Resets touched for the entire list of nml_nodes, ready for a
|
|
new object. */
|
|
|
|
static void
|
|
nml_untouch_nodes (st_parameter_dt *dtp)
|
|
{
|
|
namelist_info * t;
|
|
for (t = dtp->u.p.ionml; t; t = t->next)
|
|
t->touched = 0;
|
|
return;
|
|
}
|
|
|
|
/* Attempts to input name to namelist name. Returns
|
|
dtp->u.p.nml_read_error = 1 on no match. */
|
|
|
|
static void
|
|
nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
|
|
{
|
|
index_type i;
|
|
char c;
|
|
dtp->u.p.nml_read_error = 0;
|
|
for (i = 0; i < len; i++)
|
|
{
|
|
c = next_char (dtp);
|
|
if (tolower (c) != tolower (name[i]))
|
|
{
|
|
dtp->u.p.nml_read_error = 1;
|
|
break;
|
|
}
|
|
}
|
|
}
|
|
|
|
/* If the namelist read is from stdin, output the current state of the
|
|
namelist to stdout. This is used to implement the non-standard query
|
|
features, ? and =?. If c == '=' the full namelist is printed. Otherwise
|
|
the names alone are printed. */
|
|
|
|
static void
|
|
nml_query (st_parameter_dt *dtp, char c)
|
|
{
|
|
gfc_unit * temp_unit;
|
|
namelist_info * nl;
|
|
index_type len;
|
|
char * p;
|
|
|
|
if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
|
|
return;
|
|
|
|
/* Store the current unit and transfer to stdout. */
|
|
|
|
temp_unit = dtp->u.p.current_unit;
|
|
dtp->u.p.current_unit = find_unit (options.stdout_unit);
|
|
|
|
if (dtp->u.p.current_unit)
|
|
{
|
|
dtp->u.p.mode = WRITING;
|
|
next_record (dtp, 0);
|
|
|
|
/* Write the namelist in its entirety. */
|
|
|
|
if (c == '=')
|
|
namelist_write (dtp);
|
|
|
|
/* Or write the list of names. */
|
|
|
|
else
|
|
{
|
|
/* "&namelist_name\n" */
|
|
|
|
len = dtp->namelist_name_len;
|
|
#ifdef HAVE_CRLF
|
|
p = write_block (dtp, len + 3);
|
|
#else
|
|
p = write_block (dtp, len + 2);
|
|
#endif
|
|
if (!p)
|
|
goto query_return;
|
|
memcpy (p, "&", 1);
|
|
memcpy ((char*)(p + 1), dtp->namelist_name, len);
|
|
#ifdef HAVE_CRLF
|
|
memcpy ((char*)(p + len + 1), "\r\n", 2);
|
|
#else
|
|
memcpy ((char*)(p + len + 1), "\n", 1);
|
|
#endif
|
|
for (nl = dtp->u.p.ionml; nl; nl = nl->next)
|
|
{
|
|
/* " var_name\n" */
|
|
|
|
len = strlen (nl->var_name);
|
|
#ifdef HAVE_CRLF
|
|
p = write_block (dtp, len + 3);
|
|
#else
|
|
p = write_block (dtp, len + 2);
|
|
#endif
|
|
if (!p)
|
|
goto query_return;
|
|
memcpy (p, " ", 1);
|
|
memcpy ((char*)(p + 1), nl->var_name, len);
|
|
#ifdef HAVE_CRLF
|
|
memcpy ((char*)(p + len + 1), "\r\n", 2);
|
|
#else
|
|
memcpy ((char*)(p + len + 1), "\n", 1);
|
|
#endif
|
|
}
|
|
|
|
/* "&end\n" */
|
|
|
|
#ifdef HAVE_CRLF
|
|
p = write_block (dtp, 6);
|
|
#else
|
|
p = write_block (dtp, 5);
|
|
#endif
|
|
if (!p)
|
|
goto query_return;
|
|
#ifdef HAVE_CRLF
|
|
memcpy (p, "&end\r\n", 6);
|
|
#else
|
|
memcpy (p, "&end\n", 5);
|
|
#endif
|
|
}
|
|
|
|
/* Flush the stream to force immediate output. */
|
|
|
|
flush (dtp->u.p.current_unit->s);
|
|
unlock_unit (dtp->u.p.current_unit);
|
|
}
|
|
|
|
query_return:
|
|
|
|
/* Restore the current unit. */
|
|
|
|
dtp->u.p.current_unit = temp_unit;
|
|
dtp->u.p.mode = READING;
|
|
return;
|
|
}
|
|
|
|
/* Reads and stores the input for the namelist object nl. For an array,
|
|
the function loops over the ranges defined by the loop specification.
|
|
This default to all the data or to the specification from a qualifier.
|
|
nml_read_obj recursively calls itself to read derived types. It visits
|
|
all its own components but only reads data for those that were touched
|
|
when the name was parsed. If a read error is encountered, an attempt is
|
|
made to return to read a new object name because the standard allows too
|
|
little data to be available. On the other hand, too much data is an
|
|
error. */
|
|
|
|
static try
|
|
nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
|
|
namelist_info **pprev_nl, char *nml_err_msg,
|
|
index_type clow, index_type chigh)
|
|
{
|
|
namelist_info * cmp;
|
|
char * obj_name;
|
|
int nml_carry;
|
|
int len;
|
|
int dim;
|
|
index_type dlen;
|
|
index_type m;
|
|
index_type obj_name_len;
|
|
void * pdata;
|
|
|
|
/* This object not touched in name parsing. */
|
|
|
|
if (!nl->touched)
|
|
return SUCCESS;
|
|
|
|
dtp->u.p.repeat_count = 0;
|
|
eat_spaces (dtp);
|
|
|
|
len = nl->len;
|
|
switch (nl->type)
|
|
{
|
|
case GFC_DTYPE_INTEGER:
|
|
case GFC_DTYPE_LOGICAL:
|
|
dlen = len;
|
|
break;
|
|
|
|
case GFC_DTYPE_REAL:
|
|
dlen = size_from_real_kind (len);
|
|
break;
|
|
|
|
case GFC_DTYPE_COMPLEX:
|
|
dlen = size_from_complex_kind (len);
|
|
break;
|
|
|
|
case GFC_DTYPE_CHARACTER:
|
|
dlen = chigh ? (chigh - clow + 1) : nl->string_length;
|
|
break;
|
|
|
|
default:
|
|
dlen = 0;
|
|
}
|
|
|
|
do
|
|
{
|
|
/* Update the pointer to the data, using the current index vector */
|
|
|
|
pdata = (void*)(nl->mem_pos + offset);
|
|
for (dim = 0; dim < nl->var_rank; dim++)
|
|
pdata = (void*)(pdata + (nl->ls[dim].idx - nl->dim[dim].lbound) *
|
|
nl->dim[dim].stride * nl->size);
|
|
|
|
/* Reset the error flag and try to read next value, if
|
|
dtp->u.p.repeat_count=0 */
|
|
|
|
dtp->u.p.nml_read_error = 0;
|
|
nml_carry = 0;
|
|
if (--dtp->u.p.repeat_count <= 0)
|
|
{
|
|
if (dtp->u.p.input_complete)
|
|
return SUCCESS;
|
|
if (dtp->u.p.at_eol)
|
|
finish_separator (dtp);
|
|
if (dtp->u.p.input_complete)
|
|
return SUCCESS;
|
|
|
|
/* GFC_TYPE_UNKNOWN through for nulls and is detected
|
|
after the switch block. */
|
|
|
|
dtp->u.p.saved_type = GFC_DTYPE_UNKNOWN;
|
|
free_saved (dtp);
|
|
|
|
switch (nl->type)
|
|
{
|
|
case GFC_DTYPE_INTEGER:
|
|
read_integer (dtp, len);
|
|
break;
|
|
|
|
case GFC_DTYPE_LOGICAL:
|
|
read_logical (dtp, len);
|
|
break;
|
|
|
|
case GFC_DTYPE_CHARACTER:
|
|
read_character (dtp, len);
|
|
break;
|
|
|
|
case GFC_DTYPE_REAL:
|
|
read_real (dtp, len);
|
|
break;
|
|
|
|
case GFC_DTYPE_COMPLEX:
|
|
read_complex (dtp, len, dlen);
|
|
break;
|
|
|
|
case GFC_DTYPE_DERIVED:
|
|
obj_name_len = strlen (nl->var_name) + 1;
|
|
obj_name = get_mem (obj_name_len+1);
|
|
memcpy (obj_name, nl->var_name, obj_name_len-1);
|
|
memcpy (obj_name + obj_name_len - 1, "%", 2);
|
|
|
|
/* If reading a derived type, disable the expanded read warning
|
|
since a single object can have multiple reads. */
|
|
dtp->u.p.expanded_read = 0;
|
|
|
|
/* Now loop over the components. Update the component pointer
|
|
with the return value from nml_write_obj. This loop jumps
|
|
past nested derived types by testing if the potential
|
|
component name contains '%'. */
|
|
|
|
for (cmp = nl->next;
|
|
cmp &&
|
|
!strncmp (cmp->var_name, obj_name, obj_name_len) &&
|
|
!strchr (cmp->var_name + obj_name_len, '%');
|
|
cmp = cmp->next)
|
|
{
|
|
|
|
if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
|
|
pprev_nl, nml_err_msg, clow, chigh)
|
|
== FAILURE)
|
|
{
|
|
free_mem (obj_name);
|
|
return FAILURE;
|
|
}
|
|
|
|
if (dtp->u.p.input_complete)
|
|
{
|
|
free_mem (obj_name);
|
|
return SUCCESS;
|
|
}
|
|
}
|
|
|
|
free_mem (obj_name);
|
|
goto incr_idx;
|
|
|
|
default:
|
|
sprintf (nml_err_msg, "Bad type for namelist object %s",
|
|
nl->var_name);
|
|
internal_error (&dtp->common, nml_err_msg);
|
|
goto nml_err_ret;
|
|
}
|
|
}
|
|
|
|
/* The standard permits array data to stop short of the number of
|
|
elements specified in the loop specification. In this case, we
|
|
should be here with dtp->u.p.nml_read_error != 0. Control returns to
|
|
nml_get_obj_data and an attempt is made to read object name. */
|
|
|
|
*pprev_nl = nl;
|
|
if (dtp->u.p.nml_read_error)
|
|
{
|
|
dtp->u.p.expanded_read = 0;
|
|
return SUCCESS;
|
|
}
|
|
|
|
if (dtp->u.p.saved_type == GFC_DTYPE_UNKNOWN)
|
|
{
|
|
dtp->u.p.expanded_read = 0;
|
|
goto incr_idx;
|
|
}
|
|
|
|
/* Note the switch from GFC_DTYPE_type to BT_type at this point.
|
|
This comes about because the read functions return BT_types. */
|
|
|
|
switch (dtp->u.p.saved_type)
|
|
{
|
|
|
|
case BT_COMPLEX:
|
|
case BT_REAL:
|
|
case BT_INTEGER:
|
|
case BT_LOGICAL:
|
|
memcpy (pdata, dtp->u.p.value, dlen);
|
|
break;
|
|
|
|
case BT_CHARACTER:
|
|
m = (dlen < dtp->u.p.saved_used) ? dlen : dtp->u.p.saved_used;
|
|
pdata = (void*)( pdata + clow - 1 );
|
|
memcpy (pdata, dtp->u.p.saved_string, m);
|
|
if (m < dlen)
|
|
memset ((void*)( pdata + m ), ' ', dlen - m);
|
|
break;
|
|
|
|
default:
|
|
break;
|
|
}
|
|
|
|
/* Warn if a non-standard expanded read occurs. A single read of a
|
|
single object is acceptable. If a second read occurs, issue a warning
|
|
and set the flag to zero to prevent further warnings. */
|
|
if (dtp->u.p.expanded_read == 2)
|
|
{
|
|
notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read.");
|
|
dtp->u.p.expanded_read = 0;
|
|
}
|
|
|
|
/* If the expanded read warning flag is set, increment it,
|
|
indicating that a single read has occurred. */
|
|
if (dtp->u.p.expanded_read >= 1)
|
|
dtp->u.p.expanded_read++;
|
|
|
|
/* Break out of loop if scalar. */
|
|
if (!nl->var_rank)
|
|
break;
|
|
|
|
/* Now increment the index vector. */
|
|
|
|
incr_idx:
|
|
|
|
nml_carry = 1;
|
|
for (dim = 0; dim < nl->var_rank; dim++)
|
|
{
|
|
nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
|
|
nml_carry = 0;
|
|
if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
|
|
||
|
|
((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
|
|
{
|
|
nl->ls[dim].idx = nl->ls[dim].start;
|
|
nml_carry = 1;
|
|
}
|
|
}
|
|
} while (!nml_carry);
|
|
|
|
if (dtp->u.p.repeat_count > 1)
|
|
{
|
|
sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
|
|
nl->var_name );
|
|
goto nml_err_ret;
|
|
}
|
|
return SUCCESS;
|
|
|
|
nml_err_ret:
|
|
|
|
return FAILURE;
|
|
}
|
|
|
|
/* Parses the object name, including array and substring qualifiers. It
|
|
iterates over derived type components, touching those components and
|
|
setting their loop specifications, if there is a qualifier. If the
|
|
object is itself a derived type, its components and subcomponents are
|
|
touched. nml_read_obj is called at the end and this reads the data in
|
|
the manner specified by the object name. */
|
|
|
|
static try
|
|
nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
|
|
char *nml_err_msg)
|
|
{
|
|
char c;
|
|
namelist_info * nl;
|
|
namelist_info * first_nl = NULL;
|
|
namelist_info * root_nl = NULL;
|
|
int dim, parsed_rank;
|
|
int component_flag;
|
|
char parse_err_msg[30];
|
|
index_type clow, chigh;
|
|
int non_zero_rank_count;
|
|
|
|
/* Look for end of input or object name. If '?' or '=?' are encountered
|
|
in stdin, print the node names or the namelist to stdout. */
|
|
|
|
eat_separator (dtp);
|
|
if (dtp->u.p.input_complete)
|
|
return SUCCESS;
|
|
|
|
if (dtp->u.p.at_eol)
|
|
finish_separator (dtp);
|
|
if (dtp->u.p.input_complete)
|
|
return SUCCESS;
|
|
|
|
c = next_char (dtp);
|
|
switch (c)
|
|
{
|
|
case '=':
|
|
c = next_char (dtp);
|
|
if (c != '?')
|
|
{
|
|
sprintf (nml_err_msg, "namelist read: misplaced = sign");
|
|
goto nml_err_ret;
|
|
}
|
|
nml_query (dtp, '=');
|
|
return SUCCESS;
|
|
|
|
case '?':
|
|
nml_query (dtp, '?');
|
|
return SUCCESS;
|
|
|
|
case '$':
|
|
case '&':
|
|
nml_match_name (dtp, "end", 3);
|
|
if (dtp->u.p.nml_read_error)
|
|
{
|
|
sprintf (nml_err_msg, "namelist not terminated with / or &end");
|
|
goto nml_err_ret;
|
|
}
|
|
case '/':
|
|
dtp->u.p.input_complete = 1;
|
|
return SUCCESS;
|
|
|
|
default :
|
|
break;
|
|
}
|
|
|
|
/* Untouch all nodes of the namelist and reset the flag that is set for
|
|
derived type components. */
|
|
|
|
nml_untouch_nodes (dtp);
|
|
component_flag = 0;
|
|
non_zero_rank_count = 0;
|
|
|
|
/* Get the object name - should '!' and '\n' be permitted separators? */
|
|
|
|
get_name:
|
|
|
|
free_saved (dtp);
|
|
|
|
do
|
|
{
|
|
if (!is_separator (c))
|
|
push_char (dtp, tolower(c));
|
|
c = next_char (dtp);
|
|
} while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
|
|
|
|
unget_char (dtp, c);
|
|
|
|
/* Check that the name is in the namelist and get pointer to object.
|
|
Three error conditions exist: (i) An attempt is being made to
|
|
identify a non-existent object, following a failed data read or
|
|
(ii) The object name does not exist or (iii) Too many data items
|
|
are present for an object. (iii) gives the same error message
|
|
as (i) */
|
|
|
|
push_char (dtp, '\0');
|
|
|
|
if (component_flag)
|
|
{
|
|
size_t var_len = strlen (root_nl->var_name);
|
|
size_t saved_len
|
|
= dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
|
|
char ext_name[var_len + saved_len + 1];
|
|
|
|
memcpy (ext_name, root_nl->var_name, var_len);
|
|
if (dtp->u.p.saved_string)
|
|
memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
|
|
ext_name[var_len + saved_len] = '\0';
|
|
nl = find_nml_node (dtp, ext_name);
|
|
}
|
|
else
|
|
nl = find_nml_node (dtp, dtp->u.p.saved_string);
|
|
|
|
if (nl == NULL)
|
|
{
|
|
if (dtp->u.p.nml_read_error && *pprev_nl)
|
|
sprintf (nml_err_msg, "Bad data for namelist object %s",
|
|
(*pprev_nl)->var_name);
|
|
|
|
else
|
|
sprintf (nml_err_msg, "Cannot match namelist object name %s",
|
|
dtp->u.p.saved_string);
|
|
|
|
goto nml_err_ret;
|
|
}
|
|
|
|
/* Get the length, data length, base pointer and rank of the variable.
|
|
Set the default loop specification first. */
|
|
|
|
for (dim=0; dim < nl->var_rank; dim++)
|
|
{
|
|
nl->ls[dim].step = 1;
|
|
nl->ls[dim].end = nl->dim[dim].ubound;
|
|
nl->ls[dim].start = nl->dim[dim].lbound;
|
|
nl->ls[dim].idx = nl->ls[dim].start;
|
|
}
|
|
|
|
/* Check to see if there is a qualifier: if so, parse it.*/
|
|
|
|
if (c == '(' && nl->var_rank)
|
|
{
|
|
parsed_rank = 0;
|
|
if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
|
|
parse_err_msg, &parsed_rank) == FAILURE)
|
|
{
|
|
sprintf (nml_err_msg, "%s for namelist variable %s",
|
|
parse_err_msg, nl->var_name);
|
|
goto nml_err_ret;
|
|
}
|
|
|
|
if (parsed_rank > 0)
|
|
non_zero_rank_count++;
|
|
|
|
c = next_char (dtp);
|
|
unget_char (dtp, c);
|
|
}
|
|
else if (nl->var_rank > 0)
|
|
non_zero_rank_count++;
|
|
|
|
/* Now parse a derived type component. The root namelist_info address
|
|
is backed up, as is the previous component level. The component flag
|
|
is set and the iteration is made by jumping back to get_name. */
|
|
|
|
if (c == '%')
|
|
{
|
|
if (nl->type != GFC_DTYPE_DERIVED)
|
|
{
|
|
sprintf (nml_err_msg, "Attempt to get derived component for %s",
|
|
nl->var_name);
|
|
goto nml_err_ret;
|
|
}
|
|
|
|
if (!component_flag)
|
|
first_nl = nl;
|
|
|
|
root_nl = nl;
|
|
component_flag = 1;
|
|
c = next_char (dtp);
|
|
goto get_name;
|
|
}
|
|
|
|
/* Parse a character qualifier, if present. chigh = 0 is a default
|
|
that signals that the string length = string_length. */
|
|
|
|
clow = 1;
|
|
chigh = 0;
|
|
|
|
if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
|
|
{
|
|
descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
|
|
array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
|
|
|
|
if (nml_parse_qualifier (dtp, chd, ind, -1, parse_err_msg, &parsed_rank)
|
|
== FAILURE)
|
|
{
|
|
sprintf (nml_err_msg, "%s for namelist variable %s",
|
|
parse_err_msg, nl->var_name);
|
|
goto nml_err_ret;
|
|
}
|
|
|
|
clow = ind[0].start;
|
|
chigh = ind[0].end;
|
|
|
|
if (ind[0].step != 1)
|
|
{
|
|
sprintf (nml_err_msg,
|
|
"Step not allowed in substring qualifier"
|
|
" for namelist object %s", nl->var_name);
|
|
goto nml_err_ret;
|
|
}
|
|
|
|
c = next_char (dtp);
|
|
unget_char (dtp, c);
|
|
}
|
|
|
|
/* If a derived type touch its components and restore the root
|
|
namelist_info if we have parsed a qualified derived type
|
|
component. */
|
|
|
|
if (nl->type == GFC_DTYPE_DERIVED)
|
|
nml_touch_nodes (nl);
|
|
if (component_flag)
|
|
nl = first_nl;
|
|
|
|
/* Make sure no extraneous qualifiers are there. */
|
|
|
|
if (c == '(')
|
|
{
|
|
sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
|
|
" namelist object %s", nl->var_name);
|
|
goto nml_err_ret;
|
|
}
|
|
|
|
/* Make sure there is no more than one non-zero rank object. */
|
|
if (non_zero_rank_count > 1)
|
|
{
|
|
sprintf (nml_err_msg, "Multiple sub-objects with non-zero rank in"
|
|
" namelist object %s", nl->var_name);
|
|
non_zero_rank_count = 0;
|
|
goto nml_err_ret;
|
|
}
|
|
|
|
/* According to the standard, an equal sign MUST follow an object name. The
|
|
following is possibly lax - it allows comments, blank lines and so on to
|
|
intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
|
|
|
|
free_saved (dtp);
|
|
|
|
eat_separator (dtp);
|
|
if (dtp->u.p.input_complete)
|
|
return SUCCESS;
|
|
|
|
if (dtp->u.p.at_eol)
|
|
finish_separator (dtp);
|
|
if (dtp->u.p.input_complete)
|
|
return SUCCESS;
|
|
|
|
c = next_char (dtp);
|
|
|
|
if (c != '=')
|
|
{
|
|
sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
|
|
nl->var_name);
|
|
goto nml_err_ret;
|
|
}
|
|
|
|
if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, clow, chigh) == FAILURE)
|
|
goto nml_err_ret;
|
|
|
|
return SUCCESS;
|
|
|
|
nml_err_ret:
|
|
|
|
return FAILURE;
|
|
}
|
|
|
|
/* Entry point for namelist input. Goes through input until namelist name
|
|
is matched. Then cycles through nml_get_obj_data until the input is
|
|
completed or there is an error. */
|
|
|
|
void
|
|
namelist_read (st_parameter_dt *dtp)
|
|
{
|
|
char c;
|
|
jmp_buf eof_jump;
|
|
char nml_err_msg[100];
|
|
/* Pointer to the previously read object, in case attempt is made to read
|
|
new object name. Should this fail, error message can give previous
|
|
name. */
|
|
namelist_info *prev_nl = NULL;
|
|
|
|
dtp->u.p.namelist_mode = 1;
|
|
dtp->u.p.input_complete = 0;
|
|
dtp->u.p.expanded_read = 0;
|
|
|
|
dtp->u.p.eof_jump = &eof_jump;
|
|
if (setjmp (eof_jump))
|
|
{
|
|
dtp->u.p.eof_jump = NULL;
|
|
generate_error (&dtp->common, LIBERROR_END, NULL);
|
|
return;
|
|
}
|
|
|
|
/* Look for &namelist_name . Skip all characters, testing for $nmlname.
|
|
Exit on success or EOF. If '?' or '=?' encountered in stdin, print
|
|
node names or namelist on stdout. */
|
|
|
|
find_nml_name:
|
|
switch (c = next_char (dtp))
|
|
{
|
|
case '$':
|
|
case '&':
|
|
break;
|
|
|
|
case '!':
|
|
eat_line (dtp);
|
|
goto find_nml_name;
|
|
|
|
case '=':
|
|
c = next_char (dtp);
|
|
if (c == '?')
|
|
nml_query (dtp, '=');
|
|
else
|
|
unget_char (dtp, c);
|
|
goto find_nml_name;
|
|
|
|
case '?':
|
|
nml_query (dtp, '?');
|
|
|
|
default:
|
|
goto find_nml_name;
|
|
}
|
|
|
|
/* Match the name of the namelist. */
|
|
|
|
nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
|
|
|
|
if (dtp->u.p.nml_read_error)
|
|
goto find_nml_name;
|
|
|
|
/* A trailing space is required, we give a little lattitude here, 10.9.1. */
|
|
c = next_char (dtp);
|
|
if (!is_separator(c))
|
|
{
|
|
unget_char (dtp, c);
|
|
goto find_nml_name;
|
|
}
|
|
|
|
/* Ready to read namelist objects. If there is an error in input
|
|
from stdin, output the error message and continue. */
|
|
|
|
while (!dtp->u.p.input_complete)
|
|
{
|
|
if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg) == FAILURE)
|
|
{
|
|
gfc_unit *u;
|
|
|
|
if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
|
|
goto nml_err_ret;
|
|
|
|
u = find_unit (options.stderr_unit);
|
|
st_printf ("%s\n", nml_err_msg);
|
|
if (u != NULL)
|
|
{
|
|
flush (u->s);
|
|
unlock_unit (u);
|
|
}
|
|
}
|
|
|
|
}
|
|
|
|
dtp->u.p.eof_jump = NULL;
|
|
free_saved (dtp);
|
|
free_line (dtp);
|
|
return;
|
|
|
|
/* All namelist error calls return from here */
|
|
|
|
nml_err_ret:
|
|
|
|
dtp->u.p.eof_jump = NULL;
|
|
free_saved (dtp);
|
|
free_line (dtp);
|
|
generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
|
|
return;
|
|
}
|