From: Paul Thomas Date: Fri, 27 Oct 2023 08:33:38 +0000 (+0100) Subject: Fortran: Fix some problems with SELECT TYPE selectors [PR104625]. X-Git-Tag: basepoints/gcc-15~5173 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=b038e202210eb3e982c2ec802438edd523b47a02;p=thirdparty%2Fgcc.git Fortran: Fix some problems with SELECT TYPE selectors [PR104625]. 2023-10-27 Paul Thomas gcc/fortran PR fortran/104625 * expr.cc (gfc_check_vardef_context): Check that the target does have a vector index before emitting the specific error. * match.cc (copy_ts_from_selector_to_associate): Ensure that class valued operator expressions set the selector rank and use the rank to provide the associate variable with an appropriate array spec. * resolve.cc (resolve_operator): Reduce stacked parentheses to a single pair. (fixup_array_ref): Extract selector symbol from parentheses. gcc/testsuite/ PR fortran/104625 * gfortran.dg/pr104625.f90: New test. * gfortran.dg/associate_55.f90: Change error check. --- diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index 663fe63dea68..c668baeef8c3 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -6474,7 +6474,8 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, { if (context) { - if (assoc->target->expr_type == EXPR_VARIABLE) + if (assoc->target->expr_type == EXPR_VARIABLE + && gfc_has_vector_index (assoc->target)) gfc_error ("%qs at %L associated to vector-indexed target" " cannot be used in a variable definition" " context (%s)", diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 148a86bb436d..f848e52be4c1 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -6348,12 +6348,13 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector) else if (selector->ts.type == BT_CLASS && CLASS_DATA (selector) && CLASS_DATA (selector)->as - && ref && ref->type == REF_ARRAY) + && ((ref && ref->type == REF_ARRAY) + || selector->expr_type == EXPR_OP)) { /* Ensure that the array reference type is set. We cannot use gfc_resolve_expr at this point, so the usable parts of resolve.cc(resolve_array_ref) are employed to do it. */ - if (ref->u.ar.type == AR_UNKNOWN) + if (ref && ref->u.ar.type == AR_UNKNOWN) { ref->u.ar.type = AR_ELEMENT; for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) @@ -6367,7 +6368,7 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector) } } - if (ref->u.ar.type == AR_FULL) + if (!ref || ref->u.ar.type == AR_FULL) selector->rank = CLASS_DATA (selector)->as->rank; else if (ref->u.ar.type == AR_SECTION) selector->rank = ref->u.ar.dimen; @@ -6379,12 +6380,15 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector) if (rank) { - for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) - if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT - || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN - && ref->u.ar.end[i] == NULL - && ref->u.ar.stride[i] == NULL)) - rank--; + if (ref) + { + for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) + if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT + || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN + && ref->u.ar.end[i] == NULL + && ref->u.ar.stride[i] == NULL)) + rank--; + } if (rank) { diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 861f69ac20fd..9f4dc0726457 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -4138,6 +4138,16 @@ resolve_operator (gfc_expr *e) bool dual_locus_error; bool t = true; + /* Reduce stacked parentheses to single pair */ + while (e->expr_type == EXPR_OP + && e->value.op.op == INTRINSIC_PARENTHESES + && e->value.op.op1->expr_type == EXPR_OP + && e->value.op.op1->value.op.op == INTRINSIC_PARENTHESES) + { + gfc_expr *tmp = gfc_copy_expr (e->value.op.op1); + gfc_replace_expr (e, tmp); + } + /* Resolve all subnodes-- give them types. */ switch (e->value.op.op) @@ -9451,8 +9461,25 @@ fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2, { gfc_ref *nref = (*expr1)->ref; gfc_symbol *sym1 = (*expr1)->symtree->n.sym; - gfc_symbol *sym2 = expr2 ? expr2->symtree->n.sym : NULL; + gfc_symbol *sym2; + gfc_expr *selector = gfc_copy_expr (expr2); + (*expr1)->rank = rank; + if (selector) + { + gfc_resolve_expr (selector); + if (selector->expr_type == EXPR_OP + && selector->value.op.op == INTRINSIC_PARENTHESES) + sym2 = selector->value.op.op1->symtree->n.sym; + else if (selector->expr_type == EXPR_VARIABLE + || selector->expr_type == EXPR_FUNCTION) + sym2 = selector->symtree->n.sym; + else + gcc_unreachable (); + } + else + sym2 = NULL; + if (sym1->ts.type == BT_CLASS) { if ((*expr1)->ts.type != BT_CLASS) diff --git a/gcc/testsuite/gfortran.dg/associate_55.f90 b/gcc/testsuite/gfortran.dg/associate_55.f90 index 2b9e8c727f90..245dbfc72182 100644 --- a/gcc/testsuite/gfortran.dg/associate_55.f90 +++ b/gcc/testsuite/gfortran.dg/associate_55.f90 @@ -26,7 +26,7 @@ contains class(test_t), intent(inout) :: obj integer, intent(in) :: a associate (state => obj%state(TEST_STATES)) ! { dg-error "no IMPLICIT type" } - state = a ! { dg-error "vector-indexed target" } + state = a ! { dg-error "cannot be used in a variable definition context" } ! state(TEST_STATE) = a end associate end subroutine test_alter_state2 diff --git a/gcc/testsuite/gfortran.dg/pr104625.f90 b/gcc/testsuite/gfortran.dg/pr104625.f90 new file mode 100644 index 000000000000..84e7a9a1573e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr104625.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! Check the fix for PR104625 in which the selectors in parentheses used +! to cause ICEs. The "Unclassifiable statement" errors were uncovered once +! the ICEs were fixed. +! +! Contributed by Gerhard Steinmetz +! +program p + implicit none + type t + integer :: a + end type +contains + subroutine s(x) +! class(t) :: x ! Was OK + class(t) :: x(:) ! Used to ICE in combination with below + class(t), allocatable :: r(:) + + select type (y => x) ! OK + type is (t) + y%a = 99 + end select + select type (z => (x)) ! Used to ICE + type is (t) + r = z(1) ! Used to give "Unclassifiable statement" error + z%a = 99 ! { dg-error "cannot be used in a variable definition" } + end select + select type (u => ((x))) ! Used to ICE + type is (t) + r = u(1) ! Used to give "Unclassifiable statement" error + u%a = 99 ! { dg-error "cannot be used in a variable definition" } + end select + end +end