Fortran: Unlimited polymorphic intrinsic function arguments [PR84006]

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

gcc/fortran
	PR fortran/84006
	PR fortran/100027
	PR fortran/98534
	* iresolve.cc (gfc_resolve_transfer): Emit a TODO error for
	unlimited polymorphic mold.
	* trans-expr.cc (gfc_resize_class_size_with_len): Use the fold
	even if a block is not available in which to fix the result.
	(trans_class_assignment): Enable correct assignment of
	character expressions to unlimited polymorphic variables using
	lhs _len field and rse string_length.
	* trans-intrinsic.cc (gfc_conv_intrinsic_storage_size): Extract
	the class expression so that the unlimited polymorphic class
	expression can be used in gfc_resize_class_size_with_len to
	obtain the storage size for character payloads. Guard the use
	of GFC_DECL_SAVED_DESCRIPTOR by testing for DECL_LANG_SPECIFIC
	to prevent the ICE. Also, invert the order to use the class
	expression extracted from the argument.
	(gfc_conv_intrinsic_transfer): In same way as 'storage_size',
	use the _len field to obtaining the correct length for arg 1.
	Add a branch for the element size in bytes of class expressions
	with provision to make use of the unlimited polymorphic _len
	field. Again, the class references are explicitly identified.
	'mold_expr' was already declared. Use it instead of 'arg'. Do
	not fix 'dest_word_len' for deferred character sources because
	reallocation on assign makes use of it before it is assigned.

gcc/testsuite/
	PR fortran/84006
	PR fortran/100027
	* gfortran.dg/storage_size_7.f90: New test.

	PR fortran/98534
	* gfortran.dg/transfer_class_4.f90: New test.

(cherry picked from commit b9294757f82aae8de6d98c122cd4e3b98f685217)

5 files changed, 257 insertions, 20 deletions

diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 8acad60..108c9a3 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -3017,6 +3017,10 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
 	}
     }
 
+  if (UNLIMITED_POLY (mold))
+    gfc_error ("TODO: unlimited polymorphic MOLD in TRANSFER intrinsic at %L",
+	       &mold->where);
+
   f->ts = mold->ts;
 
   if (size == NULL && mold->rank == 0)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 5946aa8..6b75c14 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -317,6 +317,8 @@ gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
 	  size = gfc_evaluate_now (size, block);
 	  tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
 	}
+      else
+	tmp = fold_convert (type , tmp);
       tmp2 = fold_build2_loc (input_location, MULT_EXPR,
 			      type, size, tmp);
       tmp = fold_build2_loc (input_location, GT_EXPR,
@@ -11671,15 +11673,24 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
 
       /* Take into account _len of unlimited polymorphic entities.
 	 TODO: handle class(*) allocatable function results on rhs.  */
-      if (UNLIMITED_POLY (rhs) && rhs->expr_type == EXPR_VARIABLE)
+      if (UNLIMITED_POLY (rhs))
 	{
-	  tree len = trans_get_upoly_len (block, rhs);
+	  tree len;
+	  if (rhs->expr_type == EXPR_VARIABLE)
+	    len = trans_get_upoly_len (block, rhs);
+	  else
+	    len = gfc_class_len_get (tmp);
 	  len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
 				 fold_convert (size_type_node, len),
 				 size_one_node);
 	  size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size),
 				  size, fold_convert (TREE_TYPE (size), len));
 	}
