From: Paul Thomas Date: Mon, 23 Sep 2019 09:19:10 +0000 (+0000) Subject: re PR fortran/91729 (ICE in gfc_match_select_rank, at fortran/match.c:6586) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=158ab204321cfa5fe5466faa5a12b3c38c45125a;p=gcc.git re PR fortran/91729 (ICE in gfc_match_select_rank, at fortran/match.c:6586) 2019-09-23 Paul Thomas 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 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 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7435a22f902..cd1ca756d0f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2019-09-23 Paul Thomas + + 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 PR fortran/78260 diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 56d9af04777..9b9dbf1f96f 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -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"); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 815aee0ad52..cd7ee8d3230 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2019-09-23 Paul Thomas + + 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 * gnat.dg/system_info1.adb: Sort dg-do target list. diff --git a/gcc/testsuite/gfortran.dg/select_rank_2.f90 b/gcc/testsuite/gfortran.dg/select_rank_2.f90 index 2415fdff90c..184027f6b6d 100644 --- a/gcc/testsuite/gfortran.dg/select_rank_2.f90 +++ b/gcc/testsuite/gfortran.dg/select_rank_2.f90 @@ -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) diff --git a/gcc/testsuite/gfortran.dg/select_rank_3.f90 b/gcc/testsuite/gfortran.dg/select_rank_3.f90 new file mode 100644 index 00000000000..35cd8cd9a0e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_rank_3.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! Test the fix for PR91729 +! +! Contributed by Gerhardt Steinmetz +! +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