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

re PR fortran/91729 (ICE in gfc_match_select_rank, at fortran/match.c:6586)

Browse Source 
2019-09-23  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/91729
	* match.c (gfc_match_select_rank): Initialise 'as' to NULL.
	Check for a symtree in the selector expression before trying to
	assign a value to 'as'. Revert to gfc_error and go to cleanup
	after setting a MATCH_ERROR.

2019-09-23  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/91729
	* gfortran.dg/select_rank_2.f90 : Add two more errors in foo2.
	* gfortran.dg/select_rank_3.f90 : New test.

From-SVN: r276051
This commit is contained in:
Paul Thomas 2019-09-23 09:19:10 +00:00
parent b7bb3d3580
commit 158ab20432
5 changed files with 62 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View File

@ -1,3 +1,11 @@
2019-09-23 Paul Thomas <pault@gcc.gnu.org>
PR fortran/91729
* match.c (gfc_match_select_rank): Initialise 'as' to NULL.
Check for a symtree in the selector expression before trying to
assign a value to 'as'. Revert to gfc_error and go to cleanup
after setting a MATCH_ERROR.
2019-09-20 Tobias Burnus <tobias@codesourcery.com>
PR fortran/78260

34
gcc/fortran/match.c
View File

@ -6510,7 +6510,7 @@ gfc_match_select_rank (void)
char name[GFC_MAX_SYMBOL_LEN];
gfc_symbol *sym, *sym2;
gfc_namespace *ns = gfc_current_ns;
gfc_array_spec *as;
gfc_array_spec *as = NULL;
m = gfc_match_label ();
if (m == MATCH_ERROR)
@ -6538,13 +6538,21 @@ gfc_match_select_rank (void)
}
sym = expr1->symtree->n.sym;
sym2 = expr2->symtree->n.sym;
as = sym2->ts.type == BT_CLASS ? CLASS_DATA (sym2)->as : sym2->as;
if (expr2->symtree)
{
sym2 = expr2->symtree->n.sym;
as = sym2->ts.type == BT_CLASS ? CLASS_DATA (sym2)->as : sym2->as;
}
if (expr2->expr_type != EXPR_VARIABLE
|| !(as && as->type == AS_ASSUMED_RANK))
gfc_error_now ("The SELECT RANK selector at %C must be an assumed "
"rank variable");
{
gfc_error ("The SELECT RANK selector at %C must be an assumed "
"rank variable");
m = MATCH_ERROR;
goto cleanup;
}
if (expr2->ts.type == BT_CLASS)
{
@ -6583,12 +6591,20 @@ gfc_match_select_rank (void)
return m;
}
sym = expr1->symtree->n.sym;
as = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as;
if (expr1->symtree)
{
sym = expr1->symtree->n.sym;
as = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as;
}
if (expr1->expr_type != EXPR_VARIABLE
|| !(as && as->type == AS_ASSUMED_RANK))
gfc_error_now ("The SELECT RANK selector at %C must be an assumed "
"rank variable");
{
gfc_error("The SELECT RANK selector at %C must be an assumed "
"rank variable");
m = MATCH_ERROR;
goto cleanup;
}
}
m = gfc_match (" )%t");

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2019-09-23 Paul Thomas <pault@gcc.gnu.org>
PR fortran/91729
* gfortran.dg/select_rank_2.f90 : Add two more errors in foo2.
* gfortran.dg/select_rank_3.f90 : New test.
2019-09-23 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
* gnat.dg/system_info1.adb: Sort dg-do target list.

4
gcc/testsuite/gfortran.dg/select_rank_2.f90
View File

@ -8,9 +8,9 @@ subroutine foo1 (arg)
integer :: i
integer, dimension(3) :: arg
select rank (arg) ! { dg-error "must be an assumed rank variable" }
rank (3)
rank (3) ! { dg-error "Unexpected RANK statement" }
print *, arg
end select
end select ! { dg-error "Expecting END SUBROUTINE" }
end
subroutine foo2 (arg)

21
gcc/testsuite/gfortran.dg/select_rank_3.f90 Normal file
View File

@ -0,0 +1,21 @@
! { dg-do compile }
!
! Test the fix for PR91729
!
! Contributed by Gerhardt Steinmetz <gscfq@t-online.de>
!
subroutine s(x)
integer :: x(..)
select rank (-x) ! { dg-error "must be an assumed rank" }
rank (1) ! { dg-error "Unexpected RANK statement" }
print *, x ! { dg-error "may only be used as actual argument" }
end select ! { dg-error "Expecting END SUBROUTINE" }
end
subroutine t(x)
integer :: x(..)
select rank (z => -x) ! { dg-error "must be an assumed rank" }
rank (1) ! { dg-error "Unexpected RANK statement" }
print *, z
end select ! { dg-error "Expecting END SUBROUTINE" }
end