Fortran: Suppress bogus used uninitialized warnings [PR108889].

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

gcc/fortran
	PR fortran/108889
	* gfortran.h: Add bit field 'allocated_in_scope' to gfc_symbol.
	* trans-array.cc (gfc_array_allocate): Set 'allocated_in_scope'
	after allocation if not a component reference.
	(gfc_alloc_allocatable_for_assignment): If 'allocated_in_scope'
	not set, not a component ref and not allocated, set the array
	bounds and offset to give zero length in all dimensions. Then
	set allocated_in_scope.

gcc/testsuite/
	PR fortran/108889
	* gfortran.dg/pr108889.f90: New test.

gcc/fortran/gfortran.h

@@ -1950,6 +1950,10 @@ 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;
 
   /* Reference counter, used for memory management.
 

gcc/fortran/trans-array.cc

@@ -6580,6 +6580,8 @@ 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;
 }
 
@@ -11060,6 +11062,8 @@ 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;
@@ -11260,6 +11264,45 @@ 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));

gcc/testsuite/gfortran.dg/pr108889.f90

@@ -0,0 +1,43 @@
+! { dg-do compile }
+! { dg-options "-Wall -fdump-tree-original" }
+!
+! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+!
+program main
+  implicit none
+
+  type :: struct
+    real, allocatable :: var(:)
+  end type struct
+
+  type(struct) :: single
+  real, allocatable :: ref1(:), ref2(:), ref3(:), ref4(:)
+
+  ref2 = [1,2,3,4,5]    ! Warnings here
+
+  single%var = ref2     ! No warnings for components
+  ref1 = single%var     ! Warnings here
+  ref1 = [1,2,3,4,5]    ! Should not add to tree dump count
+
+  allocate (ref3(5))
+  ref3 = single%var     ! No warnings following allocation
+
+  call set_ref4
+
+  call test (ref1)
+  call test (ref2)
+  call test (ref3)
+  call test (ref4)
+
+contains
+  subroutine test (arg)
+    real, allocatable :: arg(:)
+    if (size(arg) /= size(single%var)) stop 1
+    if (lbound(arg, 1) /= 1) stop 2
+    if (any (arg /= single%var)) stop 3
+  end
+  subroutine set_ref4
+    ref4 = single%var   ! Warnings in contained scope
+  end
+end
+! { df-final { scan-tree-dump-times "ubound = 0" 3 "original" } }