[flang] Catch bad inquiries in specification expressions

[klausler]

Summary

When a descriptor inquiry or inquiry function's result is
not constant and is known to be impossible to correctly determine
at runtime, raise an error. For example, LEN(X) when X is
a local allocatable variable with deferred length.

[jeanPerier]

Looks good.

flang/include/flang/Semantics/tools.h

 // Is the symbol explicitly or implicitly initialized in any way?
 bool IsInitialized(const Symbol &, bool ignoreDATAstatements = false,
     bool ignoreAllocatable = false);
 // Is the symbol a component subject to deallocation or finalization?
 bool IsDestructible(const Symbol &, const Symbol *derivedType = nullptr);
 bool HasIntrinsicTypeName(const Symbol &);
 bool IsSeparateModuleProcedureInterface(const Symbol *);
 bool HasAlternateReturns(const Symbol &);
-bool InCommonBlock(const Symbol &);
 
 // Return an ultimate component of type that matches predicate, or nullptr.
 const Symbol *FindUltimateComponent(const DerivedTypeSpec &type,
     const std::function<bool(const Symbol &)> &predicate);
 const Symbol *FindUltimateComponent(
     const Symbol &symbol, const std::function<bool(const Symbol &)> &predicate);
 
 // Returns an immediate component of type that matches predicate, or nullptr.

flang/lib/Evaluate/check-expression.cpp

if (converted) {
       context.messages().Say(
           "Initialization expression cannot be converted to declared type of '%s'"_err_en_US,
           symbol.name());
     }
   }
   return std::nullopt;
 }
 
+static bool IsNonLocal(const semantics::Symbol &symbol) {
+  return semantics::IsDummy(symbol) || symbol.has<semantics::UseDetails>() ||
+      symbol.owner().kind() == semantics::Scope::Kind::Module ||
+      semantics::FindCommonBlockContaining(symbol) ||
+      symbol.has<semantics::HostAssocDetails>();
+}
+
+static bool IsPermissibleInquiry(const semantics::Symbol &firstSymbol,
+    const semantics::Symbol &lastSymbol, DescriptorInquiry::Field field,
+    const semantics::Scope &localScope) {
+  if (IsNonLocal(firstSymbol)) {
+    return true;
+  }
+  if (&localScope != &firstSymbol.owner()) {
+    return true;
+  }
+  // Inquiries on local objects may not access a deferred bound or length.
+  const auto *object{lastSymbol.detailsIf<semantics::ObjectEntityDetails>()};
+  switch (field) {
+  case DescriptorInquiry::Field::LowerBound:
+  case DescriptorInquiry::Field::Extent:
+  case DescriptorInquiry::Field::Stride:
+    return object && !object->shape().CanBeDeferredShape();
+  case DescriptorInquiry::Field::Rank:
+    return true; // always known
+  case DescriptorInquiry::Field::Len:
+    return object && object->type() &&
+        object->type()->category() == semantics::DeclTypeSpec::Character &&
+        !object->type()->characterTypeSpec().length().isDeferred();
+  default:
+    break;
+  }
+  // TODO: Handle non-deferred LEN type parameters of PDTs
+  return false;
+}
+
 // Specification expression validation (10.1.11(2), C1010)
 class CheckSpecificationExprHelper
     : public AnyTraverse<CheckSpecificationExprHelper,
           std::optional<std::string>> {
 public:
   using Result = std::optional<std::string>;
   using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;
   explicit CheckSpecificationExprHelper(
if (auto result{(*this)(x.lower())}) {
       return result;
     }
     return (*this)(x.upper());
   }
   Result operator()(const DescriptorInquiry &x) const {
     // Many uses of SIZE(), LBOUND(), &c. that are valid in specification
     // expressions will have been converted to expressions over descriptor
     // inquiries by Fold().
+    // Catch REAL, ALLOCATABLE :: X(:); REAL :: Y(SIZE(X))
+    if (IsPermissibleInquiry(x.base().GetFirstSymbol(),
+            x.base().GetLastSymbol(), x.field(), scope_)) {
       auto restorer{common::ScopedSet(inInquiry_, true)};
       return (*this)(x.base());
+    } else if (IsConstantExpr(x)) {
+      return std::nullopt;
+    } else {
+      return "non-constant descriptor inquiry not allowed for local object";
+    }
   }
 
   Result operator()(const TypeParamInquiry &inq) const {
     if (scope_.IsDerivedType() && !IsConstantExpr(inq) &&
         inq.base() /* X%T, not local T */) { // C750, C754
       return "non-constant reference to a type parameter inquiry not "
              "allowed for derived type components or type parameter values";
     }
if (const auto *symbol{x.proc().GetSymbol()}) {
             })};
         if (iter != procChars->dummyArguments.end()) {
           return "reference to function '"s + ultimate.name().ToString() +
               "' with dummy procedure argument '" + iter->name + '\'';
         }
       }
       // References to internal functions are caught in expression semantics.
       // TODO: other checks for standard module procedures
