https://gcc.gnu.org/g:749d4907fa5321f6283899865cbe6ea4094979d4

commit 749d4907fa5321f6283899865cbe6ea4094979d4
Author: Mikael Morin <mik...@gcc.gnu.org>
Date:   Wed Jul 2 11:30:20 2025 +0200

    Revert "Fortran: Suppress bogus used uninitialized warnings [PR108889]."
    
    This reverts commit c3aa339ea50f050caf7ed2e497f5499ec2d7b9cc.
    
    Sauvegarde suppression initialisation inutile bornes pour taire warnings
    
    Correction régression realloc_on_assign_23.f90
    
    Correction régression realloc_on_assign_1.f03
    
    Correction régression pr108889.f90 realloc_on_assign*
    
    Correction régression associate_46.f90
    
    Correction régression array_function_6.f90
    
    Correction régression allocate_with_source_5.f90
    
    Correction régression func_result_6.f90
    
    Correction régression PR95196.f90
    
    Correction typebound_operator_9.f90
    
    Correction régression class_transformational_2.f90
    
    Correction régression alloc_comp_assign_12 etc
    
    Correction actual_array_offset_1.f90

Diff:
---
 gcc/fortran/gfortran.h     |   4 -
 gcc/fortran/resolve.cc     |  46 ++++++++--
 gcc/fortran/trans-array.cc | 203 ++++++++++++++++++++++++++++++---------------
 gcc/fortran/trans-expr.cc  |  34 ++++----
 4 files changed, 190 insertions(+), 97 deletions(-)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 6848bd1762d3..69367e638c5b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2028,10 +2028,6 @@ typedef struct gfc_symbol
   /* Set if this should be passed by value, but is not a VALUE argument
      according to the Fortran standard.  */
   unsigned pass_as_value:1;
-  /* Set if an allocatable array variable has been allocated in the current
-     scope. Used in the suppression of uninitialized warnings in reallocation
-     on assignment.  */
-  unsigned allocated_in_scope:1;
   /* Set if an external dummy argument is called with different argument lists.
      This is legal in Fortran, but can cause problems with autogenerated
      C prototypes for C23.  */
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 4a6e951cdf16..5b021ad6137b 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -2800,6 +2800,31 @@ done:
 }
 
 
+static void
+expression_shape (gfc_expr *e, gfc_array_spec *as)
+{
+  mpz_t array[GFC_MAX_DIMENSIONS];
+  int i;
+
+  if (e->rank <= 0 || e->shape != NULL)
+    return;
+
+  for (i = 0; i < e->rank; i++)
+    if (!spec_dimen_size (as, i, &array[i]))
+      goto fail;
+
+  e->shape = gfc_get_shape (e->rank);
+
+  memcpy (e->shape, array, e->rank * sizeof (mpz_t));
+
+  return;
+
+fail:
+  for (i--; i >= 0; i--)
+    mpz_clear (array[i]);
+}
+
+
 /************* Function resolution *************/
 
 /* Resolve a function call known to be generic.
@@ -2823,15 +2848,17 @@ resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
          else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
            expr->ts = s->result->ts;
 
-         if (s->as != NULL)
-           {
-             expr->rank = s->as->rank;
-             expr->corank = s->as->corank;
-           }
-         else if (s->result != NULL && s->result->as != NULL)
+         if (s->result != NULL && s->result->as != NULL)
            {
              expr->rank = s->result->as->rank;
              expr->corank = s->result->as->corank;
+             expression_shape (expr, s->result->as);
+           }
+         else if (s->as != NULL)
+           {
+             expr->rank = s->as->rank;
+             expr->corank = s->as->corank;
+             expression_shape (expr, s->as);
            }
 
          gfc_set_sym_referenced (expr->value.function.esym);
@@ -2975,11 +3002,13 @@ found:
     {
       expr->rank = CLASS_DATA (sym)->as->rank;
       expr->corank = CLASS_DATA (sym)->as->corank;
+      expression_shape (expr, CLASS_DATA (sym)->as);
     }
   else if (sym->as != NULL)
     {
       expr->rank = sym->as->rank;
       expr->corank = sym->as->corank;
+      expression_shape (expr, sym->as);
     }
 
   return MATCH_YES;
@@ -3104,6 +3133,7 @@ resolve_unknown_f (gfc_expr *expr)
     {
       expr->rank = sym->as->rank;
       expr->corank = sym->as->corank;
+      expression_shape (expr, sym->as);
     }
 
   /* Type of the expression is either the type of the symbol or the
@@ -3663,6 +3693,7 @@ resolve_function (gfc_expr *expr)
     gfc_warning (OPT_Wdeprecated_declarations,
                 "Using function %qs at %L is deprecated",
                 sym->name, &expr->where);
+
   return t;
 }
 
@@ -5896,9 +5927,6 @@ gfc_resolve_ref (gfc_expr *expr)
 }
 
 
-/* Given an expression, determine its shape.  This is easier than it sounds.
-   Leaves the shape array NULL if it is not possible to determine the shape.  
*/
-
 static void
 expression_shape (gfc_expr *e)
 {
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 7be2d7b11a62..76939bdf7ef9 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -3420,6 +3420,35 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, 
bool subscript,
 }
 
 
