Dear All, This patch was rescued from my ill-fated and long winded attempt to provide a fix-up for function selector references, where the function is parsed after the procedure containing the associate/select type construct (PRs 89645 and 99065). The fix-ups broke down completely once these constructs were enclosed by another associate construct, where the selector is a derived type or class function. My inclination now is to introduce two pass parsing for contained procedures.
Returning to PR112834, the patch is simple enough and is well described by the change logs. PR111853 was fixed as a side effect of the bigger patch. Steve Kargl had also posted the same fix on the PR. Regression tests - OK for trunk and 13-branch? Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 9e3571d3dbe..cecd2940dcf 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,19 @@ 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 abd3a424f38..c1fa751d0e8 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5131,7 +5131,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;
@@ -5195,6 +5195,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 166b702cd9a..92678b816a1 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 50b71e67234..b70c079fc55 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. */
! { 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 <pa...@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
! { dg-do compile }
!
! A null dereference fixed
!
! Contributed by Daniel Otero <ca...@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
