#include "config.h"
#include <string.h>
#include <ctype.h>
#include "libgfortran.h"
#include "io.h"
#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'
#define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
|| c == '\t' || c == '\r')
#define MAX_REPEAT 200000000
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;
}
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;
}
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;
}
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;
}
if (is_array_io(dtp))
{
if (dtp->u.p.at_eof)
longjmp (*dtp->u.p.eof_jump, 1);
if (dtp->u.p.current_unit->bytes_left == 0)
{
c = '\n';
record = next_array_record (dtp, dtp->u.p.current_unit->ls);
if (record == 0)
{
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;
}
}
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))
{
if (p == NULL)
{
generate_error (&dtp->common, ERROR_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, ERROR_OS, NULL);
return '\0';
}
if (length == 0)
longjmp (*dtp->u.p.eof_jump, 1);
c = *p;
}
done:
dtp->u.p.at_eol = (c == '\n' || c == '\r');
return c;
}
static void
unget_char (st_parameter_dt *dtp, char c)
{
dtp->u.p.last_char = c;
}
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;
}
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':
n = next_char(dtp);
if (n == '\n')
dtp->u.p.at_eol = 1;
else
unget_char (dtp, n);
break;
case '\n':
dtp->u.p.at_eol = 1;
break;
case '!':
if (dtp->u.p.namelist_mode)
{
do
c = next_char (dtp);
while (c != '\n');
break;
}
default:
unget_char (dtp, c);
break;
}
}
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;
}
}
static void
eat_line (st_parameter_dt *dtp)
{
char c;
if (!is_internal_unit (dtp))
do
c = next_char (dtp);
while (c != '\n');
}
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;
}
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)
{
st_sprintf (message, "Zero repeat count in item %d of list input",
dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message);
m = 1;
}
}
free_saved (dtp);
return m;
overflow:
if (length == -1)
st_sprintf (message, "Repeat count overflow in item %d of list input",
dtp->u.p.item_count);
else
st_sprintf (message, "Integer overflow while reading item %d",
dtp->u.p.item_count);
free_saved (dtp);
generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
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)
{
st_sprintf (message,
"Repeat count overflow in item %d of list input",
dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
break;
case '*':
if (repeat == 0)
{
st_sprintf (message,
"Zero repeat count in item %d of list input",
dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_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);
st_sprintf (message, "Bad repeat count in item %d of list input",
dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
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;
}
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;
default:
goto bad_logical;
}
dtp->u.p.saved_type = BT_LOGICAL;
dtp->u.p.saved_length = length;
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))
{
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);
st_sprintf (message, "Bad logical value while reading item %d",
dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_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);
}
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;
case '+':
c = next_char (dtp);
goto get_integer;
CASE_SEPARATORS:
unget_char (dtp, c);
eat_separator (dtp);
return;
CASE_DIGITS:
push_char (dtp, c);
break;
default:
goto bad_integer;
}
for (;;)
{
c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
push_char (dtp, c);
break;
case '*':
push_char (dtp, '\0');
goto repeat;
CASE_SEPARATORS:
goto done;
default:
goto bad_integer;
}
}
repeat:
if (convert_integer (dtp, -1, 0))
return;
c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
break;
CASE_SEPARATORS:
unget_char (dtp, c);
eat_separator (dtp);
return;
case '-':
negative = 1;
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);
st_sprintf (message, "Bad integer for item %d in list input",
dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_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;
}
static void
read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
{
char c, quote, message[100];
quote = ' ';
c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
push_char (dtp, c);
break;
CASE_SEPARATORS:
unget_char (dtp, c);
eat_separator (dtp);
return;
case '"':
case '\'':
quote = c;
goto get_string;
default:
if (dtp->u.p.namelist_mode)
{
unget_char (dtp,c);
return;
}
push_char (dtp, c);
goto get_string;
}
for (;;)
{
c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
push_char (dtp, c);
break;
CASE_SEPARATORS:
unget_char (dtp, c);
goto done;
case '*':
push_char (dtp, '\0');
goto got_repeat;
default:
push_char (dtp, c);
goto get_string;
}
}
got_repeat:
if (convert_integer (dtp, -1, 0))
return;
c = next_char (dtp);
switch (c)
{
CASE_SEPARATORS:
unget_char (dtp, c);
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;
}
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;
}
}
done:
c = next_char (dtp);
if (is_separator (c))
{
unget_char (dtp, c);
eat_separator (dtp);
dtp->u.p.saved_type = BT_CHARACTER;
}
else
{
free_saved (dtp);
st_sprintf (message, "Invalid string input in item %d",
dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message);
}
}
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 != '.')
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;
bad:
if (nml_bad_return (dtp, c))
return 0;
eat_line (dtp);
free_saved (dtp);
st_sprintf (message, "Bad floating point number for item %d",
dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
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);
st_sprintf (message, "Bad complex value in item %d of list input",
dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message);
}
static void
read_real (st_parameter_dt *dtp, int length)
{
char c, message[100];
int seen_dp;
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);
eat_separator (dtp);
return;
default:
goto bad_real;
}
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;
c = next_char (dtp);
if (is_separator (c))
{
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 != '.')
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;
bad_real:
if (nml_bad_return (dtp, c))
return;
eat_line (dtp);
free_saved (dtp);
st_sprintf (message, "Bad real number in item %d of list input",
dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message);
}
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)
{
st_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, ERROR_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)
{
st_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, ERROR_READ_VALUE, message);
return 1;
}
return 0;
}
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, ERROR_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))
{
eat_separator (dtp);
dtp->u.p.repeat_count = 0;
if (dtp->u.p.comma_flag)
goto cleanup;
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);
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
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;
for (elem = 0; elem < nelems; elem++)
{
dtp->u.p.item_count++;
list_formatted_read_scalar (dtp, type, tmp + size*elem, kind, size);
}
}
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');
}
static try
nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
array_loop_spec *ls, int rank, char *parse_err_msg)
{
int dim;
int indx;
int neg;
int null_flag;
int is_array_section;
char c;
is_array_section = 0;
dtp->u.p.expanded_read = 0;
c = next_char (dtp);
for (dim=0; dim < rank; dim++ )
{
for (indx=0; indx<3; indx++)
{
free_saved (dtp);
eat_spaces (dtp);
neg = 0;
c = next_char (dtp);
switch (c)
{
case '-':
neg = 1;
break;
case '+':
break;
default:
unget_char (dtp, c);
break;
}
for (;;)
{
c = next_char (dtp);
switch (c)
{
case ':':
is_array_section = 1;
break;
case ',': case ')':
if ((c==',' && dim == rank -1)
|| (c==')' && dim < rank -1))
{
st_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:
st_sprintf (parse_err_msg, "Bad character in index");
goto err_ret;
}
if ((c == ',' || c == ')') && indx == 0
&& dtp->u.p.saved_string == 0)
{
st_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))
{
st_sprintf(parse_err_msg, "Bad index triplet");
goto err_ret;
}
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;
}
if (convert_integer (dtp, sizeof(ssize_t), neg))
{
st_sprintf (parse_err_msg, "Bad integer in index");
goto err_ret;
}
break;
}
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));
}
if (c==',' || c==')')
{
if (indx == 0)
{
memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
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;
}
break;
}
}
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))
{
st_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))
{
st_sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
goto err_ret;
}
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;
}
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);
strcpy (ext_name, nl->var_name);
strcat (ext_name, "%");
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;
}
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;
}
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;
}
}
}
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;
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);
if (c == '=')
namelist_write (dtp);
else
{
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)
{
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
}
#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 (dtp->u.p.current_unit->s);
unlock_unit (dtp->u.p.current_unit);
}
query_return:
dtp->u.p.current_unit = temp_unit;
dtp->u.p.mode = READING;
return;
}
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;
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
{
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);
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;
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);
strcpy (obj_name, nl->var_name);
strcat (obj_name, "%");
dtp->u.p.expanded_read = 0;
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:
st_sprintf (nml_err_msg, "Bad type for namelist object %s",
nl->var_name);
internal_error (&dtp->common, nml_err_msg);
goto nml_err_ret;
}
}
*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;
}
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;
}
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 (dtp->u.p.expanded_read >= 1)
dtp->u.p.expanded_read++;
if (!nl->var_rank)
break;
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)
{
st_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;
}
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;
int component_flag;
char parse_err_msg[30];
index_type clow, chigh;
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 != '?')
{
st_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)
{
st_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;
}
nml_untouch_nodes (dtp);
component_flag = 0;
get_name:
free_saved (dtp);
do
{
push_char (dtp, tolower(c));
c = next_char (dtp);
} while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
unget_char (dtp, c);
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)
st_sprintf (nml_err_msg, "Bad data for namelist object %s",
(*pprev_nl)->var_name);
else
st_sprintf (nml_err_msg, "Cannot match namelist object name %s",
dtp->u.p.saved_string);
goto nml_err_ret;
}
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;
}
if (c == '(' && nl->var_rank)
{
if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
parse_err_msg) == FAILURE)
{
st_sprintf (nml_err_msg, "%s for namelist variable %s",
parse_err_msg, nl->var_name);
goto nml_err_ret;
}
c = next_char (dtp);
unget_char (dtp, c);
}
if (c == '%')
{
if (nl->type != GFC_DTYPE_DERIVED)
{
st_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;
}
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) == FAILURE)
{
st_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)
{
st_sprintf (nml_err_msg,
"Bad step in substring for namelist object %s",
nl->var_name);
goto nml_err_ret;
}
c = next_char (dtp);
unget_char (dtp, c);
}
if (nl->type == GFC_DTYPE_DERIVED)
nml_touch_nodes (nl);
if (component_flag)
nl = first_nl;
if (c == '(')
{
st_sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
" namelist object %s", nl->var_name);
goto nml_err_ret;
}
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 != '=')
{
st_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;
}
void
namelist_read (st_parameter_dt *dtp)
{
char c;
jmp_buf eof_jump;
char nml_err_msg[100];
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, ERROR_END, NULL);
return;
}
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;
}
nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
if (dtp->u.p.nml_read_error)
goto find_nml_name;
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;
nml_err_ret:
dtp->u.p.eof_jump = NULL;
free_saved (dtp);
free_line (dtp);
generate_error (&dtp->common, ERROR_READ_VALUE, nml_err_msg);
return;
}