+/* A simple reference can be accessed with a pointer and
+   a constant offset.  */
+bool
+simple_reference_p (tree data_ref)
+{
+  bool seen_dereference = false;
+  while (true)
+    {
+      if (DECL_P (data_ref))
+       return true;
+
+      if (TREE_CODE (data_ref) == INDIRECT_REF)
+       {
+         if (seen_dereference)
+           return false;
+
+         seen_dereference = true;
+         data_ref = TREE_OPERAND (data_ref, 0);
+       }
+      else if (TREE_CODE (data_ref) == COMPONENT_REF)
+       data_ref = TREE_OPERAND (data_ref, 0);
+      else if (TREE_CODE (data_ref) == NOP_EXPR)
+       data_ref = TREE_OPERAND (data_ref, 0);
+      else
+       return false;
+    }
+}
+
+
 /* Translate expressions for the descriptor and data pointer of a SS.  */
 /*GCC ARRAYS*/
 
@@ -3440,7 +3469,35 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * 
ss, int base)
   se.descriptor_only = 1;
   gfc_conv_expr_lhs (&se, ss_info->expr);
   gfc_add_block_to_block (block, &se.pre);
-  info->descriptor = se.expr;
+  if (simple_reference_p (se.expr))
+    info->descriptor = se.expr;
+  else
+    {
+      tree desc = se.expr;
+      STRIP_NOPS (desc);
+      if (TREE_CODE (desc) == INDIRECT_REF)
+       {
+         tree ptr = TREE_OPERAND (desc, 0);
+         ptr = gfc_evaluate_now (ptr, block);
+         TREE_OPERAND (desc, 0) = ptr;
+         info->descriptor = se.expr;
+       }
+      else if (TREE_CODE (desc) == COMPONENT_REF)
+       {
+         tree parent_ref = TREE_OPERAND (desc, 0);
+         tree parent_ptr_type = build_pointer_type (TREE_TYPE (parent_ref));
+         tree ptr = fold_build1_loc (input_location, ADDR_EXPR,
+                                     parent_ptr_type, parent_ref);
+         ptr = gfc_evaluate_now (ptr, block);
+         tree deref = fold_build1_loc (input_location, INDIRECT_REF,
+                                       TREE_TYPE (parent_ref),
+                                       ptr);
+         TREE_OPERAND (desc, 0) = deref;
+         info->descriptor = se.expr;
+       }
+      else
+       info->descriptor = gfc_evaluate_now (se.expr, block);
+    }
   ss_info->string_length = se.string_length;
   ss_info->class_container = se.class_container;
 
@@ -3471,12 +3528,15 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * 
ss, int base)
                && DECL_P (TREE_OPERAND (tmp, 0)))
            || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
                && TREE_CODE (se.expr) == COMPONENT_REF
-               && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0))))))
+               && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0)))))
+         && !ss->is_alloc_lhs)
        tmp = gfc_evaluate_now (tmp, block);
       info->data = tmp;
 
       tmp = gfc_conv_array_offset (se.expr);
