[flang] Validate SIZE(x,DIM=n) dimension for assumed-size array x

[klausler]

Summary

Catch invalid attempts to extract the unknowable extent of the last
dimension of an assumed-size array dummy argument, and clean up
problems with assumed-rank arguments in similar circumstances
exposed by testing the fix.

[PeteSteinfeld]

Looks great!

flang/include/flang/Evaluate/tools.h

 template <typename A>
 std::optional<DataRef> ExtractDataRef(const A *p, bool intoSubstring = false) {
   if (p) {
     return ExtractDataRef(*p, intoSubstring);
   } else {
     return std::nullopt;
   }
 }
+std::optional<DataRef> ExtractDataRef(
+    const ActualArgument &, bool intoSubstring = false);
+
 std::optional<DataRef> ExtractSubstringBase(const Substring &);
 
 // Predicate: is an expression is an array element reference?
 template <typename T>
 bool IsArrayElement(const Expr<T> &expr, bool intoSubstring = true,
     bool skipComponents = false) {
   if (auto dataRef{ExtractDataRef(expr, intoSubstring)}) {
     const DataRef *ref{&*dataRef};

flang/include/flang/Semantics/tools.h

 bool HasImpureFinal(const DerivedTypeSpec &);
 bool IsCoarray(const Symbol &);
 bool IsInBlankCommon(const Symbol &);
 bool IsAutomaticObject(const Symbol &);
 inline bool IsAssumedSizeArray(const Symbol &symbol) {
   const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
   return details && details->IsAssumedSize();
 }
-inline bool IsAssumedRankArray(const Symbol &symbol) {
-  const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
-  return details && details->IsAssumedRank();
-}
 bool IsAssumedLengthCharacter(const Symbol &);
 bool IsExternal(const Symbol &);
 bool IsModuleProcedure(const Symbol &);
 // Is the symbol modifiable in this scope
 std::optional<parser::MessageFixedText> WhyNotModifiable(
     const Symbol &, const Scope &);
 std::optional<parser::Message> WhyNotModifiable(SourceName, const SomeExpr &,
     const Scope &, bool vectorSubscriptIsOk = false);

flang/lib/Evaluate/fold-integer.cpp

if (const auto *cx{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
             return Scalar<typename ResultType<decltype(kx)>::Part>::RANGE;
           },
           cx->u)};
     }
   } else if (name == "rank") {
     if (const auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {
       if (auto named{ExtractNamedEntity(*array)}) {
         const Symbol &symbol{named->GetLastSymbol()};
-        if (semantics::IsAssumedRankArray(symbol)) {
+        if (IsAssumedRank(symbol)) {
           // DescriptorInquiry can only be placed in expression of kind
           // DescriptorInquiry::Result::kind.
           return ConvertToType<T>(Expr<
               Type<TypeCategory::Integer, DescriptorInquiry::Result::kind>>{
               DescriptorInquiry{*named, DescriptorInquiry::Field::Rank}});
         }
       }
       return Expr<T>{args[0].value().Rank()};
return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
               return result.value;
             }));
   } else if (name == "size") {
     if (auto shape{GetShape(context, args[0])}) {
       if (auto &dimArg{args[1]}) { // DIM= is present, get one extent
         if (auto dim{GetInt64Arg(args[1])}) {
           int rank{GetRank(*shape)};
           if (*dim >= 1 && *dim <= rank) {
-            if (auto &extent{shape->at(*dim - 1)}) {
+            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"_en_US,
                 *dim, rank);
           }
         }
if (auto info{
             Fold(context, Expr<T>{8} * ConvertToType<T>(std::move(*bytes)))};
       }
     }
   } else if (name == "sum") {
     return FoldSum<T>(context, std::move(funcRef));
   } else if (name == "ubound") {
     return UBOUND(context, std::move(funcRef));
   }
-  // TODO: count(w/ dim), dot_product, findloc, ibits, image_status, ishftc,
+  // TODO: dot_product, findloc, ibits, image_status, ishftc,
   // matmul, maxloc, minloc, sign, transfer
   return Expr<T>{std::move(funcRef)};
 }
 
 // Substitutes a bare type parameter reference with its value if it has one now
 // in an instantiation.  Bare LEN type parameters are substituted only when
 // the known value is constant.
 Expr<TypeParamInquiry::Result> FoldOperation(

flang/lib/Evaluate/formatting.cpp

case Field::Rank:
     break;
   case Field::Len:
     break;
   }
   base_.AsFortran(o);
   if (field_ == Field::Len) {
     return o << "%len";
   } else {
-    if (dimension_ >= 0) {
+    if (field_ != Field::Rank && dimension_ >= 0) {
       o << ",dim=" << (dimension_ + 1);
     }
     return o << ')';
   }
 }
 
 llvm::raw_ostream &Assignment::AsFortran(llvm::raw_ostream &o) const {
   std::visit(

flang/lib/Evaluate/shape.cpp

for (const auto &shapeSpec : details->shape()) {
               DescriptorInquiry::Field::LowerBound, dimension_}};
         } else {
           break;
         }
       }
     }
   } else if (const auto *assoc{
                  symbol.detailsIf<semantics::AssocEntityDetails>()}) {
+    if (assoc->rank()) { // SELECT RANK case
+      const Symbol &resolved{ResolveAssociations(symbol)};
+      if (IsDescriptor(resolved) && dimension_ < *assoc->rank()) {
+        return ExtentExpr{DescriptorInquiry{NamedEntity{symbol0},
+            DescriptorInquiry::Field::LowerBound, dimension_}};
+      }
+    } else {
       return (*this)(assoc->expr());
     }
+  }
   return Default();
 }
 
 auto GetLowerBoundHelper::operator()(const Component &component) -> Result {
   if (component.base().Rank() == 0) {
     const Symbol &symbol{component.GetLastSymbol().GetUltimate()};
     if (const auto *details{
             symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
if (uval && lval) {
     }
   }
   return common::Clone(ubound.value()) - common::Clone(lbound.value()) +
       ExtentExpr{1};
 }
 
 MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) {
   CHECK(dimension >= 0);
-  const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
+  const Symbol &last{base.GetLastSymbol()};
+  const Symbol &symbol{ResolveAssociations(last)};
+  if (const auto *assoc{last.detailsIf<semantics::AssocEntityDetails>()}) {
+    if (assoc->rank()) { // SELECT RANK case
+      if (semantics::IsDescriptor(symbol) && dimension < *assoc->rank()) {
+        return ExtentExpr{DescriptorInquiry{
+            NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}};
+      }
+    } else if (auto shape{GetShape(assoc->expr())}) {
+      if (dimension < static_cast<int>(shape->size())) {
+        return std::move(shape->at(dimension));
+      }
+    }
+  }
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     if (IsImpliedShape(symbol) && details->init()) {
       if (auto shape{GetShape(symbol)}) {
         if (dimension < static_cast<int>(shape->size())) {
           return std::move(shape->at(dimension));
         }
       }
     } else {
if (IsImpliedShape(symbol) && details->init()) {
             return std::nullopt;
           } else if (semantics::IsDescriptor(symbol)) {
             return ExtentExpr{DescriptorInquiry{NamedEntity{base},
                 DescriptorInquiry::Field::Extent, dimension}};
           }
         }
       }
     }
-  } else if (const auto *assoc{
-                 symbol.detailsIf<semantics::AssocEntityDetails>()}) {
-    if (auto shape{GetShape(assoc->expr())}) {
-      if (dimension < static_cast<int>(shape->size())) {
-        return std::move(shape->at(dimension));
-      }
-    }
   }
   return std::nullopt;
 }
 
 MaybeExtentExpr GetExtent(
     FoldingContext &context, const NamedEntity &base, int dimension) {
   return Fold(context, GetExtent(base, dimension));
 }

flang/lib/Evaluate/tools.cpp

return std::visit(
                 return AsGenericExpr(Parentheses<T>{std::move(y)});
               },
               std::move(x.u));
         }
       },
       std::move(expr.u));
 }
 
+std::optional<DataRef> ExtractDataRef(
+    const ActualArgument &arg, bool intoSubstring) {
+  if (const Expr<SomeType> *expr{arg.UnwrapExpr()}) {
+    return ExtractDataRef(*expr, intoSubstring);
+  } else {
+    return std::nullopt;
+  }
+}
+
 std::optional<DataRef> ExtractSubstringBase(const Substring &substring) {
   return std::visit(
       common::visitors{
           [&](const DataRef &x) -> std::optional<DataRef> { return x; },
           [&](const StaticDataObject::Pointer &) -> std::optional<DataRef> {
             return std::nullopt;
           },
       },
std::optional<Expr<SomeType>> ConvertToType(
   if (x) {
     return ConvertToType(to, std::move(*x));
   } else {
     return std::nullopt;
   }
 }
 
 bool IsAssumedRank(const Symbol &original) {
+  if (const auto *assoc{original.detailsIf<semantics::AssocEntityDetails>()}) {
+    if (assoc->rank()) {
+      return false; // in SELECT RANK case
+    }
+  }
   const Symbol &symbol{semantics::ResolveAssociations(original)};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     return details->IsAssumedRank();
   } else {
     return false;
   }
 }
 

flang/lib/Evaluate/variable.cpp

std::optional<Expr<SomeCharacter>> Substring::Fold(FoldingContext &context) {
   return std::nullopt;
 }
 
 DescriptorInquiry::DescriptorInquiry(
     const NamedEntity &base, Field field, int dim)
     : base_{base}, field_{field}, dimension_{dim} {
   const Symbol &last{base_.GetLastSymbol()};
   CHECK(IsDescriptor(last));
-  CHECK((field == Field::Len && dim == 0) ||
+  CHECK(((field == Field::Len || field == Field::Rank) && dim == 0) ||
       (field != Field::Len && dim >= 0 && dim < last.Rank()));
 }
 
 DescriptorInquiry::DescriptorInquiry(NamedEntity &&base, Field field, int dim)
     : base_{std::move(base)}, field_{field}, dimension_{dim} {
   const Symbol &last{base_.GetLastSymbol()};
   CHECK(IsDescriptor(last));
   CHECK((field == Field::Len && dim == 0) ||

flang/lib/Semantics/check-select-rank.cpp

const auto &selectRankStmt{
           selectRankConstruct.t)};
   const auto &selectRankStmtSel{
       std::get<parser::Selector>(selectRankStmt.statement.t)};
 
   // R1149 select-rank-stmt checks
   const Symbol *saveSelSymbol{nullptr};
   if (const auto selExpr{GetExprFromSelector(selectRankStmtSel)}) {
     if (const Symbol * sel{evaluate::UnwrapWholeSymbolDataRef(*selExpr)}) {
-      if (!IsAssumedRankArray(*sel)) { // C1150
+      if (!evaluate::IsAssumedRank(*sel)) { // C1150
         context_.Say(parser::FindSourceLocation(selectRankStmtSel),
             "Selector '%s' is not an assumed-rank array variable"_err_en_US,
             sel->name().ToString());
       } else {
         saveSelSymbol = sel;
       }
     } else {
       context_.Say(parser::FindSourceLocation(selectRankStmtSel),

flang/test/Semantics/select-rank.f90

contains
 
    subroutine CALL_ME8(x)
     implicit none
     integer :: x(..),j
     SELECT RANK(x)
     Rank(2)
       print *, "Now it's rank 2 "
     RANK (*)
-      print *, "Going for a other rank"
+      print *, "Going for another rank"
+      !ERROR: 'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type
       j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 1))
     !ERROR: Not more than one of the selectors of SELECT RANK statement may be '*'
     RANK (*)
       print *, "This is Wrong"
+      !ERROR: 'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type
       j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 1))
     END SELECT
    end subroutine
 
    subroutine CALL_ME10(x)
     implicit none
     integer:: x(..), a=10,b=20,j
     integer, dimension(5) :: arr = (/1,2,3,4,5/),brr