Fortran: Fix wrong code in unlimited polymorphic assignment [PR113363]

2024-05-13  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/113363
	* trans-array.cc (gfc_array_init_size): Use the expr3 dtype so
	that the correct element size is used.
	* trans-expr.cc (gfc_conv_procedure_call): Remove restriction
	that ss and ss->loop be present for the finalization of class
	array function results.
	(trans_class_assignment): Use free and malloc, rather than
	realloc, for character expressions assigned to unlimited poly
	entities.
	* trans-stmt.cc (gfc_trans_allocate): Build a correct rhs for
	the assignment of an unlimited polymorphic 'source'.

gcc/testsuite/
	PR fortran/113363
	* gfortran.dg/pr113363.f90: New test.

(cherry picked from commit 2d0eeb529d400e61197a09c56011be976dd81ef0)

4 files changed, 151 insertions, 14 deletions

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index f38e872..9557cd1 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -5795,6 +5795,11 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
       tmp = gfc_conv_descriptor_dtype (descriptor);
       gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
     }
+  else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
+    {
+      tmp = gfc_conv_descriptor_dtype (descriptor);
+      gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
+    }
   else
     {
       tmp = gfc_conv_descriptor_dtype (descriptor);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6b75c14..657f1cb 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7984,8 +7984,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	 call the finalization function of the temporary. Note that the
 	 nullification of allocatable components needed by the result
 	 is done in gfc_trans_assignment_1.  */
-      if (expr && ((gfc_is_class_array_function (expr)
-		    && se->ss && se->ss->loop)
+      if (expr && (gfc_is_class_array_function (expr)
 		   || gfc_is_alloc_class_scalar_function (expr))
 	  && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
 	  && expr->must_finalize)
@@ -11705,18 +11704,25 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
 
       /* Reallocate if dynamic types are different. */
       gfc_init_block (&re_alloc);
-      tmp = fold_convert (pvoid_type_node, class_han);
-      re = build_call_expr_loc (input_location,
-				builtin_decl_explicit (BUILT_IN_REALLOC), 2,
-				tmp, size);
-      re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
-			    re);
-      tmp = fold_build2_loc (input_location, NE_EXPR,
-			     logical_type_node, rhs_vptr, old_vptr);
-      re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
-			    tmp, re, build_empty_stmt (input_location));
-      gfc_add_expr_to_block (&re_alloc, re);
-
+      if (UNLIMITED_POLY (lhs) && rhs->ts.type == BT_CHARACTER)
+	{
+	  gfc_add_expr_to_block (&re_alloc, gfc_call_free (class_han));
+	  gfc_allocate_using_malloc (&re_alloc, class_han, size, NULL_TREE);
+	}
+      else
+	{
+	  tmp = fold_convert (pvoid_type_node, class_han);
+	  re = build_call_expr_loc (input_location,
+				    builtin_decl_explicit (BUILT_IN_REALLOC),
+				    2, tmp, size);
+	  re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
+				tmp, re);
+	  tmp = fold_build2_loc (input_location, NE_EXPR,
+				 logical_type_node, rhs_vptr, old_vptr);
+	  re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				tmp, re, build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&re_alloc, re);
+	}
       tree realloc_expr = lhs->ts.type == BT_CLASS ?
 					  gfc_finish_block (&re_alloc) :
 					  build_empty_stmt (input_location);
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index caa7b59..11a8a9c 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -7059,6 +7059,46 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
 	  flag_realloc_lhs = 0;
 
