Fortran: Bugs found in class_transformational_1/2.f90[PR116254/118059].

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

gcc/fortran/ChangeLog

	PR fortran/116254
	* trans-array.cc (gfc_trans_create_temp_array): Make sure that
	transformational intrinsics of class objects that change rank,
	most particularly spread, go through the correct code path. Re-
	factor so that changes to the dtype are done on the temporary
	before the class data of the result points to it.

	PR fortran/118059
	* trans-expr.cc (arrayfunc_assign_needs_temporary): Character
	array function expressions assigned to an unlimited polymorphic
	variable require a temporary.

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index e531dd5efb7b4f78b137f690c525aa54e881a105..4506c86f166cc05da5a8763e8e7b960cf8b47366 100644 (file)
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1632,9 +1632,20 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
       tree class_data;
       tree dtype;
       gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL;
+      bool rank_changer;
+
+      /* Pick out these transformational functions because they change the rank
+        or shape of the first argument. This requires that the class type be
+        changed, the dtype updated and the correct rank used.  */
+      rank_changer = 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_SPREAD
+                        || expr1->value.function.isym->id == GFC_ISYM_PACK
+                        || expr1->value.function.isym->id == GFC_ISYM_UNPACK);
 
       /* Create a class temporary for the result using the lhs class object.  */
-      if (class_expr != NULL_TREE)
+      if (class_expr != NULL_TREE && !rank_changer)
        {
          tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
          gfc_add_modify (pre, tmp, class_expr);
@@ -1672,33 +1683,29 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
          elemsize = gfc_evaluate_now (elemsize, pre);
        }
 
-      /* Assign the new descriptor to the _data field. This allows the
-        vptr _copy to be used for scalarized assignment since the class
-        temporary can be found from the descriptor.  */
       class_data = gfc_class_data_get (tmp);
-      tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
-                            TREE_TYPE (desc), desc);
-      gfc_add_modify (pre, class_data, tmp);
 
-      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))
+      if (rank_changer)
        {
          /* 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);
+         tmp = gfc_conv_descriptor_dtype (desc);
          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;
-           }
+         /* These transformational functions change the rank.  */
+         tmp = gfc_conv_descriptor_rank (desc);
+         gfc_add_modify (pre, tmp,
+                         build_int_cst (TREE_TYPE (tmp), ss->loop->dimen));
+         fcn_ss->info->class_container = NULL_TREE;
        }
+
+      /* Assign the new descriptor to the _data field. This allows the
+        vptr _copy to be used for scalarized assignment since the class
+        temporary can be found from the descriptor.  */
+      tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+                            TREE_TYPE (desc), desc);
+      gfc_add_modify (pre, class_data, tmp);
+
       /* Point desc to the class _data field.  */
       desc = class_data;
     }

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 34891afb54ce8586089ed2cfe38108c95c278be0..9aedecb9780e184ee3053684a3876f811e2f01af 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11445,6 +11445,9 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
      character lengths are the same.  */
   if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
     {
+      if (UNLIMITED_POLY (expr1))
+       return true;
+
       if (expr1->ts.u.cl->length == NULL
            || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
        return true;