This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[patch, libfortran] PR33672 Additional runtime checks needed for namelist reads
- From: Jerry DeLisle <jvdelisle at verizon dot net>
- To: Fortran List <fortran at gcc dot gnu dot org>
- Cc: gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Mon, 08 Oct 2007 06:01:24 -0700
- Subject: [patch, libfortran] PR33672 Additional runtime checks needed for namelist reads
:ADDPATCH fortran:
Hi all,
The attached patch provides additional run-time checks to namelist reading to
assure that namelist file contents comply with the F95 standard.
Since gfortran was permitting bogus qualifiers, this could affect users who may
have been doing things incorrectly. However, gfortran does WRITE namelists
correctly so files generated using gfortran to write them will work fine.
New test case provided.
Regression tested on x86-64.
OK to commit.
Regards,
Jerry
2007-10-07 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.
Index: list_read.c
===================================================================
--- list_read.c (revision 129029)
+++ list_read.c (working copy)
@@ -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 *dt
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 *dt
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 *dt
/* 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;
@@ -1847,7 +1878,12 @@ nml_parse_qualifier (st_parameter_dt *dt
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;
}
}
@@ -1858,9 +1894,13 @@ nml_parse_qualifier (st_parameter_dt *dt
|| (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))
{
@@ -2333,10 +2373,11 @@ nml_get_obj_data (st_parameter_dt *dtp,
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 +2429,7 @@ nml_get_obj_data (st_parameter_dt *dtp,
nml_untouch_nodes (dtp);
component_flag = 0;
+ non_zero_rank_count = 0;
/* Get the object name - should '!' and '\n' be permitted separators? */
@@ -2454,18 +2496,26 @@ get_name:
/* 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) == 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
@@ -2502,7 +2552,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 +2566,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 +2584,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 +2593,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*/
@@ -2585,7 +2645,7 @@ namelist_read (st_parameter_dt *dtp)
{
char c;
jmp_buf eof_jump;
- char nml_err_msg[100];
+ char nml_err_msg[200];
/* 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. */
! { dg-do run }
! PR33672 Additional runtime checks needed for namelist reads
! Submitted by Jerry DeLisle <jvdelisle@gcc.gnu.org>
module global
type :: mt
character(len=2) :: ch(2) = (/"aa","bb"/)
end type mt
type :: bt
integer :: i(2) = (/1,2/)
type(mt) :: m(2)
end type bt
end module global
program namelist_40
use global
type(bt) :: x(2)
character(40) :: teststring
namelist /mynml/ x
teststring = " x(2)%m%ch(:)(2:2) = 'z','z',"
call writenml (teststring)
teststring = " x(2)%m(2)%ch(:)(2) = 'z','z',"
call writenml (teststring)
teststring = " x(2)%m(2)%ch(:)(:3) = 'z','z',"
call writenml (teststring)
teststring = " x(2)%m(2)%ch(1:2)(k:) = 'z','z',"
call writenml (teststring)
contains
subroutine writenml (astring)
character(40), intent(in) :: astring
character(300) :: errmessage
integer :: ierror
open (10, status="scratch", delim='apostrophe')
write (10, '(A)') "&MYNML"
write (10, '(A)') astring
write (10, '(A)') "/"
rewind (10)
read (10, nml = mynml, iostat=ierror, iomsg=errmessage)
if (ierror == 0) call abort
print '(a)', trim(errmessage)
close (10)
end subroutine writenml
end program namelist_40
! { dg-output "Multiple sub-objects with non-zero rank in namelist object x(\n|\r\n|\r)" }
! { dg-output "Missing colon in substring qualifier for namelist variable x%m%ch(\n|\r\n|\r)" }
! { dg-output "Substring out of range for namelist variable x%m%ch(\n|\r\n|\r)" }
! { dg-output "Bad character in substring qualifier for namelist variable x%m%ch(\n|\r\n|\r)" }
! { dg-final { cleanup-modules "global" } }