[Patch, fortran] PR102689 - Segfault with RESHAPE of CLASS as actual argument

[Patch, fortran] PR102689 - Segfault with RESHAPE of CLASS as actual argument

[Paul Richard Thomas]

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

Hi All,

This is one of those PRs where one thing led to another.... I think that
the patch is pretty complete and, while apparently quite heavy, is more or
less self explanatory through comments and the ChangeLog.

The first testcase concentrates on reshape in various guises, while the
second deals with all the other affected transformational intrinsic
functions. In the first, most of the test statements are factored out into
their own subroutines in order to expose the code generated for each. This
was essential for the debugging but can be undone if preferred.

Regtests just fine - OK for mainline?

Paul

[-- Attachment #2: Change.Logs --]
[-- Type: application/octet-stream, Size: 1970 bytes --]

Fortran: Fix class transformational intrinsic calls [PR102689]

2024-07-01  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/102689
	* trans-array.cc (get_array_ref_dim_for_loop_dim): Use the arg1
	class container carried in ss->info as the seed for a lhs in
	class valued transformational intrinsic calls that are not the
	rhs of an assignment. Otherwise, the lhs variable expression is
	taken from the loop chain. For this latter case, the _vptr and
	_len fields are set.
	(gfc_trans_create_temp_array): Use either the lhs expression
	seeds to build a class variable that will take the returned
	descriptor as its _data field. In the case that the arg1 expr.
	is used, a class typespec must be built with the correct rank
	and the _vptr and _len fields set. The element size is provided
	for the temporary allocation and to set the descriptor span.
	(gfc_array_init_size): When an intrinsic type scalar expr3 is
	used in allocation of a class array, use its element size in
	the descriptor dtype.
	* trans-expr.cc (gfc_conv_class_to_class): Class valued
	transformational intrinsics return the pointer to the array
	descriptor as the _data field of a class temporary. Extract
	directly and return the address of the class temporary.
	(gfc_conv_procedure_call): store the expression for the first
	argument of a class valued transformational intrinsic function
	in the ss info class_container field. Later, use its type  as
	the element type in the call to gfc_trans_create_temp_array.
	(fcncall_realloc_result): Add a dtype argument and use it in
	the descriptor, when available.
	(gfc_trans_arrayfunc_assign): For class lhs, build a dtype with
	the lhs rank and the rhs element size and use it in the call to
	fcncall_realloc_result.

gcc/testsuite/
	PR fortran/102689
	* gfortran.dg/class_transformational_1.f90: New test for class-
	valued reshape.
	* gfortran.dg/class_transformational_2.f90: New test for other
	class_valued transformational intrinsics.

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

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 19d69aec9c0..3926b42fcd1 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1301,10 +1301,13 @@ get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
    is a class expression.  */
 
 static tree
-get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
+get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
+			gfc_ss **fcnss)
 {
+  gfc_ss *loop_ss = ss->loop->ss;
   gfc_ss *lhs_ss;
   gfc_ss *rhs_ss;
+  gfc_ss *fcn_ss = NULL;
   tree tmp;
   tree tmp2;
   tree vptr;
@@ -1313,11 +1316,13 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
   bool unlimited_rhs = false;
   bool unlimited_lhs = false;
   bool rhs_function = false;
+  bool unlimited_arg1 = false;
   gfc_symbol *vtab;
+  tree cntnr = NULL_TREE;
 
   /* The second element in the loop chain contains the source for the
      temporary; ie. the rhs of the assignment.  */
-  rhs_ss = ss->loop->ss->loop_chain;
+  rhs_ss = loop_ss->loop_chain;
 
   if (rhs_ss != gfc_ss_terminator
       && rhs_ss->info
@@ -1335,19 +1340,49 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
 	rhs_function = true;
     }
 
+  /* Usually, ss points to the function. When the function call is an actual
+     argument, it is instead rhs_ss. */
+  *fcnss = fcn_ss = rhs_function ? rhs_ss : ss;
+
+  /* If this is a transformational function with a class result, the info
+     class_container field points to the class container of arg1.  */
+  if (rhs_class_expr != NULL_TREE
+      && fcn_ss->info && fcn_ss->info->expr
+      && fcn_ss->info->expr->expr_type == EXPR_FUNCTION
+      && fcn_ss->info->expr->value.function.isym
+      && fcn_ss->info->expr->value.function.isym->transformational)
+    {
+      cntnr = ss->info->class_container;
+      unlimited_arg1
+	   = UNLIMITED_POLY (fcn_ss->info->expr->value.function.actual->expr);
+    }
+
   /* For an assignment the lhs is the next element in the loop chain.
      If we have a class rhs, this had better be a class variable
-     expression!  */
+     expression!  Otherwise, the class container from arg1 can be used
+     to set the vptr and len fields of the result class container.  */
   lhs_ss = rhs_ss->loop_chain;
-  if (lhs_ss != gfc_ss_terminator
-      && lhs_ss->info
-      && lhs_ss->info->expr
+  if (lhs_ss && lhs_ss != gfc_ss_terminator
+      && lhs_ss->info && lhs_ss->info->expr
       && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
       && lhs_ss->info->expr->ts.type == BT_CLASS)
     {
       tmp = lhs_ss->info->data.array.descriptor;
       unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
     }
+  else if (cntnr != NULL_TREE)
+    {
+      tmp = gfc_class_vptr_get (rhs_class_expr);
+      gfc_add_modify (pre, tmp, fold_convert (TREE_TYPE (tmp),
+					      gfc_class_vptr_get (cntnr)));
+      if (unlimited_rhs)
+	{
+	  tmp = gfc_class_len_get (rhs_class_expr);
+	  if (unlimited_arg1)
+	    gfc_add_modify (pre, tmp, gfc_class_len_get (cntnr));
+	}
+      tmp = NULL_TREE;
+    }
   else
     tmp = NULL_TREE;
 
@@ -1369,11 +1404,9 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
 				    gfc_class_vptr_get (rhs_class_expr)));
       if (unlimited_lhs)
 	{
+	  gcc_assert (unlimited_rhs);
 	  tmp = gfc_class_len_get (lhs_class_expr);
-	  if (unlimited_rhs)
-	    tmp2 = gfc_class_len_get (rhs_class_expr);
-	  else
-	    tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
+	  tmp2 = gfc_class_len_get (rhs_class_expr);
 	  gfc_add_modify (pre, tmp, tmp2);
 	}
 
@@ -1383,7 +1416,7 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
 	  gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
 	}
     }
-  else
+  else if (rhs_ss->info->data.array.descriptor)
    {
       /* lhs is class and rhs is intrinsic or derived type.  */
       *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
@@ -1452,6 +1485,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
   tree or_expr;
   tree elemsize;
   tree class_expr = NULL_TREE;
+  gfc_ss *fcn_ss = NULL;
   int n, dim, tmp_dim;
   int total_dim = 0;
 
@@ -1471,7 +1505,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
      The descriptor can be obtained from the ss->info and then converted
      to the class object.  */
   if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
-    class_expr = get_class_info_from_ss (pre, ss, &eltype);
+    class_expr = get_class_info_from_ss (pre, ss, &eltype, &fcn_ss);
 
   /* If the dynamic type is not available, use the declared type.  */
   if (eltype && GFC_CLASS_TYPE_P (eltype))
@@ -1571,14 +1605,46 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
   gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
 				      arraytype, TYPE_NAME (arraytype)));
 
-  if (class_expr != NULL_TREE)
+  if (class_expr != NULL_TREE
+      || (fcn_ss && fcn_ss->info && fcn_ss->info->class_container))
     {
       tree class_data;
       tree dtype;
+      gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL;
+
+      /* Create a class temporary for the result using the lhs class object.  */
+      if (class_expr != NULL_TREE)
+	{
+	  tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
+	  gfc_add_modify (pre, tmp, class_expr);
+	}
+      else
+	{
+	  tree vptr;
+	  class_expr = fcn_ss->info->class_container;
+	  gcc_assert (expr1);
 
-      /* Create a class temporary.  */
-      tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
-      gfc_add_modify (pre, tmp, class_expr);
+	  /* Build a new class container using the arg1 class object. The class
+	     typespec must be rebuilt because the rank might have changed.  */
+	  gfc_typespec ts = CLASS_DATA (expr1)->ts;
+	  symbol_attribute attr = CLASS_DATA (expr1)->attr;
+	  gfc_change_class (&ts, &attr, NULL, expr1->rank, 0);
+	  tmp = gfc_create_var (gfc_typenode_for_spec (&ts), "ctmp");
+	  fcn_ss->info->class_container = tmp;
+
+	  /* Set the vptr and obtain the element size.  */
+	  vptr = gfc_class_vptr_get (tmp);
+	  gfc_add_modify (pre, vptr,
+			  fold_convert (TREE_TYPE (vptr),
+					gfc_class_vptr_get (class_expr)));
+	  elemsize = gfc_class_vtab_size_get (class_expr);
+	  elemsize = gfc_evaluate_now (elemsize, pre);
+
+	  /* Set the _len field, if necessary.  */
+	  if (UNLIMITED_POLY (expr1))
+	    gfc_add_modify (pre, gfc_class_len_get (tmp),
+			    gfc_class_len_get (class_expr));
+	}
 
       /* Assign the new descriptor to the _data field. This allows the
 	 vptr _copy to be used for scalarized assignment since the class
@@ -1588,11 +1654,25 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
 			     TREE_TYPE (desc), desc);
       gfc_add_modify (pre, class_data, tmp);
 
-      /* Take the dtype from the class expression.  */
-      dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
-      tmp = gfc_conv_descriptor_dtype (class_data);
-      gfc_add_modify (pre, tmp, dtype);
+      if (expr1 && expr1->expr_type == EXPR_FUNCTION
+	  && expr1->value.function.isym
+	  && (expr1->value.function.isym->id == GFC_ISYM_RESHAPE
+	      || expr1->value.function.isym->id == GFC_ISYM_UNPACK))
+	{
+	  /* Take the dtype from the class expression.  */
+	  dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
+	  tmp = gfc_conv_descriptor_dtype (class_data);
+	  gfc_add_modify (pre, tmp, dtype);
 
+	  /* Transformational functions reshape and reduce can change the rank.  */
+	  if (fcn_ss && fcn_ss->info && fcn_ss->info->class_container)
+	    {
+	      tmp = gfc_conv_descriptor_rank (class_data);
+	      gfc_add_modify (pre, tmp,
+			      build_int_cst (TREE_TYPE (tmp), ss->loop->dimen));
+	      fcn_ss->info->class_container = NULL_TREE;
+	    }
+	}
       /* Point desc to the class _data field.  */
       desc = class_data;
     }
@@ -5983,6 +6063,14 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
       tmp = gfc_conv_descriptor_dtype (descriptor);
       gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
     }
+  else if (expr->ts.type == BT_CLASS
+	   && expr3 && expr3->ts.type != BT_CLASS
+	   && expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE)
+    {
+      tmp = gfc_conv_descriptor_elem_len (descriptor);
+      gfc_add_modify (pblock, tmp,
+		      fold_convert (TREE_TYPE (tmp), expr3_elem_size));
+    }
   else
     {
       tmp = gfc_conv_descriptor_dtype (descriptor);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 558a7380516..015ab11d089 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1176,6 +1176,21 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
   stmtblock_t block;
   bool full_array = false;
 
+  /* Class transformational function results are the data field of a class
+     temporary and so the class expression canbe obtained directly.  */
+  if (e->expr_type == EXPR_FUNCTION
+      && e->value.function.isym
+      && e->value.function.isym->transformational
+      && TREE_CODE (parmse->expr) == COMPONENT_REF
+      && !GFC_CLASS_TYPE_P (TREE_TYPE (parmse->expr)))
+    {
+      parmse->expr = TREE_OPERAND (parmse->expr, 0);
+      if (!VAR_P (parmse->expr))
+	parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
+      parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+      return;
+    }
+
   gfc_init_block (&block);
 
   class_ref = NULL;
@@ -6258,7 +6273,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   gfc_component *comp = NULL;
   int arglen;
   unsigned int argc;
-
+  tree arg1_cntnr = NULL_TREE;
   arglist = NULL;
   retargs = NULL;
   stringargs = NULL;
@@ -6266,6 +6281,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   var = NULL_TREE;
   len = NULL_TREE;
   gfc_clear_ts (&ts);
+  gfc_intrinsic_sym *isym = expr && expr->rank ?
+			    expr->value.function.isym : NULL;
 
   comp = gfc_get_proc_ptr_comp (expr);
 
@@ -7375,6 +7392,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				    e->representation.length);
 	}
 
