[flang] Avoid bogus errors with LBOUND/UBOUND(assumed rank array, DIM=)

Don't emit bogus compile-time error messages about out-of-range values
for the DIM= argument to LBOUND/BOUND when the array in question is an
assumed-rank dummy array argument.

Differential Revision: https://reviews.llvm.org/D155494

diff --git a/flang/lib/Evaluate/fold-integer.cpp b/flang/lib/Evaluate/fold-integer.cpp
index fdf6201..b87a01b 100644 (file)
--- a/flang/lib/Evaluate/fold-integer.cpp
+++ b/flang/lib/Evaluate/fold-integer.cpp
@@ -115,14 +115,14 @@ Expr<Type<TypeCategory::Integer, KIND>> LBOUND(FoldingContext &context,
   using T = Type<TypeCategory::Integer, KIND>;
   ActualArguments &args{funcRef.arguments()};
   if (const auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {
-    if (int rank{array->Rank()}; rank > 0) {
+    if (int rank{array->Rank()}; rank > 0 && !IsAssumedRank(*array)) {
       std::optional<int> dim;
       if (funcRef.Rank() == 0) {
         // Optional DIM= argument is present: result is scalar.
         if (auto dim64{ToInt64(args[1])}) {
           if (*dim64 < 1 || *dim64 > rank) {
-            context.messages().Say("DIM=%jd dimension is out of range for "
-                                   "rank-%d array"_err_en_US,
+            context.messages().Say(
+                "DIM=%jd dimension is out of range for rank-%d array"_err_en_US,
                 *dim64, rank);
             return MakeInvalidIntrinsic<T>(std::move(funcRef));
           } else {
@@ -169,14 +169,14 @@ Expr<Type<TypeCategory::Integer, KIND>> UBOUND(FoldingContext &context,
   using T = Type<TypeCategory::Integer, KIND>;
   ActualArguments &args{funcRef.arguments()};
   if (auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {
-    if (int rank{array->Rank()}; rank > 0) {
+    if (int rank{array->Rank()}; rank > 0 && !IsAssumedRank(*array)) {
       std::optional<int> dim;
       if (funcRef.Rank() == 0) {
         // Optional DIM= argument is present: result is scalar.
         if (auto dim64{ToInt64(args[1])}) {
           if (*dim64 < 1 || *dim64 > rank) {
-            context.messages().Say("DIM=%jd dimension is out of range for "
-                                   "rank-%d array"_err_en_US,
+            context.messages().Say(
+                "DIM=%jd dimension is out of range for rank-%d array"_err_en_US,
                 *dim64, rank);
             return MakeInvalidIntrinsic<T>(std::move(funcRef));
           } else {
@@ -194,8 +194,8 @@ Expr<Type<TypeCategory::Integer, KIND>> UBOUND(FoldingContext &context,
           takeBoundsFromShape = false;
           if (dim) {
             if (semantics::IsAssumedSizeArray(symbol) && *dim == rank - 1) {
-              context.messages().Say("DIM=%jd dimension is out of range for "
-                                     "rank-%d assumed-size array"_err_en_US,
+              context.messages().Say(
+                  "DIM=%jd dimension is out of range for rank-%d assumed-size array"_err_en_US,
                   rank, rank);
               return MakeInvalidIntrinsic<T>(std::move(funcRef));
             } else if (auto ub{GetUBOUND(context, *named, *dim)}) {

diff --git a/flang/test/Semantics/misc-intrinsics.f90 b/flang/test/Semantics/misc-intrinsics.f90
index 31efc3e..00018f6 100644 (file)
--- a/flang/test/Semantics/misc-intrinsics.f90
+++ b/flang/test/Semantics/misc-intrinsics.f90
@@ -3,10 +3,11 @@
 program test_size
   real :: scalar
   real, dimension(5, 5) :: array
-  call test(array)
+  call test(array, array)
  contains
-  subroutine test(arg)
+  subroutine test(arg, assumedRank)
     real, dimension(5, *) :: arg
+    real, dimension(..) :: assumedRank
     !ERROR: A dim= argument is required for 'size' when the array is assumed-size
     print *, size(arg)
     !ERROR: missing mandatory 'dim=' argument
@@ -21,6 +22,13 @@ program test_size
     print *, size(scalar)
     !ERROR: missing mandatory 'dim=' argument
     print *, ubound(scalar)
+    select rank(assumedRank)
+    rank(1)
+      !ERROR: DIM=2 dimension is out of range for rank-1 array
+      print *, lbound(assumedRank, dim=2)
+      !ERROR: DIM=2 dimension is out of range for rank-1 array
+      print *, ubound(assumedRank, dim=2)
+    end select
     ! But these cases are fine:
     print *, size(arg, dim=1)
     print *, ubound(arg, dim=1)
@@ -32,5 +40,15 @@ program test_size
     print *, ubound(arg(:,1))
     print *, shape(scalar)
     print *, shape(arg(:,1))
+    print *, lbound(assumedRank, dim=2) ! can't check until run time
+    print *, ubound(assumedRank, dim=2)
+    select rank(assumedRank)
+    rank(3)
+      print *, lbound(assumedRank, dim=2)
+      print *, ubound(assumedRank, dim=2)
+    rank default
+      print *, lbound(assumedRank, dim=2)
+      print *, ubound(assumedRank, dim=2)
+    end select
   end subroutine
 end