[flang] Stricter checking of DIM= arguments to LBOUND/UBOUND/SIZE

[klausler]

Summary

DIM= arguments with constant values can be checked for validity
even when other arguments to an intrinsic function can't be
folded. Handle errors with assumed-rank arguments as well.

[clementval]

LGTM

flang/lib/Evaluate/fold-integer.cpp

if (asScalar) {
     const int rank{GetRank(bounds)};
     std::vector<Scalar<T>> packed(rank);
     std::transform(bounds.begin(), bounds.end(), packed.begin(),
         [](ConstantSubscript x) { return Scalar<T>(x); });
     return Expr<T>{Constant<T>{std::move(packed), ConstantSubscripts{rank}}};
   }
 }
 
+// If a DIM= argument to LBOUND(), UBOUND(), or SIZE() exists and has a valid
+// constant value, return in "dimVal" that value, less 1 (to make it suitable
+// for use as a C++ vector<> index).  Also check for erroneous constant values
+// and returns false on error.
+static bool CheckDimArg(const std::optional<ActualArgument> &dimArg,
+    const Expr<SomeType> &array, parser::ContextualMessages &messages,
+    bool isLBound, std::optional<int> &dimVal) {
+  dimVal.reset();
+  if (int rank{array.Rank()}; rank > 0 || IsAssumedRank(array)) {
+    auto named{ExtractNamedEntity(array)};
+    if (auto dim64{ToInt64(dimArg)}) {
+      if (*dim64 < 1) {
+        messages.Say("DIM=%jd dimension must be positive"_err_en_US, *dim64);
+        return false;
+      } else if (!IsAssumedRank(array) && *dim64 > rank) {
+        messages.Say(
+            "DIM=%jd dimension is out of range for rank-%d array"_err_en_US,
+            *dim64, rank);
+        return false;
+      } else if (!isLBound && named &&
+          semantics::IsAssumedSizeArray(named->GetLastSymbol()) &&
+          *dim64 == rank) {
+        messages.Say(
+            "DIM=%jd dimension is out of range for rank-%d assumed-size array"_err_en_US,
+            *dim64, rank);
+        return false;
+      } else if (IsAssumedRank(array)) {
+        if (*dim64 > common::maxRank) {
+          messages.Say(
+              "DIM=%jd dimension is too large for any array (maximum rank %d)"_err_en_US,
+              *dim64, common::maxRank);
+          return false;
+        }
+      } else {
+        dimVal = static_cast<int>(*dim64 - 1); // 1-based to 0-based
+      }
+    }
+  }
+  return true;
+}
+
 // Class to retrieve the constant bound of an expression which is an
 // array that devolves to a type of Constant<T>
 class GetConstantArrayBoundHelper {
 public:
   template <typename T>
   static Expr<T> GetLbound(
       const Expr<SomeType> &array, std::optional<int> dim) {
     return PackageConstantBounds<T>(

 };
 
 template <int KIND>
 Expr<Type<TypeCategory::Integer, KIND>> LBOUND(FoldingContext &context,
     FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {
   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 && !IsAssumedRank(*array)) {
+    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,
-                *dim64, rank);
-            return MakeInvalidIntrinsic<T>(std::move(funcRef));
-          } else {
-            dim = *dim64 - 1; // 1-based to 0-based
-          }
-        } else {
-          // DIM= is present but not constant
+        if (!CheckDimArg(args[1], *array, context.messages(), true, dim)) {
+        } else if (!dim) {
+          // DIM= is present but not constant, or error
           return Expr<T>{std::move(funcRef)};
         }
       }
       bool lowerBoundsAreOne{true};
       if (auto named{ExtractNamedEntity(*array)}) {
         const Symbol &symbol{named->GetLastSymbol()};
         if (symbol.Rank() == rank) {
           lowerBoundsAreOne = false;

 }
 
 template <int KIND>
 Expr<Type<TypeCategory::Integer, KIND>> UBOUND(FoldingContext &context,
     FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {
   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 && !IsAssumedRank(*array)) {
+    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,
-                *dim64, rank);
-            return MakeInvalidIntrinsic<T>(std::move(funcRef));
-          } else {
-            dim = *dim64 - 1; // 1-based to 0-based
-          }
-        } else {
+        if (!CheckDimArg(args[1], *array, context.messages(), false, dim)) {
+        } else if (!dim) {
           // DIM= is present but not constant
           return Expr<T>{std::move(funcRef)};
         }
       }
       bool takeBoundsFromShape{true};
       if (auto named{ExtractNamedEntity(*array)}) {
         const Symbol &symbol{named->GetLastSymbol()};
         if (symbol.Rank() == rank) {
           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,
-                  rank, rank);
-              return MakeInvalidIntrinsic<T>(std::move(funcRef));
-            } else if (auto ub{GetUBOUND(context, *named, *dim)}) {
+            if (auto ub{GetUBOUND(context, *named, *dim)}) {
               return Fold(context, ConvertToType<T>(std::move(*ub)));
             }
           } else {
             Shape ubounds{GetUBOUNDs(context, *named)};
             if (semantics::IsAssumedSizeArray(symbol)) {
               CHECK(!ubounds.back());
               ubounds.back() = ExtentExpr{-1};
             }
return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
           if (result.overflow) {
             context.messages().Say(
                 "sign(integer(kind=%d)) folding overflowed"_warn_en_US, KIND);
           }
           return result.value;
         }));
   } else if (name == "size") {
     if (auto shape{GetContextFreeShape(context, args[0])}) {
-      if (auto &dimArg{args[1]}) { // DIM= is present, get one extent
-        if (auto dim{ToInt64(args[1])}) {
-          int rank{GetRank(*shape)};
-          if (*dim >= 1 && *dim <= rank) {
-            const Symbol *symbol{UnwrapWholeSymbolDataRef(args[0])};
-            if (symbol && IsAssumedSizeArray(*symbol) && *dim == rank) {
-              context.messages().Say(
-                  "size(array,dim=%jd) of last dimension is not available for rank-%d assumed-size array dummy argument"_err_en_US,
-                  *dim, rank);
-              return MakeInvalidIntrinsic<T>(std::move(funcRef));
-            } else if (auto &extent{shape->at(*dim - 1)}) {
-              return Fold(context, ConvertToType<T>(std::move(*extent)));
-            }
-          } else {
-            context.messages().Say(
-                "size(array,dim=%jd) dimension is out of range for rank-%d array"_warn_en_US,
-                *dim, rank);
-          }
+      if (args[1]) { // DIM= is present, get one extent
+        std::optional<int> dim;
+        if (const auto *array{args[0].value().UnwrapExpr()}; array &&
+            !CheckDimArg(args[1], *array, context.messages(), false, dim)) {
+        } else if (dim) {
+          if (auto &extent{shape->at(*dim)}) {
         }
       } else if (auto extents{common::AllElementsPresent(std::move(*shape))}) {
         // DIM= is absent; compute PRODUCT(SHAPE())
         ExtentExpr product{1};
         for (auto &&extent : std::move(*extents)) {
           product = std::move(product) * std::move(extent);
         }
         return Expr<T>{ConvertToType<T>(Fold(context, std::move(product)))};

flang/test/Evaluate/errors01.f90

 ! RUN: not %flang_fc1 %s 2>&1 | FileCheck %s
 ! Check errors found in folding
 ! TODO: test others emitted from flang/lib/Evaluate
 module m
   type t
     real x
   end type t
  contains
   subroutine s1(a,b)
     real :: a(*), b(:)
     !CHECK: error: DIM=1 dimension is out of range for rank-1 assumed-size array
     integer :: ub1(ubound(a,1))
     !CHECK-NOT: error: DIM=1 dimension is out of range for rank-1 assumed-size array
     integer :: lb1(lbound(a,1))
-    !CHECK: error: DIM=0 dimension is out of range for rank-1 array
+    !CHECK: error: DIM=0 dimension must be positive
     integer :: ub2(ubound(a,0))
     !CHECK: error: DIM=2 dimension is out of range for rank-1 array
     integer :: ub3(ubound(a,2))
-    !CHECK: error: DIM=0 dimension is out of range for rank-1 array
+    !CHECK: error: DIM=0 dimension must be positive
     integer :: lb2(lbound(b,0))
     !CHECK: error: DIM=2 dimension is out of range for rank-1 array
     integer :: lb3(lbound(b,2))
   end subroutine
   subroutine s2
     integer, parameter :: array(2,3) = reshape([(j, j=1, 6)], shape(array))
     integer :: x(2, 3)
     !CHECK: error: Invalid 'dim=' argument (0) in CSHIFT

flang/test/Semantics/misc-intrinsics.f90

subroutine test(arg, assumedRank)
     !ERROR: The 'harvest=' argument to the intrinsic procedure 'random_number' may not be assumed-size
     call random_number(arg)
     !ERROR: missing mandatory 'dim=' argument
     print *, lbound(scalar)
     !ERROR: 'array=' argument has unacceptable rank 0
     print *, size(scalar)
     !ERROR: missing mandatory 'dim=' argument
     print *, ubound(scalar)
+    !ERROR: DIM=0 dimension must be positive
+    print *, lbound(arg, 0)
+    !ERROR: DIM=0 dimension must be positive
+    print *, lbound(assumedRank, 0)
+    !ERROR: DIM=666 dimension is too large for any array (maximum rank 15)
+    print *, lbound(assumedRank, 666)
+    !ERROR: DIM=0 dimension must be positive
+    print *, ubound(arg, 0)
+    !ERROR: DIM=2 dimension is out of range for rank-2 assumed-size array
+    print *, ubound(arg, 2)
+    !ERROR: DIM=0 dimension must be positive
+    print *, ubound(assumedRank, 0)
+    !ERROR: DIM=666 dimension is too large for any array (maximum rank 15)
+    print *, ubound(assumedRank, 666)
     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: