https://gcc.gnu.org/g:3f3f0b7ee8022776d69ecaed1375e1559716f226
commit r14-9509-g3f3f0b7ee8022776d69ecaed1375e1559716f226
Author: Harald Anlauf <anl...@gmx.de>
Date: Fri Mar 15 20:14:07 2024 +0100
Fortran: fix for absent array argument passed to optional dummy [PR101135]
gcc/fortran/ChangeLog:
PR fortran/101135
* trans-array.cc (gfc_get_dataptr_offset): Check for optional
arguments being present before dereferencing data pointer.
gcc/testsuite/ChangeLog:
PR fortran/101135
* gfortran.dg/missing_optional_dummy_6a.f90: Adjust diagnostic
pattern.
* gfortran.dg/ubsan/missing_optional_dummy_8.f90: New test.
Diff:
---
gcc/fortran/trans-array.cc | 11 +++
.../gfortran.dg/missing_optional_dummy_6a.f90 | 2 +-
.../gfortran.dg/ubsan/missing_optional_dummy_8.f90 | 108 +++++++++++++++++++++
3 files changed, 120 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 3673fa40720..a7717a8107e 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -7526,6 +7526,17 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm,
tree desc, tree offset,
/* Set the target data pointer. */
offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
+
+ /* Check for optional dummy argument being present. Arguments of BIND(C)
+ procedures are excepted here since they are handled differently. */
+ if (expr->expr_type == EXPR_VARIABLE
+ && expr->symtree->n.sym->attr.dummy
+ && expr->symtree->n.sym->attr.optional
+ && !is_CFI_desc (NULL, expr))
+ offset = build3_loc (input_location, COND_EXPR, TREE_TYPE (offset),
+ gfc_conv_expr_present (expr->symtree->n.sym), offset,
+ fold_convert (TREE_TYPE (offset),
gfc_index_zero_node));
+
gfc_conv_descriptor_data_set (block, parm, offset);
}
diff --git a/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90
b/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90
index c6a79059a91..b5e1726d74d 100644
--- a/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90
+++ b/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90
@@ -49,7 +49,7 @@ end program test
! { dg-final { scan-tree-dump-times "scalar2 \\(.* slr1" 1 "original" } }
-! { dg-final { scan-tree-dump-times "= es1 != 0B" 1 "original" } }
+! { dg-final { scan-tree-dump-times "= es1 != 0B" 2 "original" } }
! { dg-final { scan-tree-dump-times "assumed_shape2 \\(es1" 0 "original" } }
! { dg-final { scan-tree-dump-times "explicit_shape2 \\(es1" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/ubsan/missing_optional_dummy_8.f90
b/gcc/testsuite/gfortran.dg/ubsan/missing_optional_dummy_8.f90
new file mode 100644
index 00000000000..fd3914934aa
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ubsan/missing_optional_dummy_8.f90
@@ -0,0 +1,108 @@
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-original -fsanitize=undefined" }
+!
+! PR fortran/101135 - Load of null pointer when passing absent
+! assumed-shape array argument for an optional dummy argument
+!
+! Based on testcase by Marcel Jacobse
+
+program main
+ implicit none
+ character(len=3) :: a(6) = ['abc', 'def', 'ghi', 'jlm', 'nop', 'qrs']
+ call as ()
+ call as (a(::2))
+ call as_c ()
+ call as_c (a(2::2))
+ call test_wrapper
+ call test_wrapper_c
+ call test_ar_wrapper
+ call test_ar_wrapper_c
+contains
+ subroutine as (xx)
+ character(len=*), optional, intent(in) :: xx(*)
+ if (.not. present (xx)) return
+ print *, xx(1:3)
+ end subroutine as
+
+ subroutine as_c (zz) bind(c)
+ character(len=*), optional, intent(in) :: zz(*)
+ if (.not. present (zz)) return
+ print *, zz(1:3)
+ end subroutine as_c
+
+ subroutine test_wrapper (x)
+ real, dimension(1), intent(out), optional :: x
+ call test (x)
+ call test1 (x)
+ call test_c (x)
+ call test1_c (x)
+ end subroutine test_wrapper
+
+ subroutine test_wrapper_c (w) bind(c)
+ real, dimension(1), intent(out), optional :: w
+ call test (w)
+ call test1 (w)
+ call test_c (w)
+ call test1_c (w)
+ end subroutine test_wrapper_c
+
+ subroutine test (y)
+ real, dimension(:), intent(out), optional :: y
+ if (present (y)) y=0.
+ end subroutine test
+
+ subroutine test_c (y) bind(c)
+ real, dimension(:), intent(out), optional :: y
+ if (present (y)) y=0.
+ end subroutine test_c
+
+ subroutine test1 (y)
+ real, dimension(1), intent(out), optional :: y
+ if (present (y)) y=0.
+ end subroutine test1
+
+ subroutine test1_c (y) bind(c)
+ real, dimension(1), intent(out), optional :: y
+ if (present (y)) y=0.
+ end subroutine test1_c
+
+ subroutine test_ar_wrapper (p, q, r)
+ real, intent(out), optional :: p
+ real, dimension(1), intent(out), optional :: q
+ real, dimension(:), intent(out), optional :: r
+ call test_ar (p)
+ call test_ar (q)
+ call test_ar (r)
+ call test_ar_c (p)
+ call test_ar_c (q)
+ call test_ar_c (r)
+ end subroutine test_ar_wrapper
+
+ subroutine test_ar_wrapper_c (u, v, s) bind(c)
+ real, intent(out), optional :: u
+ real, dimension(1), intent(out), optional :: v
+ real, dimension(:), intent(out), optional :: s
+ call test_ar (u)
+ call test_ar (v)
+! call test_ar (s) ! Disabled due to runtime segfault, see pr114355
+ call test_ar_c (u)
+ call test_ar_c (v)
+ call test_ar_c (s)
+ end subroutine test_ar_wrapper_c
+
+ subroutine test_ar (z)
+ real, dimension(..), intent(out), optional :: z
+ end subroutine test_ar
+
+ subroutine test_ar_c (z) bind(c)
+ real, dimension(..), intent(out), optional :: z
+ end subroutine test_ar_c
+end program
+
+! { dg-final { scan-tree-dump-times "data = v != 0B " 2 "original" } }
+! { dg-final { scan-tree-dump-times "data = w != 0B " 2 "original" } }
+! { dg-final { scan-tree-dump-times "data = q != 0B " 2 "original" } }
+! { dg-final { scan-tree-dump-times "data = x != 0B " 2 "original" } }
+! { dg-final { scan-tree-dump-times "data = xx.0 != 0B " 1 "original" } }
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defjlmqrs(\n|\r\n|\r)" }"
