From 609ba636927811cddc74fb815cb18809c7d33565 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Sun, 2 Jul 2023 22:14:19 +0200 Subject: [PATCH] Fortran: fixes for procedures with ALLOCATABLE,INTENT(OUT) arguments [PR92178] gcc/fortran/ChangeLog: PR fortran/92178 * trans-expr.cc (gfc_conv_procedure_call): Check procedures for allocatable dummy arguments with INTENT(OUT) and move deallocation of actual arguments after evaluation of argument expressions before the procedure is executed. gcc/testsuite/ChangeLog: PR fortran/92178 * gfortran.dg/pr92178.f90: New test. * gfortran.dg/pr92178_2.f90: New test. Co-authored-by: Steven G. Kargl --- gcc/fortran/trans-expr.cc | 52 ++++++++++++++-- gcc/testsuite/gfortran.dg/pr92178.f90 | 83 +++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/pr92178_2.f90 | 46 ++++++++++++++ 3 files changed, 177 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pr92178.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr92178_2.f90 diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 30946ba3f63..16e8f037cfc 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,33 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && UNLIMITED_POLY (sym) && comp && (strcmp ("_copy", comp->name) == 0); + /* First scan argument list 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 +6708,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 @@ -6980,7 +7008,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 +7032,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 +7129,21 @@ 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 all actual argument expressions before deallocations are + performed and the procedure is executed. This ensures we conform + to F2023:15.5.3, 15.5.4. Create temporaries except for constants, + variables, and functions returning pointers that can appear in a + variable definition context. */ + if (e && fsym && force_eval_args + && e->expr_type != EXPR_VARIABLE + && !gfc_is_constant_expr (e) + && (e->expr_type != EXPR_FUNCTION + || !(gfc_expr_attr (e).pointer + || gfc_expr_attr (e).proc_pointer))) + 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/pr92178.f90 b/gcc/testsuite/gfortran.dg/pr92178.f90 new file mode 100644 index 00000000000..de3998d6b8c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr92178.f90 @@ -0,0 +1,83 @@ +! { 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) + if (allocated (a)) stop 11 + + a = [1, 2] + k = 1 + call foo (allocated (a), size (a), test (k*a), a) + if (allocated (a)) stop 12 + + b% a = [1, 2] + call foo (allocated (b% a), size (b% a), test (b% a), b% a) + if (allocated (b% a)) stop 13 + + c = [3, 4] + call bar (allocated (c), size (c), test2 (c), 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) + logical, value :: alloc, tst + integer, value :: sz + 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 + end subroutine foo + ! + logical function test (zz) + integer :: zz(2) + test = zz(2) == 2 + end function test + ! + subroutine bar (alloc, sz, tst, x) + logical, value :: alloc, tst + integer, value :: sz + 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 + 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/pr92178_2.f90 b/gcc/testsuite/gfortran.dg/pr92178_2.f90 new file mode 100644 index 00000000000..bc9208dcf6d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr92178_2.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 -- 2.35.3