From bf8ee9e4eed6ba1a6d77b4cf168df480e1f954da Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Fri, 22 Jan 2021 17:11:06 +0000 Subject: [PATCH] Fortran: Fix for class functions as associated target [PR98565]. 2021-01-22 Paul Thomas gcc/fortran PR fortran/98565 * trans-intrinsic.c (gfc_conv_associated): Do not add a _data component for scalar class function targets. Instead, fix the function result and access the _data from that. gcc/testsuite/ PR fortran/98565 * gfortran.dg/associated_target_7.f90 : New test. --- gcc/fortran/trans-intrinsic.c | 8 +- .../gfortran.dg/associated_target_7.f90 | 87 +++++++++++++++++++ 2 files changed, 94 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/associated_target_7.f90 diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 0e7c60a906b..5c9258c65c3 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -9002,7 +9002,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) else { /* An optional target. */ - if (arg2->expr->ts.type == BT_CLASS) + if (arg2->expr->ts.type == BT_CLASS + && arg2->expr->expr_type != EXPR_FUNCTION) gfc_add_data_component (arg2->expr); if (scalar) @@ -9023,6 +9024,11 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) && arg2->expr->symtree->n.sym->attr.dummy) arg2se.expr = build_fold_indirect_ref_loc (input_location, arg2se.expr); + if (arg2->expr->ts.type == BT_CLASS) + { + arg2se.expr = gfc_evaluate_now (arg2se.expr, &arg2se.pre); + arg2se.expr = gfc_class_data_get (arg2se.expr); + } gfc_add_block_to_block (&se->pre, &arg1se.pre); gfc_add_block_to_block (&se->post, &arg1se.post); gfc_add_block_to_block (&se->pre, &arg2se.pre); diff --git a/gcc/testsuite/gfortran.dg/associated_target_7.f90 b/gcc/testsuite/gfortran.dg/associated_target_7.f90 new file mode 100644 index 00000000000..97f93b3c742 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associated_target_7.f90 @@ -0,0 +1,87 @@ +! { dg-do run } +! +! associated_target_7.f90: Test the fix for PR98565. +! +! Contributed by Yves Secretan +! +MODULE PS_SN0N_M + + IMPLICIT NONE + PRIVATE + + TYPE, PUBLIC :: DT_GRID_T + INTEGER :: NNT + CONTAINS + ! PASS + END TYPE DT_GRID_T + + TYPE, PUBLIC :: LM_ELEM_T + CLASS(DT_GRID_T), POINTER :: PGRID + CONTAINS + PROCEDURE, PUBLIC :: REQPGRID => LM_ELEM_REGPGRID + END TYPE LM_ELEM_T + + TYPE, PUBLIC :: PS_SN0N_T + CLASS(DT_GRID_T), POINTER :: PGRID + + CONTAINS + PROCEDURE, PUBLIC :: ASGOELE => PS_SN0N_ASGOELE + END TYPE PS_SN0N_T + + +CONTAINS + !------------------------------------------------------------------------ + !------------------------------------------------------------------------ + FUNCTION LM_ELEM_REGPGRID(SELF) RESULT(PGRID) + CLASS(DT_GRID_T), POINTER :: PGRID + CLASS(LM_ELEM_T), INTENT(IN) :: SELF + PGRID => SELF%PGRID + RETURN + END FUNCTION LM_ELEM_REGPGRID + + !------------------------------------------------------------------------ + !------------------------------------------------------------------------ + FUNCTION PS_SN0N_ASGOELE(SELF, OELE) RESULT(ERMSG) + + INTEGER :: ERMSG + CLASS(PS_SN0N_T), INTENT(IN) :: SELF + CLASS(LM_ELEM_T), INTENT(IN) :: OELE + + !CLASS(DT_GRID_T), POINTER :: PGRID + LOGICAL :: ISOK + !------------------------------------------------------------------------ + + ! ASSOCIATED with temp variable compiles + !PGRID => OELE%REQPGRID() + !ISOK = ASSOCIATED(SELF%PGRID, PGRID) + + ! ASSOCIATE without temp variable crashes with ICE + ISOK = ASSOCIATED(SELF%PGRID, OELE%REQPGRID()) + ERMSG = 0 + IF (ISOK) ERMSG = 1 + + RETURN + END FUNCTION PS_SN0N_ASGOELE + +END MODULE PS_SN0N_M + + + USE PS_SN0N_M + CLASS(PS_SN0N_T), ALLOCATABLE :: SELF + CLASS(LM_ELEM_T), ALLOCATABLE :: OELE + TYPE (DT_GRID_T), TARGET :: GRID1 = DT_GRID_T (42) + TYPE (DT_GRID_T), TARGET :: GRID2 = DT_GRID_T (84) + + ALLOCATE (PS_SN0N_T :: SELF) + ALLOCATE (LM_ELEM_T :: OELE) + SELF%PGRID => GRID1 + + OELE%PGRID => NULL () + IF (SELF%ASGOELE (OELE) .NE. 0) STOP 1 + + OELE%PGRID => GRID2 + IF (SELF%ASGOELE (OELE) .NE. 0) STOP 2 + + OELE%PGRID => GRID1 + IF (SELF%ASGOELE (OELE) .NE. 1) STOP 3 +END -- 2.30.2