OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR libfortran/33672 (Additional runtime checks needed for namelist reads) 

2007-10-14  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libfortran/33672
	* io/list_read.c (nml_parse_qualifier): Add character specific error
	messages.  Check for proper form of sub-string qualifiers.  Return the
	parsed_rank flag indicating a non-zero rank qualifier.
	(nml_get_obj_data):  Count the instances of non-zero rank qualifiers.
	Issue an error if more that one non-zero rank qualifier is found.

From-SVN: r129309
This commit is contained in:
Jerry DeLisle 2007-10-15 01:33:16 +00:00
parent 422e566461
commit 45dfbe77d2
2 changed files with 83 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
libgfortran/ChangeLog
View File

@ -1,3 +1,12 @@
2007-10-14 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libfortran/33672
* io/list_read.c (nml_parse_qualifier): Add character specific error
messages. Check for proper form of sub-string qualifiers. Return the
parsed_rank flag indicating a non-zero rank qualifier.
(nml_get_obj_data): Count the instances of non-zero rank qualifiers.
Issue an error if more that one non-zero rank qualifier is found.
2007-10-04 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libfortran/33253

96
libgfortran/io/list_read.c
View File

@ -1713,18 +1713,27 @@ calls:
static try
nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
array_loop_spec *ls, int rank, char *parse_err_msg)
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;
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);
@ -1770,8 +1779,10 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
if ((c==',' && dim == rank -1)
|| (c==')' && dim < rank -1))
{
sprintf (parse_err_msg,
"Bad number of index fields");
if (is_char)
sprintf (parse_err_msg, "Bad substring qualifier");
else
sprintf (parse_err_msg, "Bad number of index fields");
goto err_ret;
}
break;
@ -1786,21 +1797,38 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
break;
default:
sprintf (parse_err_msg, "Bad character in index");
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)
{
sprintf (parse_err_msg, "Null index field");
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))
{
sprintf(parse_err_msg, "Bad index triplet");
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;
}
@ -1816,7 +1844,10 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
/* Now read the index. */
if (convert_integer (dtp, sizeof(ssize_t), neg))
{
sprintf (parse_err_msg, "Bad integer in index");
if (is_char)
sprintf (parse_err_msg, "Bad integer substring qualifier");
else
sprintf (parse_err_msg, "Bad integer in index");
goto err_ret;
}
break;
@ -1848,6 +1879,11 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
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;
}
}
@ -1858,9 +1894,13 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
|| (ls[dim].end > (ssize_t)ad[dim].ubound)
|| (ls[dim].end < (ssize_t)ad[dim].lbound))
{
sprintf (parse_err_msg, "Index %d out of range", dim + 1);
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))
{
@ -1995,7 +2035,6 @@ nml_query (st_parameter_dt *dtp, char c)
else
{
/* "&namelist_name\n" */
len = dtp->namelist_name_len;
@ -2015,7 +2054,6 @@ nml_query (st_parameter_dt *dtp, char c)
#endif
for (nl = dtp->u.p.ionml; nl; nl = nl->next)
{
/* " var_name\n" */
len = strlen (nl->var_name);
@ -2081,7 +2119,6 @@ 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;
@ -2103,7 +2140,6 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
len = nl->len;
switch (nl->type)
{
case GFC_DTYPE_INTEGER:
case GFC_DTYPE_LOGICAL:
dlen = len;
@ -2127,7 +2163,6 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
do
{
/* Update the pointer to the data, using the current index vector */
pdata = (void*)(nl->mem_pos + offset);
@ -2333,10 +2368,11 @@ nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
namelist_info * nl;
namelist_info * first_nl = NULL;
namelist_info * root_nl = NULL;
int dim;
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. */
@ -2388,6 +2424,7 @@ nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
nml_untouch_nodes (dtp);
component_flag = 0;
non_zero_rank_count = 0;
/* Get the object name - should '!' and '\n' be permitted separators? */
@ -2456,16 +2493,23 @@ get_name:
if (c == '(' && nl->var_rank)
{
parsed_rank = 0;
if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
parse_err_msg) == FAILURE)
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
@ -2473,7 +2517,6 @@ get_name:
if (c == '%')
{
if (nl->type != GFC_DTYPE_DERIVED)
{
sprintf (nml_err_msg, "Attempt to get derived component for %s",
@ -2488,7 +2531,6 @@ get_name:
component_flag = 1;
c = next_char (dtp);
goto get_name;
}
/* Parse a character qualifier, if present. chigh = 0 is a default
@ -2502,7 +2544,8 @@ get_name:
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)
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);
@ -2515,8 +2558,8 @@ get_name:
if (ind[0].step != 1)
{
sprintf (nml_err_msg,
"Bad step in substring for namelist object %s",
nl->var_name);
"Step not allowed in substring qualifier"
" for namelist object %s", nl->var_name);
goto nml_err_ret;
}
@ -2533,7 +2576,7 @@ get_name:
if (component_flag)
nl = first_nl;
/*make sure no extraneous qualifiers are there.*/
/* Make sure no extraneous qualifiers are there. */
if (c == '(')
{
@ -2542,6 +2585,15 @@ get_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*/