[Patch, fortran] PR113363 - ICE on ASSOCIATE and unlimited polymorphic function

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 1149 bytes --]

Hi All,

This patch corrects incorrect results from assignment of unlimited
polymorphic function results both in assignment statements and allocation
with source.

The first chunk in trans-array.cc ensures that the array dtype is set to
the source dtype. The second chunk ensures that the lhs _len field does not
default to zero and so is specific to dynamic types of character.

The addition to trans-stmt.cc transforms the source expression, aka expr3,
from a derived type of type "STAR" into a proper unlimited polymorphic
expression ready for assignment to the newly allocated entity.

OK for mainline?

Paul

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

2024-04-10  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.
(gfc_alloc_allocatable_for_assignment): Set the _len field for
unlimited polymorphic assignments.
* 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.

[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 5706 bytes --]

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 30b84762346..2f9a32dda15 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -5957,6 +5957,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);
@@ -11324,6 +11329,9 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
 	    gfc_add_modify (&fblock, tmp,
 			    fold_convert (TREE_TYPE (tmp),
 					  TYPE_SIZE_UNIT (type)));
+	  else if (UNLIMITED_POLY (expr2))
+	    gfc_add_modify (&fblock, tmp,
+			    gfc_class_len_get (TREE_OPERAND (desc, 0)));
 	  else
 	    gfc_add_modify (&fblock, tmp,
 			    build_int_cst (TREE_TYPE (tmp), 0));
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 7997c167bae..c6953033cf4 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -7187,6 +7187,45 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
 	  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);
+		      rhs->ref->next = gfc_copy_ref (ref->next);
+		      break;
+		    }
+		  else if ((init_expr->rank && !code->expr3->rank
+			    && ref && ref->next && !ref->next->next)
+			   || (ref && !ref->next))
+		    {
+		      rhs->ref = gfc_copy_ref (ref);
+		      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 00000000000..7701539fdff
--- /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"
+
+! 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")
+  y = "hijklmnopq"
+  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(*))
+!       print *, len(x), x
+      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(*))
+!       print *, len(x), x
+      if (x .ne. carg) stop 3
+    class default
+       stop 4
+    end select
+  end subroutine check2
+end