+      else if (rhs->ts.type == BT_CHARACTER && rse->string_length)
+	size = fold_build2_loc (input_location, MULT_EXPR,
+				gfc_charlen_type_node, size,
+				rse->string_length);
+
 
       tmp = lse->expr;
       class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 455b61a..f40bfda 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -8254,7 +8254,9 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
 {
   gfc_expr *arg;
   gfc_se argse;
-  tree type, result_type, tmp;
+  tree type, result_type, tmp, class_decl = NULL;
+  gfc_symbol *sym;
+  bool unlimited = false;
 
   arg = expr->value.function.actual->expr;
 
@@ -8265,10 +8267,12 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
     {
       if (arg->ts.type == BT_CLASS)
 	{
+	  unlimited = UNLIMITED_POLY (arg);
 	  gfc_add_vptr_component (arg);
 	  gfc_add_size_component (arg);
 	  gfc_conv_expr (&argse, arg);
 	  tmp = fold_convert (result_type, argse.expr);
+	  class_decl = gfc_get_class_from_expr (argse.expr);
 	  goto done;
 	}
 
@@ -8280,14 +8284,20 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
     {
       argse.want_pointer = 0;
       gfc_conv_expr_descriptor (&argse, arg);
+      sym = arg->expr_type == EXPR_VARIABLE ? arg->symtree->n.sym : NULL;
       if (arg->ts.type == BT_CLASS)
 	{
-	  if (arg->rank > 0)
+	  unlimited = UNLIMITED_POLY (arg);
+	  if (TREE_CODE (argse.expr) == COMPONENT_REF)
+	    tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
+	  else if (arg->rank > 0 && sym
+		   && DECL_LANG_SPECIFIC (sym->backend_decl))
 	    tmp = gfc_class_vtab_size_get (
-		 GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
+		 GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl));
 	  else
-	    tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
+	    gcc_unreachable ();
 	  tmp = fold_convert (result_type, tmp);
+	  class_decl = gfc_get_class_from_expr (argse.expr);
 	  goto done;
 	}
       type = gfc_get_element_type (TREE_TYPE (argse.expr));
@@ -8301,6 +8311,9 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
   tmp = fold_convert (result_type, tmp);
 
 done:
+  if (unlimited && class_decl)
+    tmp = gfc_resize_class_size_with_len (NULL, class_decl, tmp);
+
   se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
 			      build_int_cst (result_type, BITS_PER_UNIT));
   gfc_add_block_to_block (&se->pre, &argse.pre);
@@ -8423,7 +8436,10 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
 	{
 	  tmp = build_fold_indirect_ref_loc (input_location, argse.expr);
 	  if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
-	    source = gfc_class_data_get (tmp);
+	    {
+	      source = gfc_class_data_get (tmp);
+	      class_ref = tmp;
+	    }
 	  else
 	    {
 	      /* Array elements are evaluated as a reference to the data.
@@ -8450,9 +8466,17 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
 	  break;
 	case BT_CLASS:
 	  if (class_ref != NULL_TREE)
-	    tmp = gfc_class_vtab_size_get (class_ref);
+	    {
+	      tmp = gfc_class_vtab_size_get (class_ref);
+	      if (UNLIMITED_POLY (source_expr))
+		tmp = gfc_resize_class_size_with_len (NULL, class_ref, tmp);
+	    }
 	  else
-	    tmp = gfc_class_vtab_size_get (argse.expr);
+	    {
+	      tmp = gfc_class_vtab_size_get (argse.expr);
+	      if (UNLIMITED_POLY (source_expr))
+		tmp = gfc_resize_class_size_with_len (NULL, argse.expr, tmp);
+	    }
 	  break;
 	default:
 	  source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
@@ -8505,6 +8529,13 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
       if (arg->expr->ts.type == BT_CHARACTER)
 	tmp = size_of_string_in_bytes (arg->expr->ts.kind,
 				       argse.string_length);
+      else if (arg->expr->ts.type == BT_CLASS)
+	{
+	  class_ref = TREE_OPERAND (argse.expr, 0);
+	  tmp = gfc_class_vtab_size_get (class_ref);
+	  if (UNLIMITED_POLY (arg->expr))
+	    tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
+	}
       else
 	tmp = fold_convert (gfc_array_index_type,
 			    size_in_bytes (source_type));
@@ -8545,15 +8576,14 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
 
   if (arg->expr->rank == 0)
     {
-      gfc_conv_expr_reference (&argse, arg->expr);
+      gfc_conv_expr_reference (&argse, mold_expr);
       mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
 							  argse.expr));
     }
   else
     {
-      gfc_init_se (&argse, NULL);
       argse.want_pointer = 0;
-      gfc_conv_expr_descriptor (&argse, arg->expr);
+      gfc_conv_expr_descriptor (&argse, mold_expr);
       mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
     }
 
@@ -8564,27 +8594,41 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
     {
       /* If this TRANSFER is nested in another TRANSFER, use a type
 	 that preserves all bits.  */
-      if (arg->expr->ts.type == BT_LOGICAL)
-	mold_type = gfc_get_int_type (arg->expr->ts.kind);
+      if (mold_expr->ts.type == BT_LOGICAL)
+	mold_type = gfc_get_int_type (mold_expr->ts.kind);
     }
 
   /* Obtain the destination word length.  */
-  switch (arg->expr->ts.type)
+  switch (mold_expr->ts.type)
     {
     case BT_CHARACTER:
-      tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
-      mold_type = gfc_get_character_type_len (arg->expr->ts.kind,
+      tmp = size_of_string_in_bytes (mold_expr->ts.kind, argse.string_length);
+      mold_type = gfc_get_character_type_len (mold_expr->ts.kind,
 					      argse.string_length);
       break;
     case BT_CLASS:
-      tmp = gfc_class_vtab_size_get (argse.expr);
+      if (scalar_mold)
+	class_ref = argse.expr;
+      else
+	class_ref = TREE_OPERAND (argse.expr, 0);
+      tmp = gfc_class_vtab_size_get (class_ref);
+      if (UNLIMITED_POLY (arg->expr))
+	tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
       break;
     default:
       tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
       break;
     }
-  dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
-  gfc_add_modify (&se->pre, dest_word_len, tmp);
+
+  /* Do not fix dest_word_len if it is a variable, since the temporary can wind
+     up being used before the assignment.  */
+  if (mold_expr->ts.type == BT_CHARACTER && mold_expr->ts.deferred)
+    dest_word_len = tmp;
+  else
+    {
+      dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
+      gfc_add_modify (&se->pre, dest_word_len, tmp);
+    }
 
   /* Finally convert SIZE, if it is present.  */
   arg = arg->next;
diff --git a/gcc/testsuite/gfortran.dg/storage_size_7.f90 b/gcc/testsuite/gfortran.dg/storage_size_7.f90
new file mode 100644
index 0000000..e32ca1b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/storage_size_7.f90
@@ -0,0 +1,91 @@
+! { dg-do run }
+! Fix STORAGE_SIZE intrinsic for polymorphic arguments PR84006 and PR100027.
+! Contributed by Steve Kargl  <kargls@comcast.net>
+!            and José Rui Faustino de Sousa  <jrfsousa@gcc.gnu.org>
+program p
+  use, intrinsic :: ISO_FORTRAN_ENV, only: int64
+  type t
+    integer i
+  end type
+  type s
+    class(t), allocatable :: c(:)
+  end type
+  integer :: rslt, class_rslt
+  integer(kind=int64), target :: tgt
+  class(t), allocatable, target :: t_alloc(:)
+  class(s), allocatable, target :: s_alloc(:)
+  character(:), allocatable, target :: chr(:)
+  class(*), pointer :: ptr_s, ptr_a(:)
+
+  allocate (t_alloc(2), source=t(1))
+  rslt = storage_size(t_alloc(1))      ! Scalar arg - the original testcase
+  if (rslt .ne. 32) stop 1
+
+  rslt = storage_size(t_alloc)         ! Array arg
+  if (rslt .ne. 32) stop 2
+
+  call pr100027
+
+  allocate (s_alloc(2), source=s([t(1), t(2)]))
+! This, of course, is processor dependent: gfortran gives 576, NAG 448
+! and Intel 1216.
+  class_rslt = storage_size(s_alloc)   ! Type with a class component
+  ptr_s => s_alloc(2)
+! However, the unlimited polymorphic result should be the same
+  if (storage_size (ptr_s) .ne. class_rslt) stop 3
+  ptr_a => s_alloc
+  if (storage_size (ptr_a) .ne. class_rslt) stop 4
+
+  rslt = storage_size(s_alloc(1)%c(2)) ! Scalar component arg
+  if (rslt .ne. 32) stop 5
+
+  rslt = storage_size(s_alloc(1)%c)    ! Scalar component of array arg
+  if (rslt .ne. 32) stop 6
+
+  ptr_s => tgt
+  rslt = storage_size (ptr_s)          ! INTEGER(8) target
+  if (rslt .ne. 64) stop 7
+
+  allocate (chr(2), source = ["abcde", "fghij"])
+  ptr_s => chr(2)
+  rslt = storage_size (ptr_s)          ! CHARACTER(5) scalar
+  if (rslt .ne. 40) stop 8
+
+  ptr_a => chr
+  rslt = storage_size (ptr_a)          ! CHARACTER(5) array
+  if (rslt .ne. 40) stop 9
+
+  deallocate (t_alloc, s_alloc, chr)   ! For valgrind check
+
+contains
+
+! Original testcase from José Rui Faustino de Sousa
+  subroutine pr100027
+    implicit none
+
+    integer, parameter :: n = 11
+
+    type :: foo_t
+    end type foo_t
+
+    type, extends(foo_t) :: bar_t
+    end type bar_t
+
+    class(*),     pointer :: apu(:)
+    class(foo_t), pointer :: apf(:)
+    class(bar_t), pointer :: apb(:)
+    type(bar_t),   target :: atb(n)
+
+    integer :: m
+
+    apu => atb
+    m = storage_size(apu)
+    if (m .ne. 0) stop 10
+    apf => atb
+    m = storage_size(apf)
+    if (m .ne. 0) stop 11
+    apb => atb
+    m = storage_size(apb)
+    if (m .ne. 0) stop 12
+  end
+end program p
diff --git a/gcc/testsuite/gfortran.dg/transfer_class_4.f90 b/gcc/testsuite/gfortran.dg/transfer_class_4.f90
new file mode 100644
index 0000000..604874e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/transfer_class_4.f90
@@ -0,0 +1,87 @@
+! { dg-do run }
+!
+! Fix TRANSFER intrinsic for unlimited polymorphic SOURCEs - PR98534
+! Note that unlimited polymorphic MOLD is a TODO.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+  use, intrinsic :: ISO_FORTRAN_ENV, only: real32
+  implicit none
+  character(*), parameter :: string = "abcdefgh"
+  character(len=:), allocatable :: string_a(:)
+  class(*), allocatable :: star
+  class(*), allocatable :: star_a(:)
+  character(len=:), allocatable :: chr
+  character(len=:), allocatable :: chr_a(:)
+  integer :: sz, sum1, sum2, i
+  real(real32) :: r = 1.0
+
+! Part 1: worked correctly
+  star = r
+  sz = storage_size (star)/8
+  allocate (character(len=sz) :: chr)
+  chr = transfer (star, chr)
+  sum1 = sum ([(ichar(chr(i:i)), i = 1, sz)])
+  chr = transfer(1.0, chr)
+  sum2 = sum ([(ichar(chr(i:i)), i = 1, sz)])
+
+  if (sz /= storage_size (r)/8) stop 1
+  if (sum1 /= sum2) stop 2
+
+  deallocate (star) ! The automatic reallocation causes invalid writes
+                    ! and memory leaks. Even with this deallocation
+                    ! The invalid writes still occur.
+  deallocate (chr)
+
+! Part 2: Got everything wrong because '_len' field of unlimited polymorphic
+! expressions was not used.
+  star = string
+  sz = storage_size (star)/8
+  if (sz /= len (string)) stop 3 ! storage_size failed
+
+  sz = len (string) ! Ignore previous error in storage_size
+  allocate (character(len=sz) :: chr)
+  chr = transfer (star, chr)
+  sum1 = sum ([(ichar(chr(i:i)), i = 1, sz)])
+  chr = transfer(string, chr)
+  sum2 = sum ([(ichar(chr(i:i)), i = 1, sz)])
+  if (sum1 /= sum2) stop 4       ! transfer failed
+
+! Check that arrays are OK for transfer
+  star_a = ['abcde','fghij']
+  allocate (character (len = 5) :: chr_a(2))
+  chr_a = transfer (star_a, chr_a)
+  if (any (chr_a .ne. ['abcde','fghij'])) stop 5
+
+! Check that string length and size are correctly handled
+  string_a = ["abcdefgh", "ijklmnop"]
+  star_a = string_a;
+  chr_a = transfer (star_a, chr_a) ! Old string length used for size
+  if (size(chr_a) .ne. 4) stop 6
+  if (len(chr_a) .ne. 5) stop 7
+  if (trim (chr_a(3)) .ne. "klmno") stop 8
+  if (chr_a(4)(1:1) .ne. "p") stop 9
+
+  chr_a = transfer (star_a, string_a) ! Use correct string_length for payload
+  if (size(chr_a) .ne. 2) stop 10
+  if (len(chr_a) .ne. 8) stop 11
+  if (any (chr_a .ne. string_a)) stop 12
+
+! Check that an unlimited polymorphic function result is transferred OK
+  deallocate (chr_a)
+  string_a = ['abc', 'def', 'hij']
+  chr_a = transfer (foo (string_a), string_a)
+  if (any (chr_a .ne. string_a)) stop 13
+
+! Finally, check that the SIZE gives correct results with unlimited sources.
+  chr_a = transfer (star_a, chr_a, 4)
+  if (chr_a (4) .ne. 'jkl') stop 14
+
+  deallocate (star, chr, star_a, chr_a, string_a)
+contains
+  function foo (arg) result(res)
+    character(*), intent(in) :: arg(:)
+    class(*), allocatable :: res(:)
+    res = arg
+  end
+end