From: Harald Anlauf <anlauf@gmx.de>
Date: Thu, 16 Sep 2021 18:12:21 +0000 (+0200)
Subject: Fortran - fix handling of optional allocatable DT arguments with INTENT(OUT)
X-Git-Tag: basepoints/gcc-13~4729
X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=cfea7b86f2430b9cb8018379b071f4004233119c;p=thirdparty%2Fgcc.git

Fortran - fix handling of optional allocatable DT arguments with INTENT(OUT)

gcc/fortran/ChangeLog:

	PR fortran/102287
	* trans-expr.c (gfc_conv_procedure_call): Wrap deallocation of
	allocatable components of optional allocatable derived type
	procedure arguments with INTENT(OUT) into a presence check.

gcc/testsuite/ChangeLog:

	PR fortran/102287
	* gfortran.dg/intent_out_14.f90: New test.
---

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 18d665192f0d..4a81f4695d9a 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6548,6 +6548,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		    // deallocate the components first
 		    tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
 						     parmse.expr, e->rank);
+		    /* But check whether dummy argument is optional.  */
+		    if (tmp != NULL_TREE
+			&& fsym->attr.optional
+			&& e->expr_type == EXPR_VARIABLE
+			&& e->symtree->n.sym->attr.optional)
+		      {
+			tree present;
+			present = gfc_conv_expr_present (e->symtree->n.sym);
+			tmp = build3_v (COND_EXPR, present, tmp,
+					build_empty_stmt (input_location));
+		      }
 		    if (tmp != NULL_TREE)
 		      gfc_add_expr_to_block (&se->pre, tmp);
 		  }
diff --git a/gcc/testsuite/gfortran.dg/intent_out_14.f90 b/gcc/testsuite/gfortran.dg/intent_out_14.f90
new file mode 100644
index 000000000000..e59946350086
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/intent_out_14.f90
@@ -0,0 +1,24 @@
+! { dg-do run }
+! PR fortran/102287 - optional allocatable DT array arguments (intent out)
+
+module m
+  type t
+     integer, allocatable :: a
+  end type t
+contains
+  subroutine a (x, v)
+    type(t), optional, allocatable, intent(out) :: x(:)
+    type(t), optional,              intent(out) :: v(:)
+    call b (x, v)
+  end subroutine a
+
+  subroutine b (y, w)
+    type(t), optional, allocatable, intent(out) :: y(:)
+    type(t), optional,              intent(out) :: w(:)
+  end subroutine b
+end module m
+
+program p
+  use m
+  call a ()
+end