+      /* Make the class container for the first argument available with class
+	 valued transformational functions.  */
+      if (argc == 0 && e && e->ts.type == BT_CLASS
+	  && isym && isym->transformational
+	  && se->ss && se->ss->info)
+	{
+	  arg1_cntnr = parmse.expr;
+	  if (POINTER_TYPE_P (TREE_TYPE (arg1_cntnr)))
+	    arg1_cntnr = build_fold_indirect_ref_loc (input_location, arg1_cntnr);
+	  arg1_cntnr = gfc_get_class_from_expr (arg1_cntnr);
+	  se->ss->info->class_container = arg1_cntnr;
+	}
+
       if (fsym && e)
 	{
 	  /* Obtain the character length of an assumed character length
@@ -7961,6 +7991,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
 	  /* Set the type of the array.  */
 	  tmp = gfc_typenode_for_spec (&ts);
+	  tmp = arg1_cntnr ? TREE_TYPE (arg1_cntnr) : tmp;
 	  gcc_assert (se->ss->dimen == se->loop->dimen);
 
 	  /* Evaluate the bounds of the result, if known.  */
@@ -8241,8 +8272,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	 argument is actually given.  */
       arg = expr->value.function.actual;
       if (result && arg && expr->rank
-	  && expr->value.function.isym
-	  && expr->value.function.isym->transformational
+	  && isym && isym->transformational
 	  && arg->expr
 	  && arg->expr->ts.type == BT_DERIVED
 	  && arg->expr->ts.u.derived->attr.alloc_comp)
@@ -11187,7 +11217,7 @@ realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
    result to the original descriptor.  */
 
 static void
-fcncall_realloc_result (gfc_se *se, int rank)
+fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
 {
   tree desc;
   tree res_desc;
@@ -11206,7 +11236,10 @@ fcncall_realloc_result (gfc_se *se, int rank)
 
   /* Unallocated, the descriptor does not have a dtype.  */
   tmp = gfc_conv_descriptor_dtype (desc);
-  gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+  if (dtype != NULL_TREE)
+    gfc_add_modify (&se->pre, tmp, dtype);
+  else
+    gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
 
   res_desc = gfc_evaluate_now (desc, &se->pre);
   gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
@@ -11423,7 +11456,19 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
 	  ss->is_alloc_lhs = 1;
 	}
       else
-	fcncall_realloc_result (&se, expr1->rank);
+	{
+	  tree dtype = NULL_TREE;
+	  tree type = gfc_typenode_for_spec (&expr2->ts);
+	  if (expr1->ts.type == BT_CLASS)
+	    {
+	      tmp = gfc_class_vptr_get (sym->backend_decl);
+	      tree tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
+	      tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
+	      gfc_add_modify (&se.pre, tmp, tmp2);
+	      dtype = gfc_get_dtype_rank_type (expr1->rank,type);
+	    }
+	  fcncall_realloc_result (&se, expr1->rank, dtype);
+	}
     }
 
   gfc_conv_function_expr (&se, expr2);
