#include "config.h"
#include <string.h>
#include <ctype.h>
#include "libgfortran.h"
#include "io.h"
static int repeat_count, saved_length, saved_used;
static int input_complete, at_eol, comma_flag;
static char last_char, *saved_string;
static bt saved_type;
static int namelist_mode;
static int nml_read_error;
static char value[20];
#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 (char c)
{
char *new;
if (saved_string == NULL)
{
saved_string = scratch;
memset (saved_string,0,SCRATCH_SIZE);
saved_length = SCRATCH_SIZE;
saved_used = 0;
}
if (saved_used >= saved_length)
{
saved_length = 2 * saved_length;
new = get_mem (2 * saved_length);
memset (new,0,2 * saved_length);
memcpy (new, saved_string, saved_used);
if (saved_string != scratch)
free_mem (saved_string);
saved_string = new;
}
saved_string[saved_used++] = c;
}
static void
free_saved (void)
{
if (saved_string == NULL)
return;
if (saved_string != scratch)
free_mem (saved_string);
saved_string = NULL;
}
static char
next_char (void)
{
int length;
char c, *p;
if (last_char != '\0')
{
at_eol = 0;
c = last_char;
last_char = '\0';
goto done;
}
length = 1;
p = salloc_r (current_unit->s, &length);
if (p == NULL)
{
generate_error (ERROR_OS, NULL);
return '\0';
}
if (length == 0)
{
if (is_internal_unit ())
c = '\n';
else
longjmp (g.eof_jump, 1);
}
else
c = *p;
done:
at_eol = (c == '\n' || c == '\r');
return c;
}
static void
unget_char (char c)
{
last_char = c;
}
static char
eat_spaces (void)
{
char c;
do
{
c = next_char ();
}
while (c == ' ' || c == '\t');
unget_char (c);
return c;
}
static void
eat_separator (void)
{
char c;
eat_spaces ();
comma_flag = 0;
c = next_char ();
switch (c)
{
case ',':
comma_flag = 1;
eat_spaces ();
break;
case '/':
input_complete = 1;
break;
case '\n':
case '\r':
at_eol = 1;
break;
case '!':
if (namelist_mode)
{
do
c = next_char ();
while (c != '\n');
break;
}
default:
unget_char (c);
break;
}
}
static void
finish_separator (void)
{
char c;
restart:
eat_spaces ();
c = next_char ();
switch (c)
{
case ',':
if (comma_flag)
unget_char (c);
else
{
c = eat_spaces ();
if (c == '\n')
goto restart;
}
break;
case '/':
input_complete = 1;
if (!namelist_mode) next_record (0);
break;
case '\n':
case '\r':
goto restart;
case '!':
if (namelist_mode)
{
do
c = next_char ();
while (c != '\n');
goto restart;
}
default:
unget_char (c);
break;
}
}
static int
nml_bad_return (char c)
{
if (namelist_mode)
{
nml_read_error = 1;
unget_char(c);
return 1;
}
return 0;
}
static int
convert_integer (int length, int negative)
{
char c, *buffer, message[100];
int m;
int64_t v, max, max10;
buffer = 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 (value, v, length);
}
else
{
repeat_count = v;
if (repeat_count == 0)
{
st_sprintf (message, "Zero repeat count in item %d of list input",
g.item_count);
generate_error (ERROR_READ_VALUE, message);
m = 1;
}
}
free_saved ();
return m;
overflow:
if (length == -1)
st_sprintf (message, "Repeat count overflow in item %d of list input",
g.item_count);
else
st_sprintf (message, "Integer overflow while reading item %d",
g.item_count);
free_saved ();
generate_error (ERROR_READ_VALUE, message);
return 1;
}
static int
parse_repeat (void)
{
char c, message[100];
int repeat;
c = next_char ();
switch (c)
{
CASE_DIGITS:
repeat = c - '0';
break;
CASE_SEPARATORS:
unget_char (c);
eat_separator ();
return 1;
default:
unget_char (c);
return 0;
}
for (;;)
{
c = next_char ();
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",
g.item_count);
generate_error (ERROR_READ_VALUE, message);
return 1;
}
break;
case '*':
if (repeat == 0)
{
st_sprintf (message,
"Zero repeat count in item %d of list input",
g.item_count);
generate_error (ERROR_READ_VALUE, message);
return 1;
}
goto done;
default:
goto bad_repeat;
}
}
done:
repeat_count = repeat;
return 0;
bad_repeat:
st_sprintf (message, "Bad repeat count in item %d of list input",
g.item_count);
generate_error (ERROR_READ_VALUE, message);
return 1;
}
static void
read_logical (int length)
{
char c, message[100];
int v;
if (parse_repeat ())
return;
c = next_char ();
switch (c)
{
case 't':
case 'T':
v = 1;
break;
case 'f':
case 'F':
v = 0;
break;
case '.':
c = next_char ();
switch (c)
{
case 't':
case 'T':
v = 1;
break;
case 'f':
case 'F':
v = 0;
break;
default:
goto bad_logical;
}
break;
CASE_SEPARATORS:
unget_char (c);
eat_separator ();
return;
default:
goto bad_logical;
}
saved_type = BT_LOGICAL;
saved_length = length;
do
{
c = next_char ();
}
while (!is_separator (c));
unget_char (c);
eat_separator ();
free_saved ();
set_integer ((int *) value, v, length);
return;
bad_logical:
if (nml_bad_return (c))
return;
st_sprintf (message, "Bad logical value while reading item %d",
g.item_count);
generate_error (ERROR_READ_VALUE, message);
}
static void
read_integer (int length)
{
char c, message[100];
int negative;
negative = 0;
c = next_char ();
switch (c)
{
case '-':
negative = 1;
case '+':
c = next_char ();
goto get_integer;
CASE_SEPARATORS:
unget_char (c);
eat_separator ();
return;
CASE_DIGITS:
push_char (c);
break;
default:
goto bad_integer;
}
for (;;)
{
c = next_char ();
switch (c)
{
CASE_DIGITS:
push_char (c);
break;
case '*':
push_char ('\0');
goto repeat;
CASE_SEPARATORS:
goto done;
default:
goto bad_integer;
}
}
repeat:
if (convert_integer (-1, 0))
return;
c = next_char ();
switch (c)
{
CASE_DIGITS:
break;
CASE_SEPARATORS:
unget_char (c);
eat_separator ();
return;
case '-':
negative = 1;
case '+':
c = next_char ();
break;
}
get_integer:
if (!isdigit (c))
goto bad_integer;
push_char (c);
for (;;)
{
c = next_char ();
switch (c)
{
CASE_DIGITS:
push_char (c);
break;
CASE_SEPARATORS:
goto done;
default:
goto bad_integer;
}
}
bad_integer:
if (nml_bad_return (c))
return;
free_saved ();
st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
generate_error (ERROR_READ_VALUE, message);
return;
done:
unget_char (c);
eat_separator ();
push_char ('\0');
if (convert_integer (length, negative))
{
free_saved ();
return;
}
free_saved ();
saved_type = BT_INTEGER;
}
static void
read_character (int length)
{
char c, quote, message[100];
quote = ' ';
c = next_char ();
switch (c)
{
CASE_DIGITS:
push_char (c);
break;
CASE_SEPARATORS:
unget_char (c);
eat_separator ();
return;
case '"':
case '\'':
quote = c;
goto get_string;
default:
push_char (c);
goto get_string;
}
for (;;)
{
c = next_char ();
switch (c)
{
CASE_DIGITS:
push_char (c);
break;
CASE_SEPARATORS:
unget_char (c);
goto done;
case '*':
push_char ('\0');
goto got_repeat;
default:
push_char (c);
goto get_string;
}
}
got_repeat:
if (convert_integer (-1, 0))
return;
c = next_char ();
switch (c)
{
CASE_SEPARATORS:
unget_char (c);
eat_separator ();
return;
case '"':
case '\'':
quote = c;
break;
default:
push_char (c);
break;
}
get_string:
for (;;)
{
c = next_char ();
switch (c)
{
case '"':
case '\'':
if (c != quote)
{
push_char (c);
break;
}
c = next_char ();
if (c == quote)
{
push_char (quote);
break;
}
unget_char (c);
goto done;
CASE_SEPARATORS:
if (quote == ' ')
{
unget_char (c);
goto done;
}
if (c != '\n')
push_char (c);
break;
default:
push_char (c);
break;
}
}
done:
c = next_char ();
if (is_separator (c))
{
unget_char (c);
eat_separator ();
saved_type = BT_CHARACTER;
}
else
{
free_saved ();
st_sprintf (message, "Invalid string input in item %d", g.item_count);
generate_error (ERROR_READ_VALUE, message);
}
}
static int
parse_real (void *buffer, int length)
{
char c, message[100];
int m, seen_dp;
c = next_char ();
if (c == '-' || c == '+')
{
push_char (c);
c = next_char ();
}
if (!isdigit (c) && c != '.')
goto bad;
push_char (c);
seen_dp = (c == '.') ? 1 : 0;
for (;;)
{
c = next_char ();
switch (c)
{
CASE_DIGITS:
push_char (c);
break;
case '.':
if (seen_dp)
goto bad;
seen_dp = 1;
push_char (c);
break;
case 'e':
case 'E':
case 'd':
case 'D':
push_char ('e');
goto exp1;
case '-':
case '+':
push_char ('e');
push_char (c);
c = next_char ();
goto exp2;
CASE_SEPARATORS:
unget_char (c);
goto done;
default:
goto done;
}
}
exp1:
c = next_char ();
if (c != '-' && c != '+')
push_char ('+');
else
{
push_char (c);
c = next_char ();
}
exp2:
if (!isdigit (c))
goto bad;
push_char (c);
for (;;)
{
c = next_char ();
switch (c)
{
CASE_DIGITS:
push_char (c);
break;
CASE_SEPARATORS:
unget_char (c);
goto done;
default:
goto done;
}
}
done:
unget_char (c);
push_char ('\0');
m = convert_real (buffer, saved_string, length);
free_saved ();
return m;
bad:
free_saved ();
st_sprintf (message, "Bad floating point number for item %d", g.item_count);
generate_error (ERROR_READ_VALUE, message);
return 1;
}
static void
read_complex (int length)
{
char message[100];
char c;
if (parse_repeat ())
return;
c = next_char ();
switch (c)
{
case '(':
break;
CASE_SEPARATORS:
unget_char (c);
eat_separator ();
return;
default:
goto bad_complex;
}
eat_spaces ();
if (parse_real (value, length))
return;
eat_spaces ();
if (next_char () != ',')
goto bad_complex;
eat_spaces ();
if (parse_real (value + length, length))
return;
eat_spaces ();
if (next_char () != ')')
goto bad_complex;
c = next_char ();
if (!is_separator (c))
goto bad_complex;
unget_char (c);
eat_separator ();
free_saved ();
saved_type = BT_COMPLEX;
return;
bad_complex:
if (nml_bad_return (c))
return;
st_sprintf (message, "Bad complex value in item %d of list input",
g.item_count);
generate_error (ERROR_READ_VALUE, message);
}
static void
read_real (int length)
{
char c, message[100];
int seen_dp;
seen_dp = 0;
c = next_char ();
switch (c)
{
CASE_DIGITS:
push_char (c);
break;
case '.':
push_char (c);
seen_dp = 1;
break;
case '+':
case '-':
goto got_sign;
CASE_SEPARATORS:
unget_char (c);
eat_separator ();
return;
default:
goto bad_real;
}
for (;;)
{
c = next_char ();
switch (c)
{
CASE_DIGITS:
push_char (c);
break;
case '.':
if (seen_dp)
goto bad_real;
seen_dp = 1;
push_char (c);
goto real_loop;
case 'E':
case 'e':
case 'D':
case 'd':
goto exp1;
case '+':
case '-':
push_char ('e');
push_char (c);
c = next_char ();
goto exp2;
case '*':
push_char ('\0');
goto got_repeat;
CASE_SEPARATORS:
if (c != '\n' && c != ',' && c != '\r')
unget_char (c);
goto done;
default:
goto bad_real;
}
}
got_repeat:
if (convert_integer (-1, 0))
return;
c = next_char ();
if (is_separator (c))
{
unget_char (c);
eat_separator ();
return;
}
if (c != '-' && c != '+')
push_char ('+');
else
{
got_sign:
push_char (c);
c = next_char ();
}
if (!isdigit (c) && c != '.')
goto bad_real;
if (c == '.')
{
if (seen_dp)
goto bad_real;
else
seen_dp = 1;
}
push_char (c);
real_loop:
for (;;)
{
c = next_char ();
switch (c)
{
CASE_DIGITS:
push_char (c);
break;
CASE_SEPARATORS:
goto done;
case '.':
if (seen_dp)
goto bad_real;
seen_dp = 1;
push_char (c);
break;
case 'E':
case 'e':
case 'D':
case 'd':
goto exp1;
case '+':
case '-':
push_char ('e');
push_char (c);
c = next_char ();
goto exp2;
default:
goto bad_real;
}
}
exp1:
push_char ('e');
c = next_char ();
if (c != '+' && c != '-')
push_char ('+');
else
{
push_char (c);
c = next_char ();
}
exp2:
if (!isdigit (c))
goto bad_real;
push_char (c);
for (;;)
{
c = next_char ();
switch (c)
{
CASE_DIGITS:
push_char (c);
break;
CASE_SEPARATORS:
goto done;
default:
goto bad_real;
}
}
done:
unget_char (c);
eat_separator ();
push_char ('\0');
if (convert_real (value, saved_string, length))
return;
free_saved ();
saved_type = BT_REAL;
return;
bad_real:
if (nml_bad_return (c))
return;
st_sprintf (message, "Bad real number in item %d of list input",
g.item_count);
generate_error (ERROR_READ_VALUE, message);
}
static int
check_type (bt type, int len)
{
char message[100];
if (saved_type != BT_NULL && saved_type != type)
{
st_sprintf (message, "Read type %s where %s was expected for item %d",
type_name (saved_type), type_name (type), g.item_count);
generate_error (ERROR_READ_VALUE, message);
return 1;
}
if (saved_type == BT_NULL || saved_type == BT_CHARACTER)
return 0;
if (saved_length != len)
{
st_sprintf (message,
"Read kind %d %s where kind %d is required for item %d",
saved_length, type_name (saved_type), len, g.item_count);
generate_error (ERROR_READ_VALUE, message);
return 1;
}
return 0;
}
void
list_formatted_read (bt type, void *p, int len)
{
char c;
int m;
namelist_mode = 0;
if (setjmp (g.eof_jump))
{
generate_error (ERROR_END, NULL);
return;
}
if (g.first_item)
{
g.first_item = 0;
input_complete = 0;
repeat_count = 1;
at_eol = 0;
c = eat_spaces ();
if (is_separator (c))
{
eat_separator ();
repeat_count = 0;
if (at_eol)
finish_separator ();
else
return;
}
}
else
{
if (input_complete)
return;
if (repeat_count > 0)
{
if (check_type (type, len))
return;
goto set_value;
}
if (at_eol)
finish_separator ();
else
{
eat_spaces ();
if (at_eol)
finish_separator ();
}
saved_type = BT_NULL;
repeat_count = 1;
}
switch (type)
{
case BT_INTEGER:
read_integer (len);
break;
case BT_LOGICAL:
read_logical (len);
break;
case BT_CHARACTER:
read_character (len);
break;
case BT_REAL:
read_real (len);
break;
case BT_COMPLEX:
read_complex (len);
break;
default:
internal_error ("Bad type for list read");
}
if (saved_type != BT_CHARACTER && saved_type != BT_NULL)
saved_length = len;
if (ioparm.library_return != LIBRARY_OK)
return;
set_value:
switch (saved_type)
{
case BT_COMPLEX:
len = 2 * len;
case BT_INTEGER:
case BT_REAL:
case BT_LOGICAL:
memcpy (p, value, len);
break;
case BT_CHARACTER:
if (saved_string)
{
m = (len < saved_used) ? len : saved_used;
memcpy (p, saved_string, m);
}
else
m = 0;
if (m < len)
memset (((char *) p) + m, ' ', len - m);
break;
case BT_NULL:
break;
}
if (--repeat_count <= 0)
free_saved ();
}
void
init_at_eol(void)
{
at_eol = 0;
}
void
finish_list_read (void)
{
char c;
free_saved ();
if (at_eol)
{
at_eol = 0;
return;
}
do
{
c = next_char ();
}
while (c != '\n');
}
static char parse_err_msg[30];
static char nml_err_msg[100];
static namelist_info * prev_nl;
static index_type clow;
static index_type chigh;
static try
nml_parse_qualifier(descriptor_dimension * ad,
nml_loop_spec * ls, int rank)
{
int dim;
int indx;
int neg;
int null_flag;
char c;
c = next_char ();
for (dim=0; dim < rank; dim++ )
{
for (indx=0; indx<3; indx++)
{
free_saved ();
eat_spaces ();
neg = 0;
c = next_char ();
switch (c)
{
case '-':
neg = 1;
break;
case '+':
break;
default:
unget_char (c);
break;
}
for (;;)
{
c = next_char ();
switch (c)
{
case ':':
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 (c);
continue;
case ' ': case '\t':
eat_spaces ();
c = next_char ();
break;
default:
st_sprintf (parse_err_msg, "Bad character in index");
goto err_ret;
}
if (( c==',' || c==')') && indx==0 && saved_string == 0 )
{
st_sprintf (parse_err_msg, "Null index field");
goto err_ret;
}
if ( ( c==':' && indx==1 && saved_string == 0)
|| (indx==2 && saved_string == 0))
{
st_sprintf(parse_err_msg, "Bad index triplet");
goto err_ret;
}
null_flag = 0;
if ( (c==':' && indx==0 && saved_string == 0)
|| (indx==1 && saved_string == 0))
{
null_flag = 1;
break;
}
if (convert_integer (sizeof(int),neg))
{
st_sprintf (parse_err_msg, "Bad integer in index");
goto err_ret;
}
break;
}
if (!null_flag)
{
if (indx == 0)
ls[dim].start = *(int *)value;
if (indx == 1)
ls[dim].end = *(int *)value;
if (indx == 2)
ls[dim].step = *(int *)value;
}
if (c==',' || c==')')
{
if (indx == 0)
{
ls[dim].start = *(int *)value;
ls[dim].end = *(int *)value;
}
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 ();
return SUCCESS;
err_ret:
return FAILURE;
}
static namelist_info *
find_nml_node (char * var_name)
{
namelist_info * t = 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 (void)
{
namelist_info * t;
for (t = ionml; t; t = t->next)
t->touched = 0;
return;
}
static void
nml_match_name (char *name, index_type len)
{
index_type i;
char c;
nml_read_error = 0;
for (i = 0; i < len; i++)
{
c = next_char ();
if (tolower (c) != tolower (name[i]))
{
nml_read_error = 1;
break;
}
}
}
static void
nml_query (char c)
{
gfc_unit * temp_unit;
namelist_info * nl;
index_type len;
char * p;
if (current_unit->unit_number != options.stdin_unit)
return;
temp_unit = current_unit;
current_unit = find_unit (options.stdout_unit);
if (current_unit)
{
g.mode =WRITING;
next_record (0);
if (c == '=')
namelist_write ();
else
{
len = ioparm.namelist_name_len;
p = write_block (len + 2);
if (!p)
goto query_return;
memcpy (p, "&", 1);
memcpy ((char*)(p + 1), ioparm.namelist_name, len);
memcpy ((char*)(p + len + 1), "\n", 1);
for (nl =ionml; nl; nl = nl->next)
{
len = strlen (nl->var_name);
p = write_block (len + 2);
if (!p)
goto query_return;
memcpy (p, " ", 1);
memcpy ((char*)(p + 1), nl->var_name, len);
memcpy ((char*)(p + len + 1), "\n", 1);
}
p = write_block (5);
if (!p)
goto query_return;
memcpy (p, "&end\n", 5);
}
flush (current_unit->s);
}
query_return:
current_unit = temp_unit;
g.mode = READING;
return;
}
static try
nml_read_obj (namelist_info * nl, index_type offset)
{
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;
repeat_count = 0;
eat_spaces();
len = nl->len;
switch (nl->type)
{
case GFC_DTYPE_INTEGER:
case GFC_DTYPE_LOGICAL:
case GFC_DTYPE_REAL:
dlen = len;
break;
case GFC_DTYPE_COMPLEX:
dlen = 2* 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);
nml_read_error = 0;
nml_carry = 0;
if (--repeat_count <= 0)
{
if (input_complete)
return SUCCESS;
if (at_eol)
finish_separator ();
if (input_complete)
return SUCCESS;
saved_type = GFC_DTYPE_UNKNOWN;
free_saved ();
switch (nl->type)
{
case GFC_DTYPE_INTEGER:
read_integer (len);
break;
case GFC_DTYPE_LOGICAL:
read_logical (len);
break;
case GFC_DTYPE_CHARACTER:
read_character (len);
break;
case GFC_DTYPE_REAL:
read_real (len);
break;
case GFC_DTYPE_COMPLEX:
read_complex (len);
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, "%");
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 (cmp, (index_type)(pdata - nl->mem_pos)) == FAILURE)
{
free_mem (obj_name);
return FAILURE;
}
if (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 (nml_err_msg);
goto nml_err_ret;
}
}
prev_nl = nl;
if (nml_read_error)
return SUCCESS;
if (saved_type == GFC_DTYPE_UNKNOWN)
goto incr_idx;
switch (saved_type)
{
case BT_COMPLEX:
case BT_REAL:
case BT_INTEGER:
case BT_LOGICAL:
memcpy (pdata, value, dlen);
break;
case BT_CHARACTER:
m = (dlen < saved_used) ? dlen : saved_used;
pdata = (void*)( pdata + clow - 1 );
memcpy (pdata, saved_string, m);
if (m < dlen)
memset ((void*)( pdata + m ), ' ', dlen - m);
break;
default:
break;
}
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 (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 (void)
{
char c;
char * ext_name;
namelist_info * nl;
namelist_info * first_nl;
namelist_info * root_nl;
int dim;
int component_flag;
eat_separator ();
if (input_complete)
return SUCCESS;
if ( at_eol )
finish_separator ();
if (input_complete)
return SUCCESS;
c = next_char ();
switch (c)
{
case '=':
c = next_char ();
if (c != '?')
{
st_sprintf (nml_err_msg, "namelist read: missplaced = sign");
goto nml_err_ret;
}
nml_query ('=');
return SUCCESS;
case '?':
nml_query ('?');
return SUCCESS;
case '$':
case '&':
nml_match_name ("end", 3);
if (nml_read_error)
{
st_sprintf (nml_err_msg, "namelist not terminated with / or &end");
goto nml_err_ret;
}
case '/':
input_complete = 1;
return SUCCESS;
default :
break;
}
nml_untouch_nodes();
component_flag = 0;
get_name:
free_saved ();
do
{
push_char(tolower(c));
c = next_char ();
} while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
unget_char (c);
push_char ('\0');
if (component_flag)
{
ext_name = (char*)get_mem (strlen (root_nl->var_name)
+ (saved_string ? strlen (saved_string) : 0)
+ 1);
strcpy (ext_name, root_nl->var_name);
strcat (ext_name, saved_string);
nl = find_nml_node (ext_name);
free_mem (ext_name);
}
else
nl = find_nml_node (saved_string);
if (nl == NULL)
{
if (nml_read_error && prev_nl)
st_sprintf (nml_err_msg, "Bad data for namelist object %s",
prev_nl->var_name);
else
st_sprintf (nml_err_msg, "Cannot match namelist object name %s",
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 (nl->dim, nl->ls, nl->var_rank) == FAILURE)
{
st_sprintf (nml_err_msg, "%s for namelist variable %s",
parse_err_msg, nl->var_name);
goto nml_err_ret;
}
c = next_char ();
unget_char (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 ();
goto get_name;
}
clow = 1;
chigh = 0;
if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
{
descriptor_dimension chd[1] = {1, clow, nl->string_length};
nml_loop_spec ind[1] = {1, clow, nl->string_length, 1};
if (nml_parse_qualifier (chd, ind, 1) == 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 ();
unget_char (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 ();
eat_separator ();
if (input_complete)
return SUCCESS;
if (at_eol)
finish_separator ();
if (input_complete)
return SUCCESS;
c = next_char ();
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 (nl, 0) == FAILURE)
goto nml_err_ret;
return SUCCESS;
nml_err_ret:
return FAILURE;
}
void
namelist_read (void)
{
char c;
namelist_mode = 1;
input_complete = 0;
if (setjmp (g.eof_jump))
{
generate_error (ERROR_END, NULL);
return;
}
find_nml_name:
switch (c = next_char ())
{
case '$':
case '&':
break;
case '=':
c = next_char ();
if (c == '?')
nml_query ('=');
else
unget_char (c);
goto find_nml_name;
case '?':
nml_query ('?');
default:
goto find_nml_name;
}
nml_match_name (ioparm.namelist_name, ioparm.namelist_name_len);
if (nml_read_error)
goto find_nml_name;
while (!input_complete)
{
if (nml_get_obj_data () == FAILURE)
{
if (current_unit->unit_number != options.stdin_unit)
goto nml_err_ret;
st_printf ("%s\n", nml_err_msg);
flush (find_unit (options.stderr_unit)->s);
}
}
return;
nml_err_ret:
generate_error (ERROR_READ_VALUE , nml_err_msg);
return;
}