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 --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 3dc521fab9ad6108492887229750eb29a6a6c3c9..67abca9f6ba80fa1f2d24d8f5045de7492c1047e 100644 (file)
--- 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 (file)
index 0000000..1f63def
--- /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