-    } else {
+    } else { // intrinsic
       const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())};
       inInquiry = context_.intrinsics().GetIntrinsicClass(intrin.name) ==
           IntrinsicClass::inquiryFunction;
       if (scope_.IsDerivedType()) { // C750, C754
         if ((context_.intrinsics().IsIntrinsic(intrin.name) &&
                 badIntrinsicsForComponents_.find(intrin.name) !=
                     badIntrinsicsForComponents_.end())) {
           return "reference to intrinsic '"s + intrin.name +
               "' not allowed for derived type components or type parameter"
               " values";
         }
         if (inInquiry && !IsConstantExpr(x)) {
           return "non-constant reference to inquiry intrinsic '"s +
               intrin.name +
               "' not allowed for derived type components or type"
               " parameter values";
         }
       }
-      if (intrin.name == "present") {
-        // don't bother looking at argument
-        return std::nullopt;
-      }
+      // Type-determined inquiries (DIGITS, HUGE, &c.) will have already been
+      // folded and won't arrive here.  Inquiries that are represented with
+      // DescriptorInquiry operations (LBOUND) are checked elsewhere.  If a
+      // call that makes it to here satisfies the requirements of a constant
+      // expression (as Fortran defines it), it's fine.
       if (IsConstantExpr(x)) {
-        // inquiry functions may not need to check argument(s)
         return std::nullopt;
       }
+      if (intrin.name == "present") {
+        return std::nullopt; // always ok
+      }
+      // Catch CHARACTER(:), ALLOCATABLE :: X; CHARACTER(LEN(X)) :: Y
+      if (inInquiry && x.arguments().size() >= 1) {
+        if (const auto &arg{x.arguments().at(0)}) {
+          if (auto dataRef{ExtractDataRef(*arg, true, true)}) {
+            if (intrin.name == "allocated" || intrin.name == "associated" ||
+                intrin.name == "is_contiguous") { // ok
+            } else if (intrin.name == "len" &&
+                IsPermissibleInquiry(dataRef->GetFirstSymbol(),
+                    dataRef->GetLastSymbol(), DescriptorInquiry::Field::Len,
+                    scope_)) { // ok
+            } else if (intrin.name == "lbound" &&
+                IsPermissibleInquiry(dataRef->GetFirstSymbol(),
+                    dataRef->GetLastSymbol(),
+                    DescriptorInquiry::Field::LowerBound, scope_)) { // ok
+            } else if ((intrin.name == "shape" || intrin.name == "size" ||
+                           intrin.name == "sizeof" ||
+                           intrin.name == "storage_size" ||
+                           intrin.name == "ubound") &&
+                IsPermissibleInquiry(dataRef->GetFirstSymbol(),
+                    dataRef->GetLastSymbol(), DescriptorInquiry::Field::Extent,
+                    scope_)) { // ok
+            } else {
+              return "non-constant inquiry function '"s + intrin.name +
+                  "' not allowed for local object";
+            }
+          }
+        }
+      }
     }
     auto restorer{common::ScopedSet(inInquiry_, inInquiry)};
     return (*this)(x.arguments());
   }
 
 private:
   const semantics::Scope &scope_;
   FoldingContext &context_;

flang/lib/Semantics/check-declarations.cpp

