[gcc(refs/users/mikael/heads/refactor_descriptor_v291.01)] Suppression set_dtype_if_unallocated

https://gcc.gnu.org/g:646dbf75e6611cc3cc0302cc0557330e19c69b60

commit 646dbf75e6611cc3cc0302cc0557330e19c69b60
Author: Mikael Morin <[email protected]>
Date:   Sun Aug 10 11:03:57 2025 +0200

    Suppression set_dtype_if_unallocated
    
    Extraction gfc_descriptor_set_dtype_if_unallocated
    
    Sauvegarde
    
    Revert partiel
    
    Sauvegarde
    
    Correction indentation

Diff:
---
 gcc/fortran/trans-array.cc      |   2 +-
 gcc/fortran/trans-descriptor.cc |  32 ++++++++++++-
 gcc/fortran/trans-descriptor.h  |   2 +-
 gcc/fortran/trans-expr.cc       | 104 ++++++++++------------------------------
 4 files changed, 58 insertions(+), 82 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 46b5d70bbecf..3cf737e43fb8 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -655,7 +655,7 @@ void
 gfc_trans_static_array_pointer (gfc_symbol * sym)
 {
   gcc_assert (TREE_STATIC (sym->backend_decl));
-  gfc_init_static_descriptor (sym->backend_decl);
+  gfc_init_static_descriptor (sym);
 }
 
 
diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc
index 217664f4b5e0..e66637de70b8 100644
--- a/gcc/fortran/trans-descriptor.cc
+++ b/gcc/fortran/trans-descriptor.cc
@@ -962,10 +962,38 @@ gfc_init_absent_descriptor (stmtblock_t *block, tree descr)
 
 
 void
-gfc_init_static_descriptor (tree descr)
+gfc_init_static_descriptor (gfc_symbol *sym)
 {
+  vec<constructor_elt, va_gc> *v = NULL;
+
+  tree descr = sym->backend_decl;
   tree type = TREE_TYPE (descr);
-  DECL_INITIAL (descr) = gfc_build_null_descriptor (type);
+
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+  tree fields = TYPE_FIELDS (type);
+
+  tree data_field = gfc_advance_chain (fields, DATA_FIELD);
+  CONSTRUCTOR_APPEND_ELT (v, data_field,
+			  fold_convert (TREE_TYPE (data_field),
+					null_pointer_node));
+
+  gfc_array_spec *as;
+  if (sym->ts.type == BT_CLASS)
+    as = CLASS_DATA (sym)->as;
+  else
+    as = sym->as;
+
+  int rank = as ? as->rank : 0;
+  tree dtype_field = gfc_advance_chain (fields, DTYPE_FIELD);
+  tree dtype_value = gfc_get_dtype_rank_type (rank,
+					      gfc_get_element_type (type));
+  CONSTRUCTOR_APPEND_ELT (v, dtype_field,
+			  fold_convert (TREE_TYPE (dtype_field), dtype_value));
+
+  tree constr = build_constructor (type, v);
+  TREE_CONSTANT (constr) = 1;
+
+  DECL_INITIAL (descr) = constr;
 }
 
 
diff --git a/gcc/fortran/trans-descriptor.h b/gcc/fortran/trans-descriptor.h
index 45a4a2d47c10..947902e83a84 100644
--- a/gcc/fortran/trans-descriptor.h
+++ b/gcc/fortran/trans-descriptor.h
@@ -70,7 +70,7 @@ void gfc_grow_array (stmtblock_t *, tree, tree);
 void gfc_nullify_descriptor (stmtblock_t *block, tree);
 void gfc_init_descriptor_result (stmtblock_t *block, tree descr);
 void gfc_init_absent_descriptor (stmtblock_t *block, tree descr);
-void gfc_init_static_descriptor (tree descr);
+void gfc_init_static_descriptor (gfc_symbol *);
 tree gfc_create_null_actual_descriptor (stmtblock_t *, gfc_typespec *,
 					symbol_attribute, int);
 
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 59a0eceed5fd..b5dd4baa749c 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -5975,50 +5975,6 @@ expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
 }
 
 
-/* A helper function to set the dtype for unallocated or unassociated
-   entities.  */
-
-static void
-set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
-{
-  tree tmp;
-  tree desc;
-  tree cond;
-  tree type;
-  stmtblock_t block;
-
-  /* TODO Figure out how to handle optional dummies.  */
-  if (e && e->expr_type == EXPR_VARIABLE
-      && e->symtree->n.sym->attr.optional)
-    return;
-
-  desc = parmse->expr;
-  if (desc == NULL_TREE)
-    return;
-
-  if (POINTER_TYPE_P (TREE_TYPE (desc)))
-    desc = build_fold_indirect_ref_loc (input_location, desc);
-  if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
-    desc = gfc_class_data_get (desc);
-  if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
-    return;
-
-  gfc_init_block (&block);
-  tmp = gfc_conv_descriptor_data_get (desc);
-  cond = fold_build2_loc (input_location, EQ_EXPR,
-			  logical_type_node, tmp,
-			  build_int_cst (TREE_TYPE (tmp), 0));
-  type = gfc_get_element_type (TREE_TYPE (desc));
-  gfc_conv_descriptor_dtype_set (&block, desc,
-				 gfc_get_dtype_rank_type (e->rank, type));
-  cond = build3_v (COND_EXPR, cond,
-		   gfc_finish_block (&block),
-		   build_empty_stmt (input_location));
-  gfc_add_expr_to_block (&parmse->pre, cond);
-}
-
-
-
 /* Provide an interface between gfortran array descriptors and the F2018:18.4
    ISO_Fortran_binding array descriptors. */
 
@@ -7835,40 +7791,32 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  && (fsym->ts.type == BT_CLASS
 	      ? (CLASS_DATA (fsym)->as
 		 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
-	      : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
-	{
-	  if (fsym->ts.type == BT_CLASS
-	      ? (CLASS_DATA (fsym)->attr.class_pointer
-		 || CLASS_DATA (fsym)->attr.allocatable)
-	      : (fsym->attr.pointer || fsym->attr.allocatable))
-	    {
-	      /* Unallocated allocatable arrays and unassociated pointer
-		 arrays need their dtype setting if they are argument
-		 associated with assumed rank dummies to set the rank.  */
-	      set_dtype_for_unallocated (&parmse, e);
-	    }
-	  else if (e->expr_type == EXPR_VARIABLE
-		   && e->symtree->n.sym->attr.dummy
-		   && (e->ts.type == BT_CLASS
-		       ? (e->ref && e->ref->next
-			  && e->ref->next->type == REF_ARRAY
-			  && e->ref->next->u.ar.type == AR_FULL
-			  && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
-		       : (e->ref && e->ref->type == REF_ARRAY
-			  && e->ref->u.ar.type == AR_FULL
-			  && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
-	    {
-	      /* Assumed-size actual to assumed-rank dummy requires
-		 dim[rank-1].ubound = -1. */
-	      tree minus_one;
-	      tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
-	      if (fsym->ts.type == BT_CLASS)
-		tmp = gfc_class_data_get (tmp);
-	      minus_one = build_int_cst (gfc_array_index_type, -1);
-	      gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
-					      gfc_rank_cst[e->rank - 1],
-					      minus_one);
-	    }
+	      : (fsym->as && fsym->as->type == AS_ASSUMED_RANK))
+	  && !(fsym->ts.type == BT_CLASS
+	       ? (CLASS_DATA (fsym)->attr.class_pointer
+		  || CLASS_DATA (fsym)->attr.allocatable)
+	       : (fsym->attr.pointer || fsym->attr.allocatable))
+	  && e->expr_type == EXPR_VARIABLE
+	  && e->symtree->n.sym->attr.dummy
+	  && (e->ts.type == BT_CLASS
+	      ? (e->ref && e->ref->next
+		 && e->ref->next->type == REF_ARRAY
+		 && e->ref->next->u.ar.type == AR_FULL
+		 && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
+	      : (e->ref && e->ref->type == REF_ARRAY
+		 && e->ref->u.ar.type == AR_FULL
+		 && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
+	{
+	  /* Assumed-size actual to assumed-rank dummy requires
+	     dim[rank-1].ubound = -1. */
+	  tree minus_one;
+	  tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
+	  if (fsym->ts.type == BT_CLASS)
+	    tmp = gfc_class_data_get (tmp);
+	  minus_one = build_int_cst (gfc_array_index_type, -1);
+	  gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
+					  gfc_rank_cst[e->rank - 1],
+					  minus_one);
 	}
 
       /* The case with fsym->attr.optional is that of a user subroutine