From f6a65138391c902d2782973665059d7d059a50d1 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Sat, 20 Jan 2024 22:18:02 +0100
Subject: [PATCH] Fortran: passing of optional scalar arguments with VALUE
 attribute [PR113377]

gcc/fortran/ChangeLog:

	PR fortran/113377
	* trans-expr.cc (gfc_conv_procedure_call): Fix handling of optional
	scalar arguments of intrinsic type with the VALUE attribute.

gcc/testsuite/ChangeLog:

	PR fortran/113377
	* gfortran.dg/optional_absent_9.f90: New test.
---
 gcc/fortran/trans-expr.cc                     |   5 +
 .../gfortran.dg/optional_absent_9.f90         | 324 ++++++++++++++++++
 2 files changed, 329 insertions(+)
 create mode 100644 gcc/testsuite/gfortran.dg/optional_absent_9.f90

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 9dd1f4086f4..2f47a75955c 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6526,6 +6526,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 			    gfc_init_se (&argse, NULL);
 			    argse.want_pointer = 1;
 			    gfc_conv_expr (&argse, e);
+			    if (e->symtree->n.sym->attr.dummy
+				&& POINTER_TYPE_P (TREE_TYPE (argse.expr)))
+			      argse.expr = gfc_build_addr_expr (NULL_TREE,
+								argse.expr);
 			    cond = fold_convert (TREE_TYPE (argse.expr),
 						 null_pointer_node);
 			    cond = fold_build2_loc (input_location, NE_EXPR,
@@ -7256,6 +7260,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      && e->symtree->n.sym->attr.optional
 	      && (((e->rank != 0 && elemental_proc)
 		   || e->representation.length || e->ts.type == BT_CHARACTER
+		   || (e->rank == 0 && e->symtree->n.sym->attr.value)
 		   || (e->rank != 0
 		       && (fsym == NULL
 			   || (fsym->as
diff --git a/gcc/testsuite/gfortran.dg/optional_absent_9.f90 b/gcc/testsuite/gfortran.dg/optional_absent_9.f90
new file mode 100644
index 00000000000..495a6c00d7f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/optional_absent_9.f90
@@ -0,0 +1,324 @@
+! { dg-do run }
+! PR fortran/113377
+!
+! Test passing of missing optional scalar dummies of intrinsic type
+
+module m_int
+  implicit none
+contains
+  subroutine test_int ()
+    integer :: k = 1
+    call one     (k)
+    call one_val (k)
+    call one_all (k)
+    call one_ptr (k)
+  end
+
+  subroutine one (i, j)
+    integer, intent(in)           :: i
+    integer             ,optional :: j
+    integer, allocatable :: aa
+    integer, pointer     :: pp => NULL()
+    if (present (j)) error stop "j is present"
+    call two     (i, j)
+    call two_val (i, j)
+    call two     (i, aa)
+    call two     (i, pp)
+  end
+
+  subroutine one_val (i, j)
+    integer, intent(in)           :: i
+    integer, value,      optional :: j
+    if (present (j)) error stop "j is present"
+    call two     (i, j)
+    call two_val (i, j)
+  end
+
+  subroutine one_all (i, j)
+    integer, intent(in)           :: i
+    integer, allocatable,optional :: j
+    if (present (j)) error stop "j is present"
+!   call two     (i, j)  ! invalid per F2018:15.5.2.12, par. 3, clause 8
+!   call two_val (i, j)  ! invalid (*) F2018:15.5.2.12, par. 3, clause 8
+    call two_all (i, j)
+  end
+! (*) gfortran argument passing conventions ("scalar dummy arguments of type
+! INTEGER, LOGICAL, REAL, COMPLEX, and CHARACTER(len=1) with VALUE attribute
+! pass the presence status separately") may still allow this case pass
+
+  subroutine one_ptr (i, j)
+    integer, intent(in)           :: i
+    integer, pointer    ,optional :: j
+    if (present (j)) error stop "j is present"
+!   call two     (i, j)  ! invalid per F2018:15.5.2.12, par. 3, clause 7
+!   call two_val (i, j)  ! invalid (*) F2018:15.5.2.12, par. 3, clause 7
+    call two_ptr (i, j)
+  end
+
+  subroutine two (i, j)
+    integer, intent(in)           :: i
+    integer, intent(in), optional :: j
+    if (present (j)) error stop 11
+  end
+
+  subroutine two_val (i, j)
+    integer, intent(in)           :: i
+    integer, value,      optional :: j
+    if (present (j)) error stop 12
+  end
+
+  subroutine two_all (i, j)
+    integer, intent(in)           :: i
+    integer, allocatable,optional :: j
+    if (present (j)) error stop 13
+  end
+
+  subroutine two_ptr (i, j)
+    integer, intent(in)           :: i
+    integer, pointer,    optional :: j
+    if (present (j)) error stop 14
+  end
+end
+
+module m_char
+  implicit none
+contains
+  subroutine test_char ()
+    character :: k = "#"
+    call one     (k)
+    call one_val (k)
+    call one_all (k)
+    call one_ptr (k)
+  end
+
+  subroutine one (i, j)
+    character, intent(in)           :: i
+    character             ,optional :: j
+    character, allocatable :: aa
+    character, pointer     :: pp => NULL()
+    if (present (j)) error stop "j is present"
+    call two     (i, j)
+    call two_val (i, j)
+    call two     (i, aa)
+    call two     (i, pp)
+  end
+
+  subroutine one_val (i, j)
+    character, intent(in)           :: i
+    character, value,      optional :: j
+    if (present (j)) error stop "j is present"
+    call two     (i, j)
+    call two_val (i, j)
+  end
+
+  subroutine one_all (i, j)
+    character, intent(in)           :: i
+    character, allocatable,optional :: j
+    if (present (j)) error stop "j is present"
+!   call two     (i, j)  ! invalid per F2018:15.5.2.12, par. 3, clause 8
+!   call two_val (i, j)  ! invalid (*) F2018:15.5.2.12, par. 3, clause 8
+    call two_all (i, j)
+  end
+! (*) gfortran argument passing conventions ("scalar dummy arguments of type
+! INTEGER, LOGICAL, REAL, COMPLEX, and CHARACTER(len=1) with VALUE attribute
+! pass the presence status separately") may still allow this case pass
+
+  subroutine one_ptr (i, j)
+    character, intent(in)           :: i
+    character, pointer    ,optional :: j
+    if (present (j)) error stop "j is present"
+!   call two     (i, j)  ! invalid per F2018:15.5.2.12, par. 3, clause 7
+!   call two_val (i, j)  ! invalid (*) F2018:15.5.2.12, par. 3, clause 7
+    call two_ptr (i, j)
+  end
+
+  subroutine two (i, j)
+    character, intent(in)           :: i
+    character, intent(in), optional :: j
+    if (present (j)) error stop 21
+  end
+
+  subroutine two_val (i, j)
+    character, intent(in)           :: i
+    character, value,      optional :: j
+    if (present (j)) error stop 22
+  end
+
+  subroutine two_all (i, j)
+    character, intent(in)           :: i
+    character, allocatable,optional :: j
+    if (present (j)) error stop 23
+  end
+
+  subroutine two_ptr (i, j)
+    character, intent(in)           :: i
+    character, pointer,    optional :: j
+    if (present (j)) error stop 24
+  end
+end
+
+module m_char4
+  implicit none
+contains
+  subroutine test_char4 ()
+    character(kind=4) :: k = 4_"#"
+    call one     (k)
+    call one_val (k)
+    call one_all (k)
+    call one_ptr (k)
+  end
+
+  subroutine one (i, j)
+    character(kind=4), intent(in)           :: i
+    character(kind=4)             ,optional :: j
+    character(kind=4), allocatable :: aa
+    character(kind=4), pointer     :: pp => NULL()
+    if (present (j)) error stop "j is present"
+    call two     (i, j)
+    call two_val (i, j)
+    call two     (i, aa)
+    call two     (i, pp)
+  end
+
+  subroutine one_val (i, j)
+    character(kind=4), intent(in)           :: i
+    character(kind=4), value,      optional :: j
+    if (present (j)) error stop "j is present"
+    call two     (i, j)
+    call two_val (i, j)
+  end
+
+  subroutine one_all (i, j)
+    character(kind=4), intent(in)           :: i
+    character(kind=4), allocatable,optional :: j
+    if (present (j)) error stop "j is present"
+!   call two     (i, j)  ! invalid per F2018:15.5.2.12, par. 3, clause 8
+!   call two_val (i, j)  ! invalid (*) F2018:15.5.2.12, par. 3, clause 8
+    call two_all (i, j)
+  end
+! (*) gfortran argument passing conventions ("scalar dummy arguments of type
+! INTEGER, LOGICAL, REAL, COMPLEX, and CHARACTER(KIND=4)(len=1) with VALUE attribute
+! pass the presence status separately") may still allow this case pass
+
+  subroutine one_ptr (i, j)
+    character(kind=4), intent(in)           :: i
+    character(kind=4), pointer    ,optional :: j
+    if (present (j)) error stop "j is present"
+!   call two     (i, j)  ! invalid per F2018:15.5.2.12, par. 3, clause 7
+!   call two_val (i, j)  ! invalid (*) F2018:15.5.2.12, par. 3, clause 7
+    call two_ptr (i, j)
+  end
+
+  subroutine two (i, j)
+    character(kind=4), intent(in)           :: i
+    character(kind=4), intent(in), optional :: j
+    if (present (j)) error stop 31
+  end
+
+  subroutine two_val (i, j)
+    character(kind=4), intent(in)           :: i
+    character(kind=4), value,      optional :: j
+    if (present (j)) error stop 32
+  end
+
+  subroutine two_all (i, j)
+    character(kind=4), intent(in)           :: i
+    character(kind=4), allocatable,optional :: j
+    if (present (j)) error stop 33
+  end
+
+  subroutine two_ptr (i, j)
+    character(kind=4), intent(in)           :: i
+    character(kind=4), pointer,    optional :: j
+    if (present (j)) error stop 34
+  end
+end
+
+module m_complex
+  implicit none
+contains
+  subroutine test_complex ()
+    complex :: k = 3.
+    call one     (k)
+    call one_val (k)
+    call one_all (k)
+    call one_ptr (k)
+  end
+
+  subroutine one (i, j)
+    complex, intent(in)           :: i
+    complex             ,optional :: j
+    complex, allocatable :: aa
+    complex, pointer     :: pp => NULL()
+    if (present (j)) error stop "j is present"
+    call two     (i, j)
+    call two_val (i, j)
+    call two     (i, aa)
+    call two     (i, pp)
+  end
+
+  subroutine one_val (i, j)
+    complex, intent(in)           :: i
+    complex, value,      optional :: j
+    if (present (j)) error stop "j is present"
+    call two     (i, j)
+    call two_val (i, j)
+  end
+
+  subroutine one_all (i, j)
+    complex, intent(in)           :: i
+    complex, allocatable,optional :: j
+    if (present (j)) error stop "j is present"
+!   call two     (i, j)  ! invalid per F2018:15.5.2.12, par. 3, clause 8
+!   call two_val (i, j)  ! invalid (*) F2018:15.5.2.12, par. 3, clause 8
+    call two_all (i, j)
+  end
+! (*) gfortran argument passing conventions ("scalar dummy arguments of type
+! COMPLEX, LOGICAL, REAL, COMPLEX, and CHARACTER(len=1) with VALUE attribute
+! pass the presence status separately") may still allow this case pass
+
+  subroutine one_ptr (i, j)
+    complex, intent(in)           :: i
+    complex, pointer    ,optional :: j
+    if (present (j)) error stop "j is present"
+!   call two     (i, j)  ! invalid per F2018:15.5.2.12, par. 3, clause 7
+!   call two_val (i, j)  ! invalid (*) F2018:15.5.2.12, par. 3, clause 7
+    call two_ptr (i, j)
+  end
+
+  subroutine two (i, j)
+    complex, intent(in)           :: i
+    complex, intent(in), optional :: j
+    if (present (j)) error stop 41
+  end
+
+  subroutine two_val (i, j)
+    complex, intent(in)           :: i
+    complex, value,      optional :: j
+    if (present (j)) error stop 42
+  end
+
+  subroutine two_all (i, j)
+    complex, intent(in)           :: i
+    complex, allocatable,optional :: j
+    if (present (j)) error stop 43
+  end
+
+  subroutine two_ptr (i, j)
+    complex, intent(in)           :: i
+    complex, pointer,    optional :: j
+    if (present (j)) error stop 44
+  end
+end
+
+program p
+  use m_int
+  use m_char
+  use m_char4
+  use m_complex
+  implicit none
+  call test_int ()
+  call test_char ()
+  call test_char4 ()
+  call test_complex ()
+end
--
2.35.3

