diff options
| -rw-r--r-- | gcc/fortran/trans-expr.cc | 54 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/intent_out_16.f90 | 89 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/intent_out_17.f90 | 46 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/intent_out_18.f90 | 31 |
4 files changed, 215 insertions, 5 deletions
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 30946ba..7017b65 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -6085,9 +6085,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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) { @@ -6117,6 +6118,32 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && 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) @@ -6680,7 +6707,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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 @@ -6776,6 +6803,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* 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. */ @@ -6816,7 +6844,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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 @@ -6830,6 +6859,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && 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 { @@ -6980,7 +7013,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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; @@ -7004,7 +7037,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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); } } } @@ -7101,6 +7134,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } } + /* 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); @@ -7499,6 +7542,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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); diff --git a/gcc/testsuite/gfortran.dg/intent_out_16.f90 b/gcc/testsuite/gfortran.dg/intent_out_16.f90 new file mode 100644 index 0000000..e8d635f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intent_out_16.f90 @@ -0,0 +1,89 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/intent_out_17.f90 b/gcc/testsuite/gfortran.dg/intent_out_17.f90 new file mode 100644 index 0000000..bc9208d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intent_out_17.f90 @@ -0,0 +1,46 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/intent_out_18.f90 b/gcc/testsuite/gfortran.dg/intent_out_18.f90 new file mode 100644 index 0000000..50f9948 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intent_out_18.f90 @@ -0,0 +1,31 @@ +! { 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 |