-      info->offset = gfc_evaluate_now (tmp, block);
+      if (!ss->is_alloc_lhs)
+       tmp = gfc_evaluate_now (tmp, block);
+      info->offset = tmp;
 
       /* Make absolutely sure that the saved_offset is indeed saved
         so that the variable is still accessible after the loops
@@ -4769,13 +4829,12 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * 
loop, stmtblock_t * body)
 
 static void
 evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
-               tree desc, int dim, bool lbound, bool deferred)
+               tree desc, int dim, bool lbound, bool deferred, bool save_value)
 {
   gfc_se se;
   gfc_expr * input_val = values[dim];
   tree *output = &bounds[dim];
 
-
   if (input_val)
     {
       /* Specified section bound.  */
@@ -4801,7 +4860,8 @@ evaluate_bound (stmtblock_t *block, tree *bounds, 
gfc_expr ** values,
       *output = lbound ? gfc_conv_array_lbound (desc, dim) :
                         gfc_conv_array_ubound (desc, dim);
     }
-  *output = gfc_evaluate_now (*output, block);
+  if (save_value)
+    *output = gfc_evaluate_now (*output, block);
 }
 
 
@@ -4834,18 +4894,18 @@ gfc_conv_section_startstride (stmtblock_t * block, 
gfc_ss * ss, int dim)
              || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
   desc = info->descriptor;
   stride = ar->stride[dim];
-
+  bool save_value = !ss->is_alloc_lhs;
 
   /* Calculate the start of the range.  For vector subscripts this will
      be the range of the vector.  */
   evaluate_bound (block, info->start, ar->start, desc, dim, true,
-                 ar->as->type == AS_DEFERRED);
+                 ar->as->type == AS_DEFERRED, save_value);
 
   /* Similarly calculate the end.  Although this is not used in the
      scalarizer, it is needed when checking bounds and where the end
      is an expression with side-effects.  */
   evaluate_bound (block, info->end, ar->end, desc, dim, false,
-                 ar->as->type == AS_DEFERRED);
+                 ar->as->type == AS_DEFERRED, save_value);
 
 
   /* Calculate the stride.  */
@@ -4856,7 +4916,11 @@ gfc_conv_section_startstride (stmtblock_t * block, 
gfc_ss * ss, int dim)
       gfc_init_se (&se, NULL);
       gfc_conv_expr_type (&se, stride, gfc_array_index_type);
       gfc_add_block_to_block (block, &se.pre);
-      info->stride[dim] = gfc_evaluate_now (se.expr, block);
+      tree value = se.expr;
+      if (save_value)
+       info->stride[dim] = gfc_evaluate_now (value, block);
+      else
+       info->stride[dim] = value;
     }
 }
 
@@ -5991,7 +6055,10 @@ gfc_set_delta (gfc_loopinfo *loop)
                                     gfc_array_index_type,
                                     info->start[dim], tmp);
 
-             info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
+             if (ss->is_alloc_lhs)
+               info->delta[dim] = tmp;
+             else 
+               info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
            }
        }
     }
@@ -6779,8 +6846,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree 
status, tree errmsg,
   else
       gfc_add_expr_to_block (&se->pre, set_descriptor);
 
-  expr->symtree->n.sym->allocated_in_scope = 1;
-
   return true;
 }
 
@@ -8470,7 +8535,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
          gcc_assert (n == codim - 1);
          evaluate_bound (&loop.pre, info->start, ar->start,
                          info->descriptor, n + ndim, true,
-                         ar->as->type == AS_DEFERRED);
+                         ar->as->type == AS_DEFERRED, true);
          loop.from[n + loop.dimen] = info->start[n + ndim];
        }
       else
@@ -11206,6 +11271,9 @@ gfc_is_reallocatable_lhs (gfc_expr *expr)
   gfc_ref * ref;
   gfc_symbol *sym;
 
+  if (!flag_realloc_lhs)
+    return false;
+
   if (!expr->ref)
     return false;
 
@@ -11330,6 +11398,51 @@ concat_str_length (gfc_expr* expr)
 }
 
 