if (symbol.attrs().test(Attr::PROTECTED)) {
     if (symbol.owner().kind() != Scope::Kind::Module) { // C854
       messages_.Say(
           "A PROTECTED entity must be in the specification part of a module"_err_en_US);
     }
     if (!evaluate::IsVariable(symbol) && !IsProcedurePointer(symbol)) { // C855
       messages_.Say(
           "A PROTECTED entity must be a variable or pointer"_err_en_US);
     }
-    if (InCommonBlock(symbol)) { // C856
+    if (FindCommonBlockContaining(symbol)) { // C856
       messages_.Say(
           "A PROTECTED entity may not be in a common block"_err_en_US);
     }
   }
   if (IsPointer(symbol)) {
     CheckPointer(symbol);
   }
   if (InPure()) {

flang/lib/Semantics/compute-offsets.cpp

for (auto &[symbol, dep] : dependents_) {
     } else {
       SizeAndAlignment &blockInfo{iter->second};
       blockInfo.size = std::max(blockInfo.size, minBlockSize);
       blockInfo.alignment = std::max(blockInfo.alignment, symInfo.alignment);
     }
   }
   // Assign offsets for non-COMMON EQUIVALENCE blocks
   for (auto &[symbol, blockInfo] : equivalenceBlock_) {
-    if (!InCommonBlock(*symbol)) {
+    if (!FindCommonBlockContaining(*symbol)) {
       DoSymbol(*symbol);
       DoEquivalenceBlockBase(*symbol, blockInfo);
       offset_ = std::max(offset_, symbol->offset() + blockInfo.size);
     }
   }
   // Process remaining non-COMMON symbols; this is all of them if there
   // was no use of EQUIVALENCE in the scope.
   for (auto &symbol : scope.GetSymbols()) {
-    if (!InCommonBlock(*symbol) &&
+    if (!FindCommonBlockContaining(*symbol) &&
         dependents_.find(symbol) == dependents_.end() &&
         equivalenceBlock_.find(symbol) == equivalenceBlock_.end()) {
       DoSymbol(*symbol);
     }
   }
   scope.set_size(offset_);
   scope.SetAlignment(alignment_);
   // Assign offsets in COMMON blocks, unless this scope is a BLOCK construct,

flang/lib/Semantics/resolve-names.cpp

if (context().HasError(symbol) || symbol.has<T>()) {
         DIE("unexpected kind");
       }
     } else if (std::is_same_v<ObjectEntityDetails, T> &&
         symbol.has<ProcEntityDetails>()) {
       SayWithDecl(
           name, symbol, "'%s' is already declared as a procedure"_err_en_US);
     } else if (std::is_same_v<ProcEntityDetails, T> &&
         symbol.has<ObjectEntityDetails>()) {
-      if (InCommonBlock(symbol)) {
+      if (FindCommonBlockContaining(symbol)) {
         SayWithDecl(name, symbol,
             "'%s' may not be a procedure as it is in a COMMON block"_err_en_US);
       } else {
         SayWithDecl(
             name, symbol, "'%s' is already declared as an object"_err_en_US);
       }
     } else if (!CheckPossibleBadForwardRef(symbol)) {
       SayAlreadyDeclared(name, symbol);

flang/lib/Semantics/tools.cpp

bool HasAlternateReturns(const Symbol &subprogram) {
   for (const auto *dummyArg : subprogram.get<SubprogramDetails>().dummyArgs()) {
     if (!dummyArg) {
       return true;
     }
   }
   return false;
 }
 
-bool InCommonBlock(const Symbol &symbol) {
-  const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
-  return details && details->commonBlock();
-}
-
 const std::optional<parser::Name> &MaybeGetNodeName(
     const ConstructNode &construct) {
   return common::visit(
       common::visitors{
           [&](const parser::BlockConstruct *blockConstruct)
               -> const std::optional<parser::Name> & {
             return std::get<0>(blockConstruct->t).statement.v;
           },

flang/test/Evaluate/errors01.f90

subroutine s10
     character(kind=2), parameter :: badc22 = char(65536,kind=2)
     !CHECK: warning: ACHAR(I=65536) is out of range for CHARACTER(KIND=2)
     character(kind=2), parameter :: bada22 = achar(65536,kind=2)
     !CHECK: warning: CHAR(I=4294967296) is out of range for CHARACTER(KIND=4)
     character(kind=4), parameter :: badc42 = char(4294967296_8,kind=4)
     !CHECK: warning: ACHAR(I=4294967296) is out of range for CHARACTER(KIND=4)
     character(kind=4), parameter :: bada42 = achar(4294967296_8,kind=4)
   end subroutine
+  subroutine s11
+    character(:), allocatable :: x1
+    !CHECK: error: Invalid specification expression: non-constant inquiry function 'len' not allowed for local object
+    character(len(x1)) :: x2
+    real, allocatable :: x3(:)
+    !CHECK: error: Invalid specification expression: non-constant descriptor inquiry not allowed for local object
+    real :: x4(size(x3))
+  end
   subroutine s12(x,y)
     class(t), intent(in) :: x
     class(*), intent(in) :: y
     !CHERK: error: Must be a constant value
     integer, parameter :: bad1 = storage_size(x)
     !CHERK: error: Must be a constant value
     integer, parameter :: bad2 = storage_size(y)
   end subroutine

flang/test/Semantics/resolve89.f90

! C750
   ! statement functions referenced below
   iVolatileStmtFunc() = 3 * volatileVar
   iImpureStmtFunc() = 3 * impureFunc()
   iPureStmtFunc() = 3 * iPureFunc()
 
   ! This is OK
   real, dimension(merge(1, 2, allocated(mVar))) :: rVar
 
-
   integer :: var = 3
     !ERROR: Invalid specification expression: reference to impure function 'ivolatilestmtfunc'
   real, dimension(iVolatileStmtFunc()) :: arrayVarWithVolatile
     !ERROR: Invalid specification expression: reference to impure function 'iimpurestmtfunc'
   real, dimension(iImpureStmtFunc()) :: arrayVarWithImpureFunction
     !ERROR: Invalid specification expression: reference to statement function 'ipurestmtfunc'
   real, dimension(iPureStmtFunc()) :: arrayVarWithPureFunction
   real, dimension(iabs(iArg)) :: arrayVarWithIntrinsic