diff --git a/gcc/testsuite/gfortran.dg/class_transformational_1.f90 b/gcc/testsuite/gfortran.dg/class_transformational_1.f90
new file mode 100644
index 00000000000..880ab96eabe
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_transformational_1.f90
@@ -0,0 +1,204 @@
+! { dg-do run }
+!
+! Test transformational intrinsics with class results - PR102689
+!
+! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+!
+module tests
+  type t
+    integer :: i
+  end type t
+  type, extends(t) :: s
+    integer :: j
+  end type
+
+contains
+
+  subroutine class_bar(x)
+    class(*), intent(in) :: x(..)
+    integer :: checksum
+
+    if (product (shape (x)) .ne. 10) stop 1
+    select rank (x)
+      rank (1)
+        select type (x)
+          type is (s)
+            if (sum(x%i) .ne. 55) stop 2
+            if ((sum(x%j) .ne. 550) .and. (sum(x%j) .ne. 110)) stop 3
+          type is (character(*))
+            checksum = sum(ichar(x(:)(1:1)) + ichar(x(:)(2:2)))
+            if ((checksum .ne. 1490) .and. (checksum .ne. 2130)) stop 4
+          class default
+            stop
+        end select
+      rank (2)
+        select type (x)
+          type is (s)
+            if (sum(x%i) .ne. 55) stop 5
+            if (sum(x%j) .ne. 550) stop 6
+          type is (character(*));
+            checksum = sum(ichar(x(:,:)(1:1)) + ichar(x(:,:)(2:2)))
+            if ((checksum .ne. 1490) .and. (checksum .ne. 2130)) stop 7
+          class default
+            stop 8
+        end select
+      rank (3)
+        select type (x)
+          type is (s)
+            if (sum(x%i) .ne. 55) stop 9
+            if ((sum(x%j) .ne. 550) .and. (sum(x%j) .ne. 110)) stop 10
+          type is (character(*))
+            checksum = sum(ichar(x(:,:,:)(1:1)) + ichar(x(:,:,:)(2:2)))
+            if ((checksum .ne. 1490) .and. (checksum .ne. 2130)) stop 11
+          class default
+            stop 12
+        end select
+      end select
+  end
+end module tests
+
+Module class_tests
+  use tests
+  implicit none
+  private
+  public :: test_class
+
+  integer :: j
+  integer :: src(10)
+  type (s), allocatable :: src3 (:,:,:)
+  class(t), allocatable :: B(:,:,:), D(:)
+
+! gfortran gave type(t) for D for all these test cases.
+contains
+
+  subroutine test_class
+
+    src3 = reshape ([(s(j,j*10), j=1,10)], [1,10,1])
+    call test1                               ! Now D OK for gfc15. B OK back to gfc10
+    call foo
+
+    call class_rebar(reshape(B, [10]))       ! This is the original failure - run time segfault
+
+    deallocate (B, D)
+
+    allocate(B(2,1,5), source = s(1,11))    ! B was OK but descriptor elem_len = 4 so....
+    src = [(j, j=1,10)]
+    call test2                              ! D%j was type(t) and filled with B[1:5]
+    call foo
+    deallocate (B,D)
+
+    call test3                              ! B is set to type(t) and filled with [s(1,11)..s(5,50)]
+    call foo
+    deallocate (B,D)
+
+    B = src3                                ! Now D was like B in test3. B OK back to gfc10
+    call foo
+    deallocate (B, D)
+  end
+
+  subroutine class_rebar (arg)
+    class(t) :: arg(:)
+    call class_bar (arg)
+  end
+
+  subroutine test1
+    allocate(B, source = src3)
+  end
+
+  subroutine test2
+    B%i = RESHAPE(src, shape(B))
+  end
+
+  subroutine test3
+    B = reshape ([(s(j,j*10), j=1,10)], shape(B))
+  end
+
+  subroutine foo
+    D = reshape(B, [10])
+    call class_bar(B)
+    call class_bar(D)
+  end
+end module class_tests
+
+module unlimited_tests
+  use tests
+  implicit none
+  private
+  public :: test_unlimited
+
+  integer :: j
+  integer :: src(10)
+  character(len = 2, kind = 1) :: chr(10)
+  character(len = 2, kind = 1) :: chr3(5, 2, 1)
+  type (s), allocatable :: src3 (:,:,:)
+  class(*), allocatable :: B(:,:,:), D(:)
+
+contains
+  subroutine test_unlimited
+    call test1
+    call foo
+
+    call unlimited_rebar(reshape(B, [10]))       ! Unlimited version of the original failure
+
+    deallocate (B, D)
+
+    call test3
+    call foo
+    deallocate (B,D)
+
+    B = src3
+    call foo
+    deallocate (B, D)
+
+    B = reshape ([(char(64 + 2*j - 1)//char(64 + 2*j), j = 1,10)], [5, 1, 2])
+    call foo
+    deallocate (B, D)
+
+    chr = [(char(96 + 2*j - 1)//char(96 + 2*j), j = 1,10)]
+    B = reshape (chr, [5, 1, 2])
+    call foo
+
+    call unlimited_rebar(reshape(B, [10]))       ! Unlimited/ character version of the original failure
+
+    deallocate (B, D)
+
+    chr3 = reshape (chr, shape(chr3))
+    B = chr3
+    call foo
+    deallocate (B, D)
+  end
+
+  subroutine unlimited_rebar (arg)
+    class(*), allocatable :: arg(:)
+    call class_bar (arg)
+  end
+
+  subroutine test1
+    src3 = reshape ([(s(j,j*10), j=1,10)], [2,1,5])
+    allocate(B, source = src3)
+  end
+
+  subroutine test3
+    B = reshape ([(s(j,j*10), j=1,10)], shape(B))
+  end
+
+  subroutine foo
+    D = reshape(B, [10])
+    call class_bar(B)
+    call class_bar(D)
+  end
+
+end module unlimited_tests
+
+  call t1
+  call t2
+contains
+  subroutine t1
+    use class_tests
+    call test_class
+  end
+  subroutine t2
+    use unlimited_tests
+    call test_unlimited
+  end
+end
diff --git a/gcc/testsuite/gfortran.dg/class_transformational_2.f90 b/gcc/testsuite/gfortran.dg/class_transformational_2.f90
new file mode 100644
index 00000000000..908758b7548
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_transformational_2.f90
@@ -0,0 +1,103 @@
+! { dg-do run }
+!
+! Test transformational intrinsics other than reshape with class results.
+! This emerged from PR102689, for which class_transformational_1.f90 tests
+! class-valued reshape.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+  type t
+    integer :: i
+  end type t
+  type, extends(t) :: s
+    integer :: j
+  end type
+  class(t), allocatable :: scalar, a(:), aa(:), b(:,:), c(:,:,:), field(:,:,:)
+  integer, allocatable :: ishape(:), ii(:), ij(:)
+  logical :: la(2), lb(2,2), lc (4,2,2)
+  integer :: j, stop_flag
+
+  call check_spread
+  call check_pack
+  call check_unpack
+  call check_eoshift
+  call check_eoshift_dep
+contains
+  subroutine check_result_a (shift)
+    type (s), allocatable :: ss(:)
+    integer :: shift
+    select type (aa)
+      type is (s)
+        ss = eoshift (aa, shift = shift, boundary = aa(1), dim = 1)
+        ishape = shape (aa);
+        ii = ss%i
+        ij = ss%j
+    end select
+    if (any (ishape .ne. shape (a))) stop stop_flag + 1
+    select type (a)
+      type is (s)
+        if (any (a%i .ne. ii)) stop stop_flag + 2
+        if (any (a%j .ne. ij)) stop stop_flag + 3
+    end select
+  end
+
+  subroutine check_result
+    if (any (shape (c) .ne. ishape)) stop stop_flag + 1
+    select type (a)
+      type is (s)
+        if (any (a%i .ne. ii)) stop stop_flag + 2
+        if (any (a%j .ne. ij)) stop stop_flag + 3
+    end select
+  end
+
+  subroutine check_spread
+    stop_flag = 10
+    a = [(s(j,10*j), j = 1,2)]
+    b = spread (a, dim = 2, ncopies = 2)
+    c = spread (b, dim = 1, ncopies = 4)
+    a = reshape (c, [size (c)])
+    ishape = [4,2,2]
+    ii = [1,1,1,1,2,2,2,2,1,1,1,1,2,2,2,2]
+    ij = 10*[1,1,1,1,2,2,2,2,1,1,1,1,2,2,2,2]
+    call check_result
+  end
+
+  subroutine check_pack
+    stop_flag = 20
+    la = [.false.,.true.]
+    lb = spread (la, dim = 2, ncopies = 2)
+    lc = spread (lb, dim = 1, ncopies = 4)
+    a = pack (c, mask = lc)
+    ishape = shape (lc)
+    ii = [2,2,2,2,2,2,2,2]
+    ij = 10*[2,2,2,2,2,2,2,2]
+    call check_result
+  end
+
+  subroutine check_unpack
+    stop_flag = 30
+    a = [(s(j,10*j), j = 1,16)]
+    field = reshape ([(s(100*j,1000*j), j = 1,16)], shape(lc))
+    c = unpack (a, mask = lc, field = field)
+    a = reshape (c, [product (shape (lc))])
+    ishape = shape (lc)
+    ii = [100,200,300,400,1,2,3,4,900,1000,1100,1200,5,6,7,8]
+    ij = [1000,2000,3000,4000,10,20,30,40,9000,10000, 11000,12000,50,60,70,80]
+    call check_result
+  end
+
+  subroutine check_eoshift
+    type (s), allocatable :: ss(:)
+    stop_flag = 40
+    aa = a
+    a = eoshift (aa, shift = 3, boundary = aa(1), dim = 1)
+    call check_result_a (3)
+  end
+
+  subroutine check_eoshift_dep
+    stop_flag = 50
+    aa = a
+    a = eoshift (a, shift = -3, boundary = a(1), dim = 1)
+    call check_result_a (-3)
+  end
+end

Re: [Patch, fortran] PR102689 - Segfault with RESHAPE of CLASS as actual argument

[Andre Vehreschild]

Hi Paul,

In
@@ -1335,19 +1340,49 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss,
tree *eltype) rhs_function = true;
     }
<SNIPP>
     }
+  else if (cntnr != NULL_TREE)
+    {
+      tmp = gfc_class_vptr_get (rhs_class_expr);
+      gfc_add_modify (pre, tmp, fold_convert (TREE_TYPE (tmp),
+					      gfc_class_vptr_get (cntnr)));
+      if (unlimited_rhs)
+	{
+	  tmp = gfc_class_len_get (rhs_class_expr);
+	  if (unlimited_arg1)
+	    gfc_add_modify (pre, tmp, gfc_class_len_get (cntnr));
+	}
+      tmp = NULL_TREE;
+    }
   else
     tmp = NULL_TREE;

I am confused here, because you are assigning to rhs. When that is correct, why
is there no else assigning zero to the rhs->_len when arg1 is not unlimited?

@@ -1176,6 +1176,21 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts, stmtblock_t block;
   bool full_array = false;

+  /* Class transformational function results are the data field of a class
+     temporary and so the class expression canbe obtained directly.  */

s/canbe/can be/


Besides those small knits the patch looks fine to me. I am wondering though,
why gfortran is still using a non-class aware pack? To "move" the content of a
class object the _copy function of the vtype is to be used, right? In my
current PR I try to implement a class aware internal pack (and unpack) to
correctly apply the element sequence as of F2018 15.5.2.11. But I am
struggling when the rank changes. I found the idea how to do this correctly in
your code, thanks.

Regards,
	Andre


On Mon, 1 Jul 2024 22:17:11 +0100
Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:

> Hi All,
>
> This is one of those PRs where one thing led to another.... I think that
> the patch is pretty complete and, while apparently quite heavy, is more or
> less self explanatory through comments and the ChangeLog.
>
> The first testcase concentrates on reshape in various guises, while the
> second deals with all the other affected transformational intrinsic
> functions. In the first, most of the test statements are factored out into
> their own subroutines in order to expose the code generated for each. This
> was essential for the debugging but can be undone if preferred.
>
> Regtests just fine - OK for mainline?
>
> Paul


--
Andre Vehreschild * Email: vehre ad gmx dot de

Re: [Patch, fortran] PR102689 - Segfault with RESHAPE of CLASS as actual argument

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 2883 bytes --]

Hi Andre,

Thank you for the review.


> ...snip...
>
> I am confused here, because you are assigning to rhs. When that is
> correct, why
> is there no else assigning zero to the rhs->_len when arg1 is not
> unlimited?


'rhs_class_expr' is highly confusing and came from the original use of this
part of the code. With this function call, it is actually the lhs! I will
think of some less confusing name and extend the comment above its
extraction from the ss chain.

    d._vptr = b._vptr;
    d._len = b._len;    // Here is the assignment that you pointed out.
    D.5162 = d._vptr != 0B ? d._vptr->_size : 0;
    D.5163 = D.5162;
    D.5164 = d._len;
    D.5165 = D.5164 > 0 ? D.5163 * D.5164 : D.5163;
        typedef character(kind=1) [10][1:D.5165];
    ctmp.123 = d;     // This looks a bit silly but it is effective for
more complicated objects - eg. class components.
    ctmp.123._data = atmp.122;
    ctmp.123._data.dtype = d._data.dtype;
    ctmp.123._data.dtype.rank = 1;
    ctmp.123._data.dim[0].stride = 1;
    ctmp.123._data.dim[0].lbound = 0;
    ctmp.123._data.dim[0].ubound = 9;
    ctmp.123._data.span = D.5165;
    D.5174 = (void * restrict) __builtin_malloc (MAX_EXPR <(unsigned long)
(D.5165 * 10), 1>);
    D.5175 = D.5174;
    ctmp.123._data.data = D.5175;
    ctmp.123._data.offset = 0;
    _gfortran_reshape (&ctmp.123._data, D.5152, D.5161, 0B, 0B);


>
> @@ -1176,6 +1176,21 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr
> *e,
> gfc_typespec class_ts, stmtblock_t block;
>    bool full_array = false;
>
> +  /* Class transformational function results are the data field of a class
> +     temporary and so the class expression canbe obtained directly.  */
>
> s/canbe/can be/
>
> Indeed!

>
> Besides those small knits the patch looks fine to me. I am wondering
> though,
> why gfortran is still using a non-class aware pack? To "move" the content
> of a
> class object the _copy function of the vtype is to be used, right? In my
> current PR I try to implement a class aware internal pack (and unpack) to
> correctly apply the element sequence as of F2018 15.5.2.11. But I am
> struggling when the rank changes. I found the idea how to do this
> correctly in
> your code, thanks.
>

It crossed my mind that class aware transformationals would have been the
path of least resistance *after* I had fought my way through the ss chains.
The full list of affected transformational intrinsics that operate on any
type is found in the second testcase. If you tackle pack first, I would be
happy to do the rest and to assign this patch to the dustbin of history. It
should be rather straightforward to provide an interface to the existing
library functions that produces significantly less inline code than my
implementation.

I will commit the patch, though, and will revert as and when class-aware
library functions are in place.

Thanks again

Paul

Re: [Patch, fortran] PR102689 - Segfault with RESHAPE of CLASS as actual argument

[Andre Vehreschild]

Hi Paul,

yes, please go ahead with the merge. To my astonishment, I had no conflicts
with your patch. Mine is addressing copy-in/(out) aka packing/unpacking of
derived-type to class-type arguments.

Thanks for the patch.

- Andre


On Tue, 2 Jul 2024 09:21:26 +0100
Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:

> Hi Andre,
>
> Thank you for the review.
>
>
> > ...snip...
> >
> > I am confused here, because you are assigning to rhs. When that is
> > correct, why
> > is there no else assigning zero to the rhs->_len when arg1 is not
> > unlimited?
>
>
> 'rhs_class_expr' is highly confusing and came from the original use of this
> part of the code. With this function call, it is actually the lhs! I will
> think of some less confusing name and extend the comment above its
> extraction from the ss chain.
>
>     d._vptr = b._vptr;
>     d._len = b._len;    // Here is the assignment that you pointed out.
>     D.5162 = d._vptr != 0B ? d._vptr->_size : 0;
>     D.5163 = D.5162;
>     D.5164 = d._len;
>     D.5165 = D.5164 > 0 ? D.5163 * D.5164 : D.5163;
>         typedef character(kind=1) [10][1:D.5165];
>     ctmp.123 = d;     // This looks a bit silly but it is effective for
> more complicated objects - eg. class components.
>     ctmp.123._data = atmp.122;
>     ctmp.123._data.dtype = d._data.dtype;
>     ctmp.123._data.dtype.rank = 1;
>     ctmp.123._data.dim[0].stride = 1;
>     ctmp.123._data.dim[0].lbound = 0;
>     ctmp.123._data.dim[0].ubound = 9;
>     ctmp.123._data.span = D.5165;
>     D.5174 = (void * restrict) __builtin_malloc (MAX_EXPR <(unsigned long)
> (D.5165 * 10), 1>);
>     D.5175 = D.5174;
>     ctmp.123._data.data = D.5175;
>     ctmp.123._data.offset = 0;
>     _gfortran_reshape (&ctmp.123._data, D.5152, D.5161, 0B, 0B);
>
>
> >
> > @@ -1176,6 +1176,21 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr
> > *e,
> > gfc_typespec class_ts, stmtblock_t block;
> >    bool full_array = false;
> >
> > +  /* Class transformational function results are the data field of a class
> > +     temporary and so the class expression canbe obtained directly.  */
> >
> > s/canbe/can be/
> >
> > Indeed!
>
> >
> > Besides those small knits the patch looks fine to me. I am wondering
> > though,
> > why gfortran is still using a non-class aware pack? To "move" the content
> > of a
> > class object the _copy function of the vtype is to be used, right? In my
> > current PR I try to implement a class aware internal pack (and unpack) to
> > correctly apply the element sequence as of F2018 15.5.2.11. But I am
> > struggling when the rank changes. I found the idea how to do this
> > correctly in
> > your code, thanks.
> >
>
> It crossed my mind that class aware transformationals would have been the
> path of least resistance *after* I had fought my way through the ss chains.
> The full list of affected transformational intrinsics that operate on any
> type is found in the second testcase. If you tackle pack first, I would be
> happy to do the rest and to assign this patch to the dustbin of history. It
> should be rather straightforward to provide an interface to the existing
> library functions that produces significantly less inline code than my
> implementation.
>
> I will commit the patch, though, and will revert as and when class-aware
> library functions are in place.
>
> Thanks again
>
> Paul


--
Andre Vehreschild * Email: vehre ad gmx dot de