Fortran: Fix regressions with intent(out) class[PR115070, PR115348].

2024-10-27  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/115070
	PR fortran/115348
	* trans-expr.cc (gfc_trans_class_init_assign): If all the
	components of the default initializer are null for a scalar,
	build an empty statement to prevent prior declarations from
	disappearing.

gcc/testsuite/
	PR fortran/115070
	* gfortran.dg/pr115070.f90: New test.

	PR fortran/115348
	* gfortran.dg/pr115348.f90: New test.

3 files changed, 80 insertions, 12 deletions

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 663d762..ff8cde9 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1791,10 +1791,12 @@ gfc_trans_class_init_assign (gfc_code *code)
 {
   stmtblock_t block;
   tree tmp;
+  bool cmp_flag = true;
   gfc_se dst,src,memsz;
   gfc_expr *lhs, *rhs, *sz;
   gfc_component *cmp;
   gfc_symbol *sym;
+  gfc_ref *ref;
 
   gfc_start_block (&block);
 
@@ -1812,24 +1814,25 @@ gfc_trans_class_init_assign (gfc_code *code)
   rhs->rank = 0;
 
   /* Check def_init for initializers.  If this is an INTENT(OUT) dummy with all
-     default initializer components NULL, return NULL_TREE and use the passed
-     value as required by F2018(8.5.10).  */
+     default initializer components NULL, use the passed value even though
+     F2018(8.5.10) asserts that it should considered to be undefined. This is
+     needed for consistency with other brands.  */
   sym = code->expr1->expr_type == EXPR_VARIABLE ? code->expr1->symtree->n.sym
 						: NULL;
   if (code->op != EXEC_ALLOCATE
       && sym && sym->attr.dummy
       && sym->attr.intent == INTENT_OUT)
     {
-      if (!lhs->ref && lhs->symtree->n.sym->attr.dummy)
+      ref = rhs->ref;
+      while (ref && ref->next)
+	ref = ref->next;
+      cmp = ref->u.c.component->ts.u.derived->components;
+      for (; cmp; cmp = cmp->next)
 	{
-	  cmp = rhs->ref->next->u.c.component->ts.u.derived->components;
-	  for (; cmp; cmp = cmp->next)
-	    {
-	      if (cmp->initializer)
-		break;
-	      else if (!cmp->next)
-		return NULL_TREE;
-	    }
+	  if (cmp->initializer)
+	    break;
+	  else if (!cmp->next)
+	    cmp_flag = false;
 	}
     }
 
@@ -1843,7 +1846,7 @@ gfc_trans_class_init_assign (gfc_code *code)
       gfc_add_full_array_ref (lhs, tmparr);
       tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
     }
-  else
+  else if (cmp_flag)
     {
       /* Scalar initialization needs the _data component.  */
       gfc_add_data_component (lhs);
@@ -1873,6 +1876,8 @@ gfc_trans_class_init_assign (gfc_code *code)
 			    tmp, build_empty_stmt (input_location));
 	}
     }
+  else
+    tmp = build_empty_stmt (input_location);
 
   if (code->expr1->symtree->n.sym->attr.dummy
       && (code->expr1->symtree->n.sym->attr.optional
diff --git a/gcc/testsuite/gfortran.dg/pr115070.f90 b/gcc/testsuite/gfortran.dg/pr115070.f90
new file mode 100644
index 0000000..9378f77
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr115070.f90
@@ -0,0 +1,28 @@
+! { dg-do compile }
+!
+! Test the fix for PR115070
+!
+! Contributed by Sebastien Bardeau  <bardeau@iram.fr>
+!
+module my_mod
+  type my_type
+    integer :: a
+  contains
+    final :: myfinal
+  end type my_type
+contains
+  subroutine my_sub(obs)
+    use ieee_arithmetic
+    class(my_type), intent(out) :: obs
+  end subroutine my_sub
+  subroutine myfinal (arg)
+    type (my_type) :: arg
+    print *, arg%a
+  end
+end module my_mod
+
+  use my_mod
+  type (my_type) :: z
+  z%a = 42
+  call my_sub (z)
+end
diff --git a/gcc/testsuite/gfortran.dg/pr115348.f90 b/gcc/testsuite/gfortran.dg/pr115348.f90
new file mode 100644
index 0000000..bc644b2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr115348.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! { dg-options "-fcheck=recursion" }
+!
+! Test the fix for pr115348.
+!
+! Contributed by Maxime van den Bossche  <maxime.vandenbossche@kuleuven.be>
+!
+module mymodule
+    implicit none
+
+    type mytype
+        integer :: mynumber
+        contains
+        procedure :: myroutine
+    end type mytype
+
+    contains
+
+    subroutine myroutine(self)
+        class(mytype), intent(out) :: self
+
+        self%mynumber = 1
+    end subroutine myroutine
+end module mymodule
+
+
+program myprogram
+    use mymodule, only: mytype
+    implicit none
+
+    type(mytype) :: myobject
+
+    call myobject%myroutine()
+    print *, myobject%mynumber
+end program myprogram