+static void
+update_reallocated_descriptor (stmtblock_t *block, gfc_loopinfo *loop)
+{
+  for (gfc_ss *s = loop->ss; s != gfc_ss_terminator; s = s->loop_chain)
+    {
+      if (!s->is_alloc_lhs)
+       continue;
+
+      gcc_assert (s->info->type == GFC_SS_SECTION);
+      gfc_array_info *info = &s->info->data.array;
+      tree desc = info->descriptor;
+
+#define UPDATE_VALUE(field, value) \
+             do \
+               { \
+                 if ((field) && VAR_P ((field))) \
+                   { \
+                     tree val = (value); \
+                     gfc_add_modify (block, (field), val); \
+                   } \
+                 else \
+                   (field) = gfc_evaluate_now ((field), block); \
+               } \
+             while (0)
+
+      UPDATE_VALUE (info->offset, gfc_conv_descriptor_offset_get (desc));
+      info->saved_offset = info->offset;
+      for (int i = 0; i < s->dimen; i++)
+       {
+         int dim = s->dim[i];
+         tree tree_dim = gfc_rank_cst[dim]; 
+         UPDATE_VALUE (info->start[dim],
+                       gfc_conv_descriptor_lbound_get (desc, tree_dim));
+         UPDATE_VALUE (info->end[dim],
+                       gfc_conv_descriptor_ubound_get (desc, tree_dim));
+         UPDATE_VALUE (info->stride[dim],
+                       gfc_conv_descriptor_stride_get (desc, tree_dim));
+         info->delta[dim] = gfc_evaluate_now (info->delta[dim], block);
+       }
+
+#undef UPDATE_VALUE
+    }
+}
+
+
 /* Allocate the lhs of an assignment to an allocatable array, otherwise
    reallocate it.  */
 
@@ -11341,8 +11454,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo 
*loop,
   stmtblock_t realloc_block;
   stmtblock_t alloc_block;
   stmtblock_t fblock;
-  stmtblock_t loop_pre_block;
-  gfc_ref *ref;
   gfc_ss *rss;
   gfc_ss *lss;
   gfc_array_info *linfo;
@@ -11543,45 +11654,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo 
*loop,
                         array1, build_int_cst (TREE_TYPE (array1), 0));
   cond_null= gfc_evaluate_now (cond_null, &fblock);
 
-  /* If the data is null, set the descriptor bounds and offset. This suppresses
-     the maybe used uninitialized warning and forces the use of malloc because
-     the size is zero in all dimensions. Note that this block is only executed
-     if the lhs is unallocated and is only applied once in any namespace.
-     Component references are not subject to the warnings.  */
-  for (ref = expr1->ref; ref; ref = ref->next)
-    if (ref->type == REF_COMPONENT)
-      break;
-
-  if (!expr1->symtree->n.sym->allocated_in_scope && !ref)
-    {
-      gfc_start_block (&loop_pre_block);
-      for (n = 0; n < expr1->rank; n++)
-       {
-         gfc_conv_descriptor_lbound_set (&loop_pre_block, desc,
-                                         gfc_rank_cst[n],
-                                         gfc_index_one_node);
-         gfc_conv_descriptor_ubound_set (&loop_pre_block, desc,
-                                         gfc_rank_cst[n],
-                                         gfc_index_zero_node);
-         gfc_conv_descriptor_stride_set (&loop_pre_block, desc,
-                                         gfc_rank_cst[n],
-                                         gfc_index_zero_node);
-       }
-
-      tmp = gfc_conv_descriptor_offset (desc);
-      gfc_add_modify (&loop_pre_block, tmp, gfc_index_zero_node);
-
-      tmp = fold_build2_loc (input_location, EQ_EXPR,
-                            logical_type_node, array1,
-                            build_int_cst (TREE_TYPE (array1), 0));
-      tmp = build3_v (COND_EXPR, tmp,
-                     gfc_finish_block (&loop_pre_block),
-                     build_empty_stmt (input_location));
-      gfc_prepend_expr_to_block (&loop->pre, tmp);
-
-      expr1->symtree->n.sym->allocated_in_scope = 1;
-    }
-
   tmp = build3_v (COND_EXPR, cond_null,
                  build1_v (GOTO_EXPR, jump_label1),
                  build_empty_stmt (input_location));
@@ -11736,9 +11808,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo 
*loop,
      running offset.  Use the saved_offset instead.  */
   tmp = gfc_conv_descriptor_offset (desc);
   gfc_add_modify (&fblock, tmp, offset);