+	  /* The handling of code->expr3 above produces a derived type of
+	     type "STAR", whose size defaults to size(void*). In order to
+	     have the right type information for the assignment, we must
+	     reconstruct an unlimited polymorphic rhs.  */
+	  if (UNLIMITED_POLY (code->expr3)
+	      && e3rhs && e3rhs->ts.type == BT_DERIVED
+	      && !strcmp (e3rhs->ts.u.derived->name, "STAR"))
+	    {
+	      gfc_ref *ref;
+	      gcc_assert (TREE_CODE (expr3_vptr) == COMPONENT_REF);
+	      tmp = gfc_create_var (gfc_typenode_for_spec (&code->expr3->ts),
+				    "e3");
+	      gfc_add_modify (&block, tmp,
+			      gfc_get_class_from_expr (expr3_vptr));
+	      rhs->symtree->n.sym->backend_decl = tmp;
+	      rhs->ts = code->expr3->ts;
+	      rhs->symtree->n.sym->ts = rhs->ts;
+	      for (ref = init_expr->ref; ref; ref = ref->next)
+		{
+		  /* Copy over the lhs _data component ref followed by the
+		     full array reference for source expressions with rank.
+		     Otherwise, just copy the _data component ref.  */
+		  if (code->expr3->rank
+		      && ref && ref->next && !ref->next->next)
+		    {
+		      rhs->ref = gfc_copy_ref (ref);
+		      break;
+		    }
+		  else if ((init_expr->rank && !code->expr3->rank
+			    && ref && ref->next && !ref->next->next)
+			   || (ref && !ref->next))
+		    {
+		      rhs->ref = gfc_copy_ref (ref);
+		      gfc_free_ref_list (rhs->ref->next);
+		      rhs->ref->next = NULL;
+		      break;
+		    }
+		}
+	    }
+
 	  /* Set the symbol to be artificial so that the result is not finalized.  */
 	  init_expr->symtree->n.sym->attr.artificial = 1;
 	  tmp = gfc_trans_assignment (init_expr, rhs, true, false, true,
diff --git a/gcc/testsuite/gfortran.dg/pr113363.f90 b/gcc/testsuite/gfortran.dg/pr113363.f90
new file mode 100644
index 0000000..99d4f20
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr113363.f90
@@ -0,0 +1,86 @@
+! { dg-do run }
+! Test the fix for comment 1 in PR113363, which failed as in comments below.
+! Contributed by Harald Anlauf  <anlauf@gcc.gnu.org>
+program p
+  implicit none
+  class(*), allocatable :: x(:), y
+  character(*), parameter :: arr(2) = ["hello ","bye   "], &
+                             sca = "Have a nice day"
+  character(10) :: const
+
+! Bug was detected in polymorphic array function results
+  allocate(x, source = foo ())
+  call check1 (x, arr)              ! Wrong output "6 hello e"
+  deallocate (x)
+  x = foo ()
+  call check1 (x, arr)              ! Wrong output "0  "
+  associate (var => foo ())         ! OK after r14-9489-g3fd46d859cda10
+    call check1 (var, arr)          ! Now OK - outputs: "6 hello bye   "
+  end associate
+
+! Check scalar function results     ! All OK
+  allocate (y, source = bar())
+  call check2 (y, sca)
+  deallocate (y)
+  y = bar ()
+  call check2 (y, sca)
+  deallocate (y)
+  associate (var => bar ())
+    call check2 (var, sca)
+  end associate
+
+! Finally variable expressions...
+  allocate (y, source = x(1))       ! Gave zero length here
+  call check2 (y, "hello")
+  y = x(2)                          ! Segfaulted here
+  call check2 (y, "bye   ")
+  associate (var => x(2))           ! Gave zero length here
+    call check2 (var, "bye   ")
+  end associate
+
+! ...and constant expressions       ! All OK
+  deallocate(y)
+  allocate (y, source = "abcde")
+  call check2 (y, "abcde")
+  const = "hijklmnopq"
+  y = const
+  call check2 (y, "hijklmnopq")
+  associate (var => "mnopq")
+    call check2 (var, "mnopq")
+  end associate
+  deallocate (x, y)
+
+contains
+
+  function foo() result(res)
+    class(*), allocatable :: res(:)
+    res = arr
+  end function foo
+
+  function bar() result(res)
+    class(*), allocatable :: res
+    res = sca
+  end function bar
+
+  subroutine check1 (x, carg)
+    class(*), intent(in) :: x(:)
+    character(*) :: carg(:)
+    select type (x)
+    type is (character(*))
+      if (any (x .ne. carg)) stop 1
+    class default
+       stop 2
+    end select
+  end subroutine check1
+
+  subroutine check2 (x, carg)
+    class(*), intent(in) :: x
+    character(*) :: carg
+    select type (x)
+    type is (character(*))
+      if (x .ne. carg) stop 3
+    class default
+       stop 4
+    end select
+  end subroutine check2
+end