Fix regression about struct components passing for assume-shape formal arguments.

Author: wanbinchen-hnc

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: ;

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

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

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);
         }