fortran: Fix ICE and self-assignment bugs with recursive allocatable finalizers [PR90519]

Derived types with recursive allocatable components and FINAL procedures
trigger an ICE in gimplify_call_expr because the finalizer wrapper's result
symbol references itself (final->result = final), creating a cycle. This
patch creates a separate __result_<typename> symbol to break the cycle.

Self-assignment (a = a) with such types causes use-after-free because the
left-hand side is finalized before copying, destroying the source. This
patch adds detection using gfc_dep_compare_expr at compile time and pointer
comparison at runtime to skip finalization when lhs == rhs.

Parenthesized self-assignment (a = (a)) creates a temporary, defeating the
simple self-assignment detection. This patch adds strip_parentheses() to
look through INTRINSIC_PARENTHESES operators and ensure deep_copy is enabled
for such cases.

Test pr112459.f90 now expects 6 _final calls instead of 12 because separate
result symbols eliminate double-counting in tree dumps.

	PR fortran/90519

gcc/fortran/ChangeLog:

	* trans-expr.cc (strip_parentheses): New helper function to strip
	INTRINSIC_PARENTHESES operators from expressions.
	(is_runtime_conformable): Use strip_parentheses to handle cases
	like a = (a) when checking for self-assignment.
	(gfc_trans_assignment_1): Strip parentheses before checking if
	expr2 is a variable, ensuring deep_copy is enabled for cases like
	a = (a). Also strip parentheses when checking for self-assignment
	to avoid use-after-free in finalization.
	(gfc_trans_scalar_assign): Add comment about parentheses handling.
	* class.cc (generate_finalization_wrapper): Create separate result
	symbol for finalizer wrapper functions instead of self-referencing
	the procedure symbol, avoiding ICE in gimplify_call_expr.

gcc/testsuite/ChangeLog:

	* gfortran.dg/finalizer_recursive_alloc_1.f90: New test for ICE fix.
	* gfortran.dg/finalizer_recursive_alloc_2.f90: New execution test.
	* gfortran.dg/finalizer_self_assign.f90: New test for self-assignment
	including a = a, a = (a), and a = (((a))) cases using if/stop pattern.
	* gfortran.dg/pr112459.f90: Update to expect 6 _final calls instead
	of 12, reflecting corrected self-assignment behavior.

Signed-off-by: Christopher Albert <[email protected]>

Author: krystophny

gcc/fortran/class.cc

@@ -1733,10 +1733,12 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 {
   gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides;
   gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem;
+  gfc_symbol *result = NULL;
   gfc_component *comp;
   gfc_namespace *sub_ns;
   gfc_code *last_code, *block;
   char *name;
+  char *result_name;
   bool finalizable_comp = false;
   gfc_expr *ancestor_wrapper = NULL, *rank;
   gfc_iterator *iter;
@@ -1824,14 +1826,33 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   final->attr.function = 1;
   final->attr.pure = 0;
   final->attr.recursive = 1;
-  final->result = final;
   final->ts.type = BT_INTEGER;
   final->ts.kind = 4;
   final->attr.artificial = 1;
   final->attr.always_explicit = 1;
   final->attr.if_source = IFSRC_DECL;
   if (ns->proc_name->attr.flavor == FL_MODULE)
     final->module = ns->proc_name->name;
+
+  /* Create a separate result symbol instead of using final->result = final.
+     Self-referencing result symbols (final->result = final) create a cycle
+     in the symbol structure that causes an ICE in gimplify_call_expr when
+     the finalizer wrapper is used as a procedure pointer initializer.  */
+  result_name = xasprintf ("__result_%s", tname);
+  if (gfc_get_symbol (result_name, sub_ns, &result) != 0)
+    gfc_internal_error ("Failed to create finalizer result symbol");
+  free (result_name);
+
+  if (!gfc_add_flavor (&result->attr, FL_VARIABLE, result->name,
+		       &gfc_current_locus)
+      || !gfc_add_result (&result->attr, result->name, &gfc_current_locus))
+    gfc_internal_error ("Failed to set finalizer result attributes");
+
+  result->ts = final->ts;
+  result->attr.artificial = 1;
+  gfc_set_sym_referenced (result);
+  gfc_commit_symbol (result);
+  final->result = result;
   gfc_set_sym_referenced (final);
   gfc_commit_symbol (final);
 
@@ -1959,7 +1980,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 
   /* Set return value to 0.  */
   last_code = gfc_get_code (EXEC_ASSIGN);
-  last_code->expr1 = gfc_lval_expr_from_sym (final);
+  last_code->expr1 = gfc_lval_expr_from_sym (result);
   last_code->expr2 = gfc_get_int_expr (4, NULL, 0);
   sub_ns->code = last_code;
 

gcc/fortran/trans-expr.cc

@@ -11697,7 +11697,17 @@ gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
 	}
 
       gfc_add_block_to_block (&block, &rse->pre);
