From b3079a82a220477704f8156207239e4af4103ea9 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Fri, 15 Mar 2024 20:14:07 +0100 Subject: [PATCH] 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. --- gcc/fortran/trans-array.cc | 11 ++ .../gfortran.dg/missing_optional_dummy_6a.f90 | 2 +- .../ubsan/missing_optional_dummy_8.f90 | 108 ++++++++++++++++++ 3 files changed, 120 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/ubsan/missing_optional_dummy_8.f90 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)" }" -- 2.35.3