{
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;
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.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);
/* 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;
}
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,
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:
}
/* 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)
{
/* 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);
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
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" } }
projects / thirdparty / gcc.git / commitdiff
