Fortran: Fix for class functions as associated target [PR98565].

2021-01-22  Paul Thomas  <pault@gcc.gnu.org>

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.

2 files changed, 94 insertions, 1 deletions

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 0e7c60a..5c9258c 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 0000000..97f93b3
--- /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  <yves.secretan@ete.inrs.ca>
+!
+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