From: Paul Thomas Date: Sat, 16 Dec 2023 13:26:47 +0000 (+0000) Subject: Fortran: Fix problems with class array function selectors [PR112834] X-Git-Tag: basepoints/gcc-15~3519 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=5ae6f524f5d4ee2ab79ba797fa4901daf90afb25;p=thirdparty%2Fgcc.git Fortran: Fix problems with class array function selectors [PR112834] 2023-12-16 Paul Thomas gcc/fortran PR fortran/112834 * match.cc (build_associate_name): Fix whitespace issues. (select_type_set_tmp): If the selector is of unknown type, go the SELECT TYPE selector to see if this is a function and, if the result is available, use its typespec. * parse.cc (parse_associate): Again, use the function result if the type of the selector result is unknown. * trans-stmt.cc (trans_associate_var): The expression has to be of type class, for class_target to be true. Convert and fix class functions. Pass the fixed expression. PR fortran/111853 * resolve.cc (gfc_expression_rank): Avoid null dereference. gcc/testsuite/ PR fortran/112834 * gfortran.dg/associate_63.f90 : New test. PR fortran/111853 * gfortran.dg/pr111853.f90 : New test. --- diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 9e3571d3dbe2..df9adb359a00 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -6436,9 +6436,9 @@ build_associate_name (const char *name, gfc_expr **e1, gfc_expr **e2) sym = expr1->symtree->n.sym; if (expr2->ts.type == BT_UNKNOWN) - sym->attr.untyped = 1; + sym->attr.untyped = 1; else - copy_ts_from_selector_to_associate (expr1, expr2); + copy_ts_from_selector_to_associate (expr1, expr2); sym->attr.flavor = FL_VARIABLE; sym->attr.referenced = 1; @@ -6527,6 +6527,7 @@ select_type_set_tmp (gfc_typespec *ts) gfc_symtree *tmp = NULL; gfc_symbol *selector = select_type_stack->selector; gfc_symbol *sym; + gfc_expr *expr2; if (!ts) { @@ -6550,7 +6551,20 @@ select_type_set_tmp (gfc_typespec *ts) sym = tmp->n.sym; gfc_add_type (sym, ts, NULL); - if (selector->ts.type == BT_CLASS && selector->attr.class_ok + /* If the SELECT TYPE selector is a function we might be able to obtain + a typespec from the result. Since the function might not have been + parsed yet we have to check that there is indeed a result symbol. */ + if (selector->ts.type == BT_UNKNOWN + && gfc_state_stack->construct + + && (expr2 = gfc_state_stack->construct->expr2) + && expr2->expr_type == EXPR_FUNCTION + && expr2->symtree + && expr2->symtree->n.sym && expr2->symtree->n.sym->result) + selector->ts = expr2->symtree->n.sym->result->ts; + + if (selector->ts.type == BT_CLASS + && selector->attr.class_ok && selector->ts.u.derived && CLASS_DATA (selector)) { sym->attr.pointer diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index 9b4c39274bea..042a6ad5e599 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -5136,7 +5136,7 @@ parse_associate (void) gfc_current_ns = my_ns; for (a = new_st.ext.block.assoc; a; a = a->next) { - gfc_symbol* sym; + gfc_symbol *sym, *tsym; gfc_expr *target; int rank; @@ -5200,6 +5200,16 @@ parse_associate (void) sym->ts.type = BT_DERIVED; sym->ts.u.derived = derived; } + else if (target->symtree && (tsym = target->symtree->n.sym)) + { + sym->ts = tsym->result ? tsym->result->ts : tsym->ts; + if (sym->ts.type == BT_CLASS) + { + if (CLASS_DATA (sym)->as) + target->rank = CLASS_DATA (sym)->as->rank; + sym->attr.class_ok = 1; + } + } } rank = target->rank; diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 4fe0e7202e5d..2925f7da28c9 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -5669,7 +5669,7 @@ gfc_expression_rank (gfc_expr *e) if (ref->type != REF_ARRAY) continue; - if (ref->u.ar.type == AR_FULL) + if (ref->u.ar.type == AR_FULL && ref->u.ar.as) { rank = ref->u.ar.as->rank; break; diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index 5530e893a620..517b7aaa898d 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -1746,6 +1746,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) e = sym->assoc->target; class_target = (e->expr_type == EXPR_VARIABLE) + && e->ts.type == BT_CLASS && (gfc_is_class_scalar_expr (e) || gfc_is_class_array_ref (e, NULL)); @@ -2037,7 +2038,12 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) /* Class associate-names come this way because they are unconditionally associate pointers and the symbol is scalar. */ - if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension) + if (sym->ts.type == BT_CLASS && e->expr_type == EXPR_FUNCTION) + { + gfc_conv_expr (&se, e); + se.expr = gfc_evaluate_now (se.expr, &se.pre); + } + else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension) { tree target_expr; /* For a class array we need a descriptor for the selector. */ diff --git a/gcc/testsuite/gfortran.dg/associate_63.f90 b/gcc/testsuite/gfortran.dg/associate_63.f90 new file mode 100644 index 000000000000..67c7559fd117 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_63.f90 @@ -0,0 +1,57 @@ +! { dg-do run } +! +! Test the fix for PR112834 in which class array function selectors caused +! problems for both ASSOCIATE and SELECT_TYPE. +! +! Contributed by Paul Thomas +! +module m + implicit none + type t + integer :: i = 0 + end type t + integer :: i = 0 + type(t), parameter :: test_array (2) = [t(42),t(84)], & + test_scalar = t(99) +end module m +module class_selectors + use m + implicit none + private + public foo2 +contains + function bar3() result(res) + class(t), allocatable :: res(:) + allocate (res, source = test_array) + end + + subroutine foo2() + associate (var1 => bar3()) + if (any (var1%i .ne. test_array%i)) stop 1 + if (var1(2)%i .ne. test_array(2)%i) stop 2 + associate (zzz3 => var1%i) + if (any (zzz3 .ne. test_array%i)) stop 3 + if (zzz3(2) .ne. test_array(2)%i) stop 4 + end associate + select type (x => var1) + type is (t) + if (any (x%i .ne. test_array%i)) stop 5 + if (x(2)%i .ne. test_array(2)%i) stop 6 + class default + stop 7 + end select + end associate + + select type (y => bar3 ()) + type is (t) + if (any (y%i .ne. test_array%i)) stop 8 + if (y(2)%i .ne. test_array(2)%i) stop 9 + class default + stop 10 + end select + end subroutine foo2 +end module class_selectors + + use class_selectors + call foo2 +end diff --git a/gcc/testsuite/gfortran.dg/pr111853.f90 b/gcc/testsuite/gfortran.dg/pr111853.f90 new file mode 100644 index 000000000000..8f0b26664973 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr111853.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! A null dereference fixed +! +! Contributed by Daniel Otero +! +subroutine foo (rvec) + TYPE vec_rect_2D_real_acc + INTEGER :: arr + END TYPE + CLASS(vec_rect_2D_real_acc) rvec + + ASSOCIATE (arr=>rvec%arr) + call bar(arr*arr) + end associate +end