public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r14-8317] Fortran: passing of optional scalar arguments with VALUE attribute [PR113377]
@ 2024-01-21 20:24 Harald Anlauf
0 siblings, 0 replies; only message in thread
From: Harald Anlauf @ 2024-01-21 20:24 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:68862e5c75ef0e875e690f0880a96fc6200d1682
commit r14-8317-g68862e5c75ef0e875e690f0880a96fc6200d1682
Author: Harald Anlauf <anlauf@gmx.de>
Date: Sat Jan 20 22:18:02 2024 +0100
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:
---
gcc/fortran/trans-expr.cc | 1 +
gcc/testsuite/gfortran.dg/optional_absent_9.f90 | 340 ++++++++++++++++++++++++
2 files changed, 341 insertions(+)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 9dd1f4086f4..128add47516 100644
--- 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
index 00000000000..063dd212908
--- /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
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2024-01-21 20:24 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2024-01-21 20:24 [gcc r14-8317] Fortran: passing of optional scalar arguments with VALUE attribute [PR113377] Harald Anlauf
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).