From f6a65138391c902d2782973665059d7d059a50d1 Mon Sep 17 00:00:00 2001 From: Harald Anlauf 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