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.

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 9dd1f4086f4068a15e1f638994b8a116f163f27b..128add475168fa34e18d9696f82f57339ed80b93 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7256,6 +7256,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 (file)
index 0000000..063dd21
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/optional_absent_9.f90
@@ -0,0 +1,340 @@
+! { 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)
+    call two_val (i, aa)
+    call two_val (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)  ! dto.
+    call two_all (i, j)
+  end
+
+  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)  ! dto.
+    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)  ! dto.
+    call two_all (i, j)
+  end
+
+  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)  ! dto.
+    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)  ! dto.
+    call two_all (i, j)
+  end
+
+  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)  ! dto.
+    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)  ! dto.
+    call two_all (i, j)
+  end
+
+  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)  ! dto.
+    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
+
+module m_mm
+  ! Test suggested by Mikael Morin
+  implicit none
+  type :: t
+    integer, allocatable :: c
+    integer, pointer     :: p => NULL()
+  end type
+contains
+  subroutine test_mm ()
+    call s1 (t())
+  end
+
+  subroutine s1 (a)
+    type(t) :: a
+    call s2 (a% c)
+    call s2 (a% p)
+  end
+  
+  subroutine s2 (a)
+    integer, value, optional :: a
+    if (present(a)) stop 1
+  end
+end
+
+program p
+  use m_int
+  use m_char
+  use m_char4
+  use m_complex
+  use m_mm
+  implicit none
+  call test_int ()
+  call test_char ()
+  call test_char4 ()
+  call test_complex ()
+  call test_mm ()
+end