-      gfc_add_block_to_block (&block, &lse->finalblock);
+
+      /* Skip finalization for self-assignment.  */
+      if (deep_copy && lse->finalblock.head)
+	{
+	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
+			  gfc_finish_block (&lse->finalblock));
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+      else
+	gfc_add_block_to_block (&block, &lse->finalblock);
+
       gfc_add_block_to_block (&block, &lse->pre);
 
       gfc_add_modify (&block, lse->expr,
@@ -12683,12 +12693,30 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
    to make sure we do not check for reallocation unneccessarily.  */
 
 
+/* Strip parentheses from an expression to get the underlying variable.
+   This is needed for self-assignment detection since (a) creates a
+   parentheses operator node.  */
+
+static gfc_expr *
+strip_parentheses (gfc_expr *expr)
+{
+  while (expr->expr_type == EXPR_OP
+	 && expr->value.op.op == INTRINSIC_PARENTHESES)
+    expr = expr->value.op.op1;
+  return expr;
+}
+
+
 static bool
 is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
 {
   gfc_actual_arglist *a;
   gfc_expr *e1, *e2;
 
+  /* Strip parentheses to handle cases like a = (a).  */
+  expr1 = strip_parentheses (expr1);
+  expr2 = strip_parentheses (expr2);
+
   switch (expr2->expr_type)
     {
     case EXPR_VARIABLE:
@@ -13390,10 +13418,15 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
     }
 
   /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
-     after evaluation of the rhs and before reallocation.  */
+     after evaluation of the rhs and before reallocation.
+     Skip finalization for self-assignment to avoid use-after-free.
+     Strip parentheses from both sides to handle cases like a = (a).  */
   final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag);
-  if (final_expr && !(expr2->expr_type == EXPR_VARIABLE
-		      && expr2->symtree->n.sym->attr.artificial))
+  if (final_expr
+      && gfc_dep_compare_expr (strip_parentheses (expr1),
+			       strip_parentheses (expr2)) != 0
+      && !(strip_parentheses (expr2)->expr_type == EXPR_VARIABLE
+	   && strip_parentheses (expr2)->symtree->n.sym->attr.artificial))
     {
       if (lss == gfc_ss_terminator)
 	{
@@ -13416,13 +13449,18 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 
   /* If nothing else works, do it the old fashioned way!  */
   if (tmp == NULL_TREE)
-    tmp
-      = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
-				 gfc_expr_is_variable (expr2) || scalar_to_array
-				   || expr2->expr_type == EXPR_ARRAY,
-				 !(l_is_temp || init_flag) && dealloc,
-				 expr1->symtree->n.sym->attr.codimension,
-				 assoc_assign);
+    {
+      /* Strip parentheses to detect cases like a = (a) which need deep_copy.  */
+      gfc_expr *expr2_stripped = strip_parentheses (expr2);
+      tmp
+	= gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+				   gfc_expr_is_variable (expr2_stripped)
+				     || scalar_to_array
+				     || expr2->expr_type == EXPR_ARRAY,
+				   !(l_is_temp || init_flag) && dealloc,
+				   expr1->symtree->n.sym->attr.codimension,
+				   assoc_assign);
+    }
 
   /* Add the lse pre block to the body  */
   gfc_add_block_to_block (&body, &lse.pre);

gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_1.f90

@@ -0,0 +1,15 @@
+! { dg-do compile }
+! PR fortran/90519
+
+module pr90519_finalizer_mod
+  implicit none
+  type :: t
+     type(t), allocatable :: child
+  contains
+     final :: finalize_t
+  end type t
+contains
+  subroutine finalize_t(self)
+    type(t), intent(inout) :: self
+  end subroutine finalize_t
+end module pr90519_finalizer_mod

gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_2.f90

@@ -0,0 +1,32 @@
+! { dg-do run }
+! { dg-output " finalizing id\\s+0\\n finalizing id\\s+1\\n finalizer count =\\s+2\\n" }
+! PR fortran/90519
+
+module pr90519_finalizer_run_mod
+  implicit none
+  integer :: finalizer_count = 0
+  type :: tree_t
+     integer :: id = -1
+     type(tree_t), allocatable :: child
+  contains
+     final :: finalize_tree
+  end type tree_t
+contains
+  subroutine finalize_tree(self)
+    type(tree_t), intent(inout) :: self
+    finalizer_count = finalizer_count + 1
+    print *, 'finalizing id', self%id
+  end subroutine finalize_tree
+end module pr90519_finalizer_run_mod
+
+program test_finalizer
+  use pr90519_finalizer_run_mod
+  implicit none
+  block
+    type(tree_t) :: root
+    root%id = 0
+    allocate(root%child)
+    root%child%id = 1
+  end block
+  print *, 'finalizer count =', finalizer_count
+end program test_finalizer

gcc/testsuite/gfortran.dg/finalizer_self_assign.f90

@@ -0,0 +1,101 @@
+! { dg-do run }
+! Test self-assignment with recursive allocatable and finalizer
+! This should preserve allocatable components after a = a and a = (a)
+
+module self_assign_mod
+  implicit none
+  type :: node_t
+     integer :: value = 0
+     type(node_t), allocatable :: next
+  contains
+     final :: finalize_node
+  end type node_t
+contains
+  subroutine finalize_node(self)
+    type(node_t), intent(inout) :: self
+  end subroutine finalize_node
+end module self_assign_mod
+
+program test_self_assign
+  use self_assign_mod
+  implicit none
+
+  call test_simple_self_assign()
+  call test_parenthesized_self_assign()
+  call test_triple_parenthesized_self_assign()
+  call test_array_bounds()
+
+contains
+
+  subroutine test_simple_self_assign()
+    type(node_t) :: a
+
+    a%value = 100
+    allocate(a%next)
+    a%next%value = 200
+
+    ! Simple self-assignment should preserve all components
+    a = a
+
+    if (a%value /= 100) stop 1
+    if (.not. allocated(a%next)) stop 2
+    if (a%next%value /= 200) stop 3
+  end subroutine test_simple_self_assign
+
+  subroutine test_parenthesized_self_assign()
+    type(node_t) :: a
+
+    a%value = 100
+    allocate(a%next)
+    a%next%value = 200
+
+    ! Parenthesized self-assignment should also preserve all components
+    a = (a)
+
+    if (a%value /= 100) stop 4
+    if (.not. allocated(a%next)) stop 5
+    if (a%next%value /= 200) stop 6
+  end subroutine test_parenthesized_self_assign
+
+  subroutine test_triple_parenthesized_self_assign()
+    type(node_t) :: a
+
+    a%value = 100
+    allocate(a%next)
+    a%next%value = 200
+
+    ! Triple-nested parentheses should also work correctly
+    a = (((a)))
+
+    if (a%value /= 100) stop 7
+    if (.not. allocated(a%next)) stop 8
+    if (a%next%value /= 200) stop 9
+  end subroutine test_triple_parenthesized_self_assign
+
+  subroutine test_array_bounds()
+    type(node_t), allocatable :: b(:), c(:)
+
+    ! Test array bounds behavior with parentheses.
+    ! Per F2023:10.2.1.3, lbound((b),1) = 1 even if lbound(b,1) = 5.
+    ! However, for b = (b) where b is already allocated with the right shape,
+    ! NO reallocation occurs, so bounds are preserved.
+    ! For c = (b) where c is unallocated, c gets allocated with default bounds.
+    allocate(b(5:5))
+    b(5)%value = 500
+
+    ! Self-assignment with parentheses: no reallocation (same shape), bounds preserved
+    b = (b)
+    if (.not. allocated(b)) stop 10
+    if (lbound(b, 1) /= 5) stop 11  ! Bounds preserved (no realloc)
+    if (ubound(b, 1) /= 5) stop 12
+    if (b(5)%value /= 500) stop 13
+
+    ! Assignment to unallocated array: gets default (1-based) bounds
+    c = (b)
+    if (.not. allocated(c)) stop 14
+    if (lbound(c, 1) /= 1) stop 15  ! Default bounds (new allocation)
+    if (ubound(c, 1) /= 1) stop 16
+    if (c(1)%value /= 500) stop 17
+  end subroutine test_array_bounds
+
+end program test_self_assign

gcc/testsuite/gfortran.dg/pr112459.f90

@@ -34,4 +34,6 @@ program myprog
   print *,"After allocation"
 end program myprog
 ! Final subroutines were called with std=gnu and -w = > 14 "_final"s.
-! { dg-final { scan-tree-dump-times "_final" 12 "original" } }
+! Count reduced from 12 after PR90519 fix - separate result symbols
+! disambiguate procedure references from result variables.
+! { dg-final { scan-tree-dump-times "_final" 6 "original" } }