[gcc r14-6620] Fortran: Fix problems with class array function selectors [PR112834]
Paul Thomas
pault@gcc.gnu.org
Sat Dec 16 13:26:59 GMT 2023
https://gcc.gnu.org/g:5ae6f524f5d4ee2ab79ba797fa4901daf90afb25
commit r14-6620-g5ae6f524f5d4ee2ab79ba797fa4901daf90afb25
Author: Paul Thomas <pault@gcc.gnu.org>
Date: Sat Dec 16 13:26:47 2023 +0000
Fortran: Fix problems with class array function selectors [PR112834]
2023-12-16 Paul Thomas <pault@gcc.gnu.org>
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:
---
gcc/fortran/match.cc | 20 +++++++++--
gcc/fortran/parse.cc | 12 ++++++-
gcc/fortran/resolve.cc | 2 +-
gcc/fortran/trans-stmt.cc | 8 ++++-
gcc/testsuite/gfortran.dg/associate_63.f90 | 57 ++++++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/pr111853.f90 | 16 +++++++++
6 files changed, 109 insertions(+), 6 deletions(-)
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 9e3571d3dbe..df9adb359a0 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 9b4c39274be..042a6ad5e59 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 4fe0e7202e5..2925f7da28c 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 5530e893a62..517b7aaa898 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 00000000000..67c7559fd11
--- /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 <pault@gcc.gnu.org>
+!
+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 00000000000..8f0b2666497
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr111853.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+!
+! A null dereference fixed
+!
+! Contributed by Daniel Otero <canu7@yahoo.es>
+!
+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
More information about the Gcc-cvs
mailing list