public inbox for gcc-patches@gcc.gnu.org
 help / color / mirror / Atom feed
* [PATCH] Fortran: fixes for procedures with ALLOCATABLE,INTENT(OUT) arguments [PR92178]
@ 2023-07-02 20:38 Harald Anlauf
  2023-07-03 11:46 ` Mikael Morin
  0 siblings, 1 reply; 20+ messages in thread
From: Harald Anlauf @ 2023-07-02 20:38 UTC (permalink / raw)
  To: fortran, gcc-patches

[-- Attachment #1: Type: text/plain, Size: 779 bytes --]

Dear all,

the attached patch fixes a long-standing issue with the
order of evaluation of procedure argument expressions and
deallocation of allocatable actual arguments passed to
allocatable dummies with intent(out) attribute.

It is based on an initial patch by Steve, handles issues
pointed out by Tobias, and includes a suggestion by Tobias
to scan the procedure arguments first to decide whether the
creation of temporaries is needed.

There is one unresolved issue left that might be more
general: it appears to affect character arguments (only)
in that quite often there still is no temporary generated.
I haven't found the reason why and would like to defer this,
unless someone has a good suggestion.

Regtested on x86_64-pc-linux-gnu. OK for mainline?

Thanks,
Harald


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr92178.diff --]
[-- Type: text/x-patch, Size: 9059 bytes --]

From 609ba636927811cddc74fb815cb18809c7d33565 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
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 <kargl@gcc.gnu.org>
---
 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


^ permalink raw reply	[flat|nested] 20+ messages in thread

end of thread, other threads:[~2023-07-08 14:20 UTC | newest]

Thread overview: 20+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-07-02 20:38 [PATCH] Fortran: fixes for procedures with ALLOCATABLE,INTENT(OUT) arguments [PR92178] Harald Anlauf
2023-07-03 11:46 ` Mikael Morin
2023-07-03 20:49   ` Harald Anlauf
2023-07-03 20:49     ` Harald Anlauf
2023-07-03 23:56     ` Steve Kargl
2023-07-04  9:26       ` Mikael Morin
2023-07-04 15:50         ` Steve Kargl
2023-07-04 13:35     ` Mikael Morin
2023-07-04 19:00       ` Harald Anlauf
2023-07-04 19:00         ` Harald Anlauf
2023-07-04 19:37         ` Mikael Morin
2023-07-05 14:54           ` Mikael Morin
2023-07-05 20:36             ` Harald Anlauf
2023-07-05 20:36               ` Harald Anlauf
2023-07-07 12:21               ` Mikael Morin
2023-07-07 18:23                 ` Harald Anlauf
2023-07-07 18:23                   ` Harald Anlauf
2023-07-08 12:07                   ` Mikael Morin
2023-07-08 14:20                     ` Harald Anlauf
2023-07-08 14:20                       ` Harald Anlauf

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).