-  if (linfo->saved_offset
-      && VAR_P (linfo->saved_offset))
-    gfc_add_modify (&fblock, linfo->saved_offset, tmp);
 
   /* Now set the deltas for the lhs.  */
   for (n = 0; n < expr1->rank; n++)
@@ -11748,8 +11817,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo 
*loop,
       tmp = fold_build2_loc (input_location, MINUS_EXPR,
                             gfc_array_index_type, tmp,
                             loop->from[dim]);
-      if (linfo->delta[dim] && VAR_P (linfo->delta[dim]))
-       gfc_add_modify (&fblock, linfo->delta[dim], tmp);
     }
 
   /* Take into account _len of unlimited polymorphic entities, so that span
@@ -11972,18 +12039,18 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo 
*loop,
   tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
   gfc_add_expr_to_block (&fblock, tmp);
 
-  /* Make sure that the scalarizer data pointer is updated.  */
-  if (linfo->data && VAR_P (linfo->data))
-    {
-      tmp = gfc_conv_descriptor_data_get (desc);
-      gfc_add_modify (&fblock, linfo->data, tmp);
-    }
-
   /* Add the label for same shape lhs and rhs.  */
   tmp = build1_v (LABEL_EXPR, jump_label2);
   gfc_add_expr_to_block (&fblock, tmp);
 
-  return gfc_finish_block (&fblock);
+  tree realloc_code = gfc_finish_block (&fblock);
+
+  stmtblock_t result_block;
+  gfc_init_block (&result_block);
+  gfc_add_expr_to_block (&result_block, realloc_code);
+  update_reallocated_descriptor (&result_block, loop);
+
+  return gfc_finish_block (&result_block);
 }
 
 
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 3e0d763d2fb0..299acd3e3314 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -12875,11 +12875,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * 
expr2, bool init_flag,
   if (gfc_is_reallocatable_lhs (expr1))
     {
       lss->no_bounds_check = 1;
-      if (!(expr2->expr_type == EXPR_FUNCTION
-           && expr2->value.function.isym != NULL
-           && !(expr2->value.function.isym->elemental
-                || expr2->value.function.isym->conversion)))
-       lss->is_alloc_lhs = 1;
+      lss->is_alloc_lhs = 1;
     }
   else
     lss->no_bounds_check = expr1->no_bounds_check;
@@ -12943,6 +12939,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * 
expr2, bool init_flag,
       rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
     }
 
+  tree reallocation = NULL_TREE;
   if (lss != gfc_ss_terminator)
     {
       /* The assignment needs scalarization.  */
@@ -12961,8 +12958,12 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * 
expr2, bool init_flag,
       /* Walk the rhs.  */
       rss = gfc_walk_expr (expr2);
       if (rss == gfc_ss_terminator)
-       /* The rhs is scalar.  Add a ss for the expression.  */
-       rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+       {
+         /* The rhs is scalar.  Add a ss for the expression.  */
+         rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+         lss->is_alloc_lhs = 0;
+       }
+
       /* When doing a class assign, then the handle to the rhs needs to be a
         pointer to allow for polymorphism.  */
       if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
@@ -13011,6 +13012,14 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * 
expr2, bool init_flag,
          ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
        }
 
+      /* F2003: Allocate or reallocate lhs of allocatable array.  */
+      if (realloc_flag)
+       {
+         realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
+         ompws_flags &= ~OMPWS_SCALARIZER_WS;
+         reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1, 
expr2);
+       }
+
       /* Start the scalarized loop body.  */
       gfc_start_scalarized_body (&loop, &body);
     }
@@ -13319,15 +13328,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * 
expr2, bool init_flag,
          gfc_add_expr_to_block (&body, tmp);
        }
 
-      /* F2003: Allocate or reallocate lhs of allocatable array.  */
-      if (realloc_flag)
-       {
-         realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
-         ompws_flags &= ~OMPWS_SCALARIZER_WS;
-         tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
-         if (tmp != NULL_TREE)
-           gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
-       }
+      if (reallocation != NULL_TREE)
+       gfc_add_expr_to_block (&loop.code[loop.dimen - 1], reallocation);
 
       if (maybe_workshare)
        ompws_flags &= ~OMPWS_SCALARIZER_BODY;

Reply via email to