[gcc r14-10363] Fortran: fix passing of optional dummy as actual to optional argument [PR55978]

[Harald Anlauf]

https://gcc.gnu.org/g:9f147487de660f026e2fb1281e1a1800f58b3bdd

commit r14-10363-g9f147487de660f026e2fb1281e1a1800f58b3bdd
Author: Harald Anlauf <anlauf@gmx.de>
Date:   Sun Jun 23 22:36:43 2024 +0200

    Fortran: fix passing of optional dummy as actual to optional argument [PR55978]
    
    gcc/fortran/ChangeLog:
    
            PR fortran/55978
            * trans-array.cc (gfc_conv_array_parameter): Do not dereference
            data component of a missing allocatable dummy array argument for
            passing as actual to optional dummy.  Harden logic of presence
            check for optional pointer dummy by using TRUTH_ANDIF_EXPR instead
            of TRUTH_AND_EXPR.
    
    gcc/testsuite/ChangeLog:
    
            PR fortran/55978
            * gfortran.dg/optional_absent_12.f90: New test.
    
    (cherry picked from commit f02c70dafd384f0c44d7a0920f4a75a30e267045)

Diff:
---
 gcc/fortran/trans-array.cc                       | 20 ++++++++++++----
 gcc/testsuite/gfortran.dg/optional_absent_12.f90 | 30 ++++++++++++++++++++++++
 2 files changed, 46 insertions(+), 4 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index a15ff30e8f4..d4b16772de2 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8673,6 +8673,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
 	&& (sym->backend_decl != parent))
     this_array_result = false;
 
+  /* Passing an optional dummy argument as actual to an optional dummy?  */
+  bool pass_optional;
+  pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
+
   /* Passing address of the array if it is not pointer or assumed-shape.  */
   if (full_array_var && g77 && !this_array_result
       && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
@@ -8710,6 +8714,14 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
 	  if (size)
 	    array_parameter_size (&se->pre, tmp, expr, size);
 	  se->expr = gfc_conv_array_data (tmp);
+	  if (pass_optional)
+	    {
+	      tree cond = gfc_conv_expr_present (sym);
+	      se->expr = build3_loc (input_location, COND_EXPR,
+				     TREE_TYPE (se->expr), cond, se->expr,
+				     fold_convert (TREE_TYPE (se->expr),
+						   null_pointer_node));
+	    }
           return;
         }
     }
@@ -8959,8 +8971,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
 	  tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
 				 fold_convert (TREE_TYPE (tmp), ptr), tmp);
 
-	  if (fsym && fsym->attr.optional && sym && sym->attr.optional)
-	    tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+	  if (pass_optional)
+	    tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
 				   logical_type_node,
 				   gfc_conv_expr_present (sym), tmp);
 
@@ -8994,8 +9006,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
       tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
 			     fold_convert (TREE_TYPE (tmp), ptr), tmp);
 
-      if (fsym && fsym->attr.optional && sym && sym->attr.optional)
-	tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+      if (pass_optional)
+	tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
 			       logical_type_node,
 			       gfc_conv_expr_present (sym), tmp);
 
diff --git a/gcc/testsuite/gfortran.dg/optional_absent_12.f90 b/gcc/testsuite/gfortran.dg/optional_absent_12.f90
new file mode 100644
index 00000000000..1e61d91fb6d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/optional_absent_12.f90
@@ -0,0 +1,30 @@
+! { dg-do run }
+! { dg-additional-options "-fcheck=array-temps" }
+!
+! PR fortran/55978 - comment#19
+!
+! Test passing of (missing) optional dummy to optional array argument
+
+program test
+  implicit none
+  integer, pointer :: p(:) => null()
+  call one (p)
+  call one (null())
+  call one ()
+  call three ()
+contains
+  subroutine one (y)
+    integer, pointer, optional, intent(in) :: y(:)
+    call two (y)
+  end subroutine one
+
+  subroutine three (z)
+    integer, allocatable, optional, intent(in) :: z(:)
+    call two (z)
+  end subroutine three
+
+  subroutine two (x)
+    integer, optional, intent(in) :: x(*)
+    if (present (x)) stop 1
+  end subroutine two
+end