[gcc r14-8479] Fortran: NULL actual to optional dummy with VALUE attribute [PR113377]

[Harald Anlauf]

https://gcc.gnu.org/g:c4773944bb3bec712b4002a2e599409301e50b11

commit r14-8479-gc4773944bb3bec712b4002a2e599409301e50b11
Author: Harald Anlauf <anlauf@gmx.de>
Date:   Thu Jan 25 22:19:10 2024 +0100

    Fortran: NULL actual to optional dummy with VALUE attribute [PR113377]
    
    gcc/fortran/ChangeLog:
    
            PR fortran/113377
            * trans-expr.cc (conv_dummy_value): Treat NULL actual argument to
            optional dummy with the VALUE attribute as not present.
            (gfc_conv_procedure_call): Likewise.
    
    gcc/testsuite/ChangeLog:
    
            PR fortran/113377
            * gfortran.dg/optional_absent_11.f90: New test.

Diff:
---
 gcc/fortran/trans-expr.cc                        | 11 ++-
 gcc/testsuite/gfortran.dg/optional_absent_11.f90 | 99 ++++++++++++++++++++++++
 2 files changed, 108 insertions(+), 2 deletions(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 3dc521fab9ad..67abca9f6ba8 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6086,7 +6086,7 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
   gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension);
 
   /* Absent actual argument for optional scalar dummy.  */
-  if (e == NULL && fsym->attr.optional && !fsym->attr.dimension)
+  if ((e == NULL || e->expr_type == EXPR_NULL) && fsym->attr.optional)
     {
       /* For scalar arguments with VALUE attribute which are passed by
 	 value, pass "0" and a hidden argument for the optional status.  */
@@ -6354,7 +6354,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  e->ts = temp_ts;
 	}
 
-      if (e == NULL)
+      if (e == NULL
+	  || (e->expr_type == EXPR_NULL
+	      && fsym
+	      && fsym->attr.value
+	      && fsym->attr.optional
+	      && !fsym->attr.dimension
+	      && fsym->ts.type != BT_DERIVED
+	      && fsym->ts.type != BT_CLASS))
 	{
 	  if (se->ignore_optional)
 	    {
diff --git a/gcc/testsuite/gfortran.dg/optional_absent_11.f90 b/gcc/testsuite/gfortran.dg/optional_absent_11.f90
new file mode 100644
index 000000000000..1f63def46fa9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/optional_absent_11.f90
@@ -0,0 +1,99 @@
+! { dg-do run }
+! PR fortran/113377
+!
+! Test that a NULL actual argument to an optional dummy is not present
+! (see also F2018:15.5.2.12 on argument presence)
+
+program test_null_actual_is_absent
+  implicit none
+  integer   :: k(4) = 1
+  character :: c(4) = "#"
+  call one   (k)
+  call three (c)
+contains
+  subroutine one (i)
+    integer, intent(in)  :: i(4)
+    integer              :: kk = 2
+    integer, allocatable :: aa
+    integer, pointer     :: pp => NULL()
+    print *, "Scalar integer"
+    call two     (kk, aa)
+    call two     (kk, pp)
+    call two     (kk, NULL())
+    call two     (kk, NULL(aa))
+    call two     (kk, NULL(pp))
+    print *, "Elemental integer"
+    call two     (i,  aa)
+    call two     (i,  pp)
+    call two     (i,  NULL())
+    call two     (i,  NULL(aa))
+    call two     (i,  NULL(pp))
+    print *, "Scalar integer; value"
+    call two_val (kk, aa)
+    call two_val (kk, pp)
+    call two_val (kk, NULL())
+    call two_val (kk, NULL(aa))
+    call two_val (kk, NULL(pp))
+    print *, "Elemental integer; value"
+    call two_val (i,  aa)
+    call two_val (i,  pp)
+    call two_val (i,  NULL())
+    call two_val (i,  NULL(aa))
+    call two_val (i,  NULL(pp))
+  end
+
+  elemental subroutine two (i, j)
+    integer, intent(in)           :: i
+    integer, intent(in), optional :: j
+    if (present (j)) error stop 11
+  end
+
+  elemental subroutine two_val (i, j)
+    integer, intent(in)           :: i
+    integer, value,      optional :: j
+    if (present (j)) error stop 12
+  end
+
+  subroutine three (y)
+    character, intent(in)  :: y(4)
+    character              :: zz = "*"
+    character, allocatable :: aa
+    character, pointer     :: pp => NULL()
+    print *, "Scalar character"
+    call four     (zz, aa)
+    call four     (zz, pp)
+    call four     (zz, NULL())
+    call four     (zz, NULL(aa))
+    call four     (zz, NULL(pp))
+    print *, "Elemental character"
+    call four     (y,  aa)
+    call four     (y,  pp)
+    call four     (y,  NULL())
+    call four     (y,  NULL(aa))
+    call four     (y,  NULL(pp))
+    print *, "Scalar character; value"
+    call four_val (zz, aa)
+    call four_val (zz, pp)
+    call four_val (zz, NULL())
+    call four_val (zz, NULL(aa))
+    call four_val (zz, NULL(pp))
+    print *, "Elemental character; value"
+    call four_val (y,  aa)
+    call four_val (y,  pp)
+    call four_val (y,  NULL())
+    call four_val (y,  NULL(aa))
+    call four_val (y,  NULL(pp))
+  end
+
+  elemental subroutine four (i, j)
+    character, intent(in)           :: i
+    character, intent(in), optional :: j
+    if (present (j)) error stop 21
+  end
+
+  elemental subroutine four_val (i, j)
+    character, intent(in)           :: i
+    character, value,      optional :: j
+    if (present (j)) error stop 22
+  end
+end