From c7dc57cca3590fab8d6980d4f126be8771f7580b Mon Sep 17 00:00:00 2001 From: wanbin chen Date: Thu, 18 Apr 2024 03:08:40 +0000 Subject: [PATCH] Fix regression about struct components passing for assume-shape formal arguments. --- test/f90_correct/inc/bound17.mk | 19 ++++++++ test/f90_correct/lit/bound17.sh | 9 ++++ test/f90_correct/src/bound17.f90 | 84 ++++++++++++++++++++++++++++++++ tools/flang1/flang1exe/func.c | 10 +++- 4 files changed, 120 insertions(+), 2 deletions(-) create mode 100644 test/f90_correct/inc/bound17.mk create mode 100644 test/f90_correct/lit/bound17.sh create mode 100644 test/f90_correct/src/bound17.f90 diff --git a/test/f90_correct/inc/bound17.mk b/test/f90_correct/inc/bound17.mk new file mode 100644 index 00000000000..84211b05071 --- /dev/null +++ b/test/f90_correct/inc/bound17.mk @@ -0,0 +1,19 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/lit/bound17.sh b/test/f90_correct/lit/bound17.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/bound17.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/src/bound17.f90 b/test/f90_correct/src/bound17.f90 new file mode 100644 index 00000000000..f28598655f0 --- /dev/null +++ b/test/f90_correct/src/bound17.f90 @@ -0,0 +1,84 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for LBOUND and UBOUND of assumed-shape formal when the corresponding +! acutal is a struct component. + +program test + implicit none + type my_type + integer :: x(2,3,4) + integer, allocatable :: x_alloc(:, :, :) + integer, pointer :: x_ptr(:, :, :) + end type + type(my_type) :: obj + integer, allocatable :: arr_res(:) + character(len=:), allocatable :: char_res + integer :: i + + allocate(obj%x_alloc(2:3, 3:5, 4:7)) + allocate(obj%x_ptr(2:3, 3:5, 4:7)) + + arr_res = array_test_specified_lb(1, 0, -1, obj%x) + if (size(arr_res) /= 8 .or. any(arr_res /= 1)) STOP 1 + arr_res = array_test_specified_lb(2, 1, 0, obj%x(2:, 3:, 2:)) + if (size(arr_res) /= 4 .or. any(arr_res /= 1)) STOP 2 + arr_res = array_test_missing_lb(obj%x_alloc) + if (size(arr_res) /= 3 .or. any(arr_res /= 2)) STOP 3 + arr_res = array_test_specified_lb(1, 0, -1, obj%x_alloc) + if (size(arr_res) /= 8 .or. any(arr_res /= 1)) STOP 4 + arr_res = array_test_missing_lb(obj%x_ptr) + if (size(arr_res) /= 3 .or. any(arr_res /= 2)) STOP 5 + + char_res = char_test_specified_lb(1, 0, -1, obj%x) + if (len(char_res) /= 8 .or. char_res /= 'aaaaaaaa') STOP 6 + char_res = char_test_specified_lb(2, 1, 0, obj%x(2:, 3:, 2:)) + if (len(char_res) /= 4 .or. char_res /= 'aaaa') STOP 7 + char_res = char_test_missing_lb(obj%x_alloc) + if (len(char_res) /= 3 .or. char_res /= 'bbb') STOP 8 + char_res = char_test_specified_lb(1, 0, -1, obj%x_alloc) + if (len(char_res) /= 8 .or. char_res /= 'aaaaaaaa') STOP 9 + char_res = char_test_missing_lb(obj%x_ptr) + if (len(char_res) /= 3 .or. char_res /= 'bbb') STOP 10 + + arr_res = test_noncnst_dim(1, 0, -1, obj%x, 1, 2, 3) + if (size(arr_res) /= 8 .or. any(arr_res /= 1)) STOP 11 + + print *, "PASS" +contains + function array_test_specified_lb(l1, l2, l3, a) result(res) + integer :: l1, l2, l3 + integer :: a(l1:, l2:, l3:) + integer :: res(1:ubound(a, 1) * ubound(a, 2) * ubound(a, 3)) + res = 1 + end function + + function array_test_missing_lb(a) result(res) + integer :: a(:, :, :) + integer :: res(1:lbound(a, 1) + lbound(a, 2) + lbound(a, 3)) + res = 2 + end function + + function char_test_specified_lb(l1, l2, l3, a) result(res) + integer :: l1, l2, l3 + integer :: a(l1:, l2:, l3:) + character(len=ubound(a, 1) * ubound(a, 2) * ubound(a, 3)) :: res + res = repeat('a', ubound(a, 1) * ubound(a, 2) * ubound(a, 3)) + end function + + function char_test_missing_lb(a) result(res) + integer :: a(:, :, :) + character(len=lbound(a, 1) + lbound(a, 2) + lbound(a, 3)) :: res + res = repeat('b', lbound(a, 1) + lbound(a, 2) + lbound(a, 3)) + end function + + function test_noncnst_dim(l1, l2, l3, a, d1, d2, d3) result(res) + integer :: l1, l2, l3 + integer :: a(l1:, l2:, l3:) + integer :: d1, d2, d3 + integer :: res(1:ubound(a, d1) * ubound(a, d2) * ubound(a, d3)) + res = 1 + end function +end program diff --git a/tools/flang1/flang1exe/func.c b/tools/flang1/flang1exe/func.c index 67f6396a2cc..b7299c99b68 100644 --- a/tools/flang1/flang1exe/func.c +++ b/tools/flang1/flang1exe/func.c @@ -7706,7 +7706,10 @@ rewrite_lbound_ubound(int func_ast, int actual, int nextstd) (POINTERG(actual_sptr) || ALLOCG(actual_sptr))) { /* The whole array actual_sptr corresponding to an assumed-shape * formal cannot be assumed-rank. */ - extent = get_extent(SDSCG(actual_sptr), i - 1); + int subs[1]; + int desc = find_descriptor_ast(actual_sptr, actual); + subs[0] = mk_isz_cval(get_global_extent_index(i - 1), astb.bnd.dtype); + extent = mk_subscr(desc, subs, 1, astb.bnd.dtype); } else { extent = extent_of_shape(A_SHAPEG(actual), i - 1); } @@ -7902,7 +7905,10 @@ rewrite_lbound_ubound(int func_ast, int actual, int nextstd) (POINTERG(actual_sptr) || ALLOCG(actual_sptr))) { /* The whole array actual_sptr corresponding to an assumed-shape * formal cannot be assumed-rank. */ - extent = get_extent(SDSCG(actual_sptr), i); + int subs[1]; + int desc = find_descriptor_ast(actual_sptr, actual); + subs[0] = mk_isz_cval(get_global_extent_index(i - 1), astb.bnd.dtype); + extent = mk_subscr(desc, subs, 1, astb.bnd.dtype); } else { extent = extent_of_shape(A_SHAPEG(actual), i); }