else
info = NULL;
- stmtblock_t post, clobbers;
+ stmtblock_t post, clobbers, dealloc_blk;
gfc_init_block (&post);
gfc_init_block (&clobbers);
+ gfc_init_block (&dealloc_blk);
gfc_init_interface_mapping (&mapping);
if (!comp)
{
&& UNLIMITED_POLY (sym)
&& comp && (strcmp ("_copy", comp->name) == 0);
+ /* Scan for allocatable actual arguments passed to allocatable dummy
+ arguments with INTENT(OUT). As the corresponding actual arguments are
+ deallocated before execution of the procedure, we evaluate actual
+ argument expressions to avoid problems with possible dependencies. */
+ bool force_eval_args = false;
+ gfc_formal_arglist *tmp_formal;
+ for (arg = args, tmp_formal = formal; arg != NULL;
+ arg = arg->next, tmp_formal = tmp_formal ? tmp_formal->next : NULL)
+ {
+ e = arg->expr;
+ fsym = tmp_formal ? tmp_formal->sym : NULL;
+ if (e && fsym
+ && e->expr_type == EXPR_VARIABLE
+ && fsym->attr.intent == INTENT_OUT
+ && (fsym->ts.type == BT_CLASS && fsym->attr.class_ok
+ ? CLASS_DATA (fsym)->attr.allocatable
+ : fsym->attr.allocatable)
+ && e->symtree
+ && e->symtree->n.sym
+ && gfc_variable_attr (e, NULL).allocatable)
+ {
+ force_eval_args = true;
+ break;
+ }
+ }
+
/* Evaluate the arguments. */
for (arg = args, argc = 0; arg != NULL;
arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
else
tmp = gfc_finish_block (&block);
- gfc_add_expr_to_block (&se->pre, tmp);
+ gfc_add_expr_to_block (&dealloc_blk, tmp);
}
/* A class array element needs converting back to be a
/* Pass a class array. */
parmse.use_offset = 1;
gfc_conv_expr_descriptor (&parmse, e);
+ bool defer_to_dealloc_blk = false;
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
else
tmp = gfc_finish_block (&block);
- gfc_add_expr_to_block (&se->pre, tmp);
+ gfc_add_expr_to_block (&dealloc_blk, tmp);
+ defer_to_dealloc_blk = true;
}
/* The conversion does not repackage the reference to a class
&& e->symtree->n.sym->attr.optional,
CLASS_DATA (fsym)->attr.class_pointer
|| CLASS_DATA (fsym)->attr.allocatable);
+
+ /* Defer repackaging after deallocation. */
+ if (defer_to_dealloc_blk)
+ gfc_add_block_to_block (&dealloc_blk, &parmse.pre);
}
else
{
build_empty_stmt (input_location));
}
if (tmp != NULL_TREE)
- gfc_add_expr_to_block (&se->pre, tmp);
+ gfc_add_expr_to_block (&dealloc_blk, tmp);
}
tmp = parmse.expr;
void_type_node,
gfc_conv_expr_present (e->symtree->n.sym),
tmp, build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se->pre, tmp);
+ gfc_add_expr_to_block (&dealloc_blk, tmp);
}
}
}
}
}
+ /* If any actual argument of the procedure is allocatable and passed
+ to an allocatable dummy with INTENT(OUT), we conservatively
+ evaluate actual argument expressions before deallocations are
+ performed and the procedure is executed. May create temporaries.
+ This ensures we conform to F2023:15.5.3, 15.5.4. */
+ if (e && fsym && force_eval_args
+ && fsym->attr.intent != INTENT_OUT
+ && !gfc_is_constant_expr (e))
+ parmse.expr = gfc_evaluate_now (parmse.expr, &parmse.pre);
+
if (fsym && need_interface_mapping && e)
gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
vec_safe_push (arglist, parmse.expr);
}
+ gfc_add_block_to_block (&se->pre, &dealloc_blk);
gfc_add_block_to_block (&se->pre, &clobbers);
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
--- /dev/null
+! { dg-do run }
+!
+! PR fortran/92178
+! Re-order argument deallocation
+
+program p
+ implicit none
+ integer, allocatable :: a(:)
+ class(*), allocatable :: c(:)
+ type t
+ integer, allocatable :: a(:)
+ end type t
+ type(t) :: b
+ integer :: k = -999
+
+ ! Test based on original PR
+ a = [1]
+ call assign (a, (max(a(1),0)))
+ if (allocated (a)) stop 9
+ if (k /= 1) stop 10
+
+ ! Additional variations based on suggestions by Tobias Burnus
+ ! to check that argument expressions are evaluated early enough
+ a = [1, 2]
+ call foo (allocated (a), size (a), test (a), a, allocated (a))
+ if (allocated (a)) stop 11
+
+ a = [1, 2]
+ k = 1
+ call foo (allocated (a), size (a), test (k*a), a, allocated (a))
+ if (allocated (a)) stop 12
+
+ b% a = [1, 2]
+ call foo (allocated (b% a), size (b% a), test (b% a), b% a, allocated (b% a))
+ if (allocated (b% a)) stop 13
+
+ c = [3, 4]
+ call bar (allocated (c), size (c), test2 (c), c, &
+ allocated (c), size (c), test2 (c) )
+ if (allocated (c)) stop 14
+
+contains
+
+ subroutine assign (a, i)
+ integer, allocatable, intent(out) :: a(:)
+ integer, value :: i
+ k = i
+ end subroutine
+
+ subroutine foo (alloc, sz, tst, x, alloc2)
+ logical, value :: alloc, tst
+ integer, value :: sz
+ logical :: alloc2
+ integer, allocatable, intent(out) :: x(:)
+ if (allocated (x)) stop 1
+ if (.not. alloc) stop 2
+ if (sz /= 2) stop 3
+ if (.not. tst) stop 4
+ if (.not. alloc2) stop 15
+ end subroutine foo
+ !
+ logical function test (zz)
+ integer :: zz(2)
+ test = zz(2) == 2
+ end function test
+ !
+ subroutine bar (alloc, sz, tst, x, alloc2, sz2, tst2)
+ logical, value :: alloc, tst, alloc2, tst2
+ integer, value :: sz, sz2
+ class(*), allocatable, intent(out) :: x(:)
+ if (allocated (x)) stop 5
+ if (.not. alloc) stop 6
+ if (sz /= 2) stop 7
+ if (.not. tst) stop 8
+ if (.not. alloc2) stop 16
+ if (sz2 /= 2) stop 17
+ if (.not. tst2) stop 18
+ end subroutine bar
+ !
+ logical function test2 (zz)
+ class(*), intent(in) :: zz(:)
+ select type (zz)
+ type is (integer)
+ test2 = zz(2) == 4
+ class default
+ stop 99
+ end select
+ end function test2
+end
--- /dev/null
+! { dg-do run }
+!
+! PR fortran/92178
+! Contributed by Tobias Burnus
+
+program foo
+ implicit none (type, external)
+
+ type t
+ end type t
+
+ type, extends(t) :: t2
+ end type t2
+
+ type(t2) :: x2
+ class(t), allocatable :: aa
+
+ call check_intentout_false(allocated(aa), aa, &
+ allocated(aa))
+ if (allocated(aa)) stop 1
+
+ allocate(t2 :: aa)
+ if (.not.allocated(aa)) stop 2
+ if (.not.same_type_as(aa, x2)) stop 3
+ call check_intentout_true(allocated(aa), (same_type_as(aa, x2)), aa, &
+ allocated(aa), (same_type_as(aa, x2)))
+ if (allocated(aa)) stop 4
+
+contains
+ subroutine check_intentout_false(alloc1, yy, alloc2)
+ logical, value :: alloc1, alloc2
+ class(t), allocatable, intent(out) :: yy
+ if (allocated(yy)) stop 11
+ if (alloc1) stop 12
+ if (alloc2) stop 13
+ end subroutine check_intentout_false
+ subroutine check_intentout_true(alloc1, same1, zz, alloc2, same2)
+ logical, value :: alloc1, alloc2, same1, same2
+ class(t), allocatable, intent(out) :: zz
+ if (allocated(zz)) stop 21
+ if (.not.alloc1) stop 22
+ if (.not.alloc2) stop 23
+ if (.not.same1) stop 24
+ if (.not.same2) stop 25
+ end subroutine check_intentout_true
+end program
--- /dev/null
+! { dg-do run }
+!
+! PR fortran/92178
+! Contributed by Mikael Morin
+
+program p
+ implicit none
+ type t
+ integer :: i
+ integer, pointer :: pi
+ end type t
+ integer, target :: j
+ type(t), allocatable :: ta
+ j = 1
+ ta = t(2, j)
+ call assign(ta, id(ta%pi))
+ if (ta%i /= 1) stop 1
+ if (associated(ta%pi)) stop 2
+contains
+ subroutine assign(a, b)
+ type(t), intent(out), allocatable :: a
+ integer, intent(in) , value :: b
+ allocate(a)
+ a%i = b
+ a%pi => null()
+ end subroutine assign
+ function id(a)
+ integer, pointer :: id, a
+ id => a
+ end function id
+end program p
projects / thirdparty / gcc.git / commitdiff
