[flang] Refine error checking in specification expressions

[klausler]

Summary

The rules in the Fortran standard for specification expressions
are full of special cases and exceptions, and semantics didn't get
them exactly right. It is valid to refer to an INTENT(OUT) dummy
argument in a specification expression in the context of a
specification inquiry function like SIZE(); it is not valid to
reference an OPTIONAL dummy argument outside of the context of
PRESENT. This patch makes the specification expression checker
a little context-sensitive about whether it's examining an actual
argument of a specification inquiry intrinsic function or not.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/lib/Evaluate/check-expression.cpp

public:
   bool operator()(const TypeParamInquiry &inq) const {
     return INVARIANT || semantics::IsKindTypeParameter(inq.parameter());
   }
   bool operator()(const semantics::Symbol &symbol) const {
     const auto &ultimate{GetAssociationRoot(symbol)};
     return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) ||
         IsInitialProcedureTarget(ultimate) ||
         ultimate.has<semantics::TypeParamDetails>() ||
-        (INVARIANT && IsIntentIn(symbol) &&
+        (INVARIANT && IsIntentIn(symbol) && !IsOptional(symbol) &&
             !symbol.attrs().test(semantics::Attr::VALUE));
   }
   bool operator()(const CoarrayRef &) const { return false; }
   bool operator()(const semantics::ParamValue &param) const {
     return param.isExplicit() && (*this)(param.GetExplicit());
   }
   bool operator()(const ProcedureRef &) const;
   bool operator()(const StructureConstructor &constructor) const {
bool operator()(
     }
   }
 
   bool operator()(const Constant<SomeDerived> &) const { return true; }
   bool operator()(const DescriptorInquiry &x) const {
     const Symbol &sym{x.base().GetLastSymbol()};
     return INVARIANT && !IsAllocatable(sym) &&
         (!IsDummy(sym) ||
-            (IsIntentIn(sym) && !sym.attrs().test(semantics::Attr::VALUE)));
+            (IsIntentIn(sym) && !IsOptional(sym) &&
+                !sym.attrs().test(semantics::Attr::VALUE)));
   }
 
 private:
   bool IsConstantStructureConstructorComponent(
       const Symbol &, const Expr<SomeType> &) const;
   bool IsConstantExprShape(const Shape &) const;
 };
 
 template <bool INVARIANT>
 bool IsConstantExprHelper<INVARIANT>::IsConstantStructureConstructorComponent(
     const Symbol &component, const Expr<SomeType> &expr) const {
   if (IsAllocatable(component)) {
     return IsNullPointer(expr);
   } else if (IsPointer(component)) {
     return IsNullPointer(expr) || IsInitialDataTarget(expr) ||
         IsInitialProcedureTarget(expr);
   } else {
     return (*this)(expr);
   }
 }
 
 template <bool INVARIANT>
 bool IsConstantExprHelper<INVARIANT>::operator()(
     const ProcedureRef &call) const {
-  // LBOUND, UBOUND, and SIZE with DIM= arguments will have been rewritten
-  // into DescriptorInquiry operations.
+  // LBOUND, UBOUND, and SIZE with truly constant DIM= arguments will have
+  // been rewritten into DescriptorInquiry operations.
   if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&call.proc().u)}) {
     if (intrinsic->name == "kind" ||
         intrinsic->name == IntrinsicProcTable::InvalidName) {
       // kind is always a constant, and we avoid cascading errors by considering
       // invalid calls to intrinsics to be constant
       return true;
-    } else if (intrinsic->name == "lbound" && call.arguments().size() == 1) {
-      // LBOUND(x) without DIM=
+    } else if (intrinsic->name == "lbound") {
       auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())};
       return base && IsConstantExprShape(GetLBOUNDs(*base));
-    } else if (intrinsic->name == "ubound" && call.arguments().size() == 1) {
-      // UBOUND(x) without DIM=
+    } else if (intrinsic->name == "ubound") {
       auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())};
       return base && IsConstantExprShape(GetUBOUNDs(*base));
-    } else if (intrinsic->name == "shape") {
-      auto shape{GetShape(call.arguments()[0]->UnwrapExpr())};
-      return shape && IsConstantExprShape(*shape);
-    } else if (intrinsic->name == "size" && call.arguments().size() == 1) {
-      // SIZE(x) without DIM
+    } else if (intrinsic->name == "shape" || intrinsic->name == "size") {
       auto shape{GetShape(call.arguments()[0]->UnwrapExpr())};
       return shape && IsConstantExprShape(*shape);
     }
     // TODO: STORAGE_SIZE
   }
   return false;
 }
 
if (const auto *assoc{
         IsVariableName(ultimate)) { // C750, C754
       return "derived type component or type parameter value not allowed to "
              "reference variable '"s +
           ultimate.name().ToString() + "'";
     } else if (IsDummy(ultimate)) {
       if (ultimate.attrs().test(semantics::Attr::OPTIONAL)) {
         return "reference to OPTIONAL dummy argument '"s +
             ultimate.name().ToString() + "'";
-      } else if (ultimate.attrs().test(semantics::Attr::INTENT_OUT)) {
+      } else if (!inInquiry_ &&
+          ultimate.attrs().test(semantics::Attr::INTENT_OUT)) {
         return "reference to INTENT(OUT) dummy argument '"s +
             ultimate.name().ToString() + "'";
       } else if (ultimate.has<semantics::ObjectEntityDetails>()) {
         return std::nullopt;
       } else {
         return "dummy procedure argument";
       }
     } else if (&symbol.owner() != &scope_ || &ultimate.owner() != &scope_) {
       return std::nullopt; // host association is in play
     } else if (const auto *object{
                    ultimate.detailsIf<semantics::ObjectEntityDetails>()}) {
       if (object->commonBlock()) {
         return std::nullopt;
       }
     }
     return "reference to local entity '"s + ultimate.name().ToString() + "'";
   }
 
   Result operator()(const Component &x) const {
     // Don't look at the component symbol.
     return (*this)(x.base());
   }
-  Result operator()(const DescriptorInquiry &) const {
-    // Subtle: Uses of SIZE(), LBOUND(), &c. that are valid in specification
+  Result operator()(const ArrayRef &x) const {
+    if (auto result{(*this)(x.base())}) {
+      return result;
+    }
+    // The subscripts don't get special protection for being in a
+    // specification inquiry context;
+    auto restorer{common::ScopedSet(inInquiry_, false)};
+    return (*this)(x.subscript());
+  }
+  Result operator()(const Substring &x) const {
+    if (auto result{(*this)(x.parent())}) {
+      return result;
+    }
+    // The bounds don't get special protection for being in a
+    // specification inquiry context;
+    auto restorer{common::ScopedSet(inInquiry_, false)};
+    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().
-    return std::nullopt;
+    auto restorer{common::ScopedSet(inInquiry_, true)};
+    return (*this)(x.base());
   }
 
   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";
     }
     return std::nullopt;
   }
 
   Result operator()(const ProcedureRef &x) const {
+    bool inInquiry{false};
     if (const auto *symbol{x.proc().GetSymbol()}) {
       const Symbol &ultimate{symbol->GetUltimate()};
       if (!semantics::IsPureProcedure(ultimate)) {
         return "reference to impure function '"s + ultimate.name().ToString() +
             "'";
       }
       if (semantics::IsStmtFunction(ultimate)) {
         return "reference to statement function '"s +
if (const auto *symbol{x.proc().GetSymbol()}) {
           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 {
       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()) ||
-            IsProhibitedFunction(intrin.name)) {
+                    badIntrinsicsForComponents_.end())) {
           return "reference to intrinsic '"s + intrin.name +
               "' not allowed for derived type components or type parameter"
               " values";
         }
-        if (context_.intrinsics().GetIntrinsicClass(intrin.name) ==
-                IntrinsicClass::inquiryFunction &&
-            !IsConstantExpr(x)) {
+        if (inInquiry && !IsConstantExpr(x)) {
           return "non-constant reference to inquiry intrinsic '"s +
               intrin.name +
               "' not allowed for derived type components or type"
               " parameter values";
         }
-      } else if (intrin.name == "present") {
-        return std::nullopt; // no need to check argument(s)
+      }
+      if (intrin.name == "present") {
+        // don't bother looking at argument
+        return std::nullopt;
       }
       if (IsConstantExpr(x)) {
         // inquiry functions may not need to check argument(s)
         return std::nullopt;
       }
     }
+    auto restorer{common::ScopedSet(inInquiry_, inInquiry)};
     return (*this)(x.arguments());
   }
 
 private:
   const semantics::Scope &scope_;
   FoldingContext &context_;
+  // Contextual information: this flag is true when in an argument to
+  // an inquiry intrinsic like SIZE().
+  mutable bool inInquiry_{false};
   const std::set<std::string> badIntrinsicsForComponents_{
       "allocated", "associated", "extends_type_of", "present", "same_type_as"};
-  static bool IsProhibitedFunction(std::string name) { return false; }
 };
 
 template <typename A>
 void CheckSpecificationExpr(
     const A &x, const semantics::Scope &scope, FoldingContext &context) {
   if (auto why{CheckSpecificationExprHelper{scope, context}(x)}) {
     context.messages().Say(
         "Invalid specification expression: %s"_err_en_US, *why);

flang/lib/Evaluate/intrinsics.cpp

static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
     {{"isign", {{"a", DefaultInt}, {"b", DefaultInt}}, DefaultInt}, "sign"},
     {{"jiabs", {{"a", TypePattern{IntType, KindCode::exactKind, 4}}},
          TypePattern{IntType, KindCode::exactKind, 4}},
         "abs"},
     {{"kiabs", {{"a", TypePattern{IntType, KindCode::exactKind, 8}}},
          TypePattern{IntType, KindCode::exactKind, 8}},
         "abs"},
     {{"len", {{"string", DefaultChar, Rank::anyOrAssumedRank}}, DefaultInt,
-        Rank::scalar}},
+        Rank::scalar, IntrinsicClass::inquiryFunction}},
     {{"lge", {{"string_a", DefaultChar}, {"string_b", DefaultChar}},
          DefaultLogical},
         "lge", true},
     {{"lgt", {{"string_a", DefaultChar}, {"string_b", DefaultChar}},
          DefaultLogical},
         "lgt", true},
     {{"lle", {{"string_a", DefaultChar}, {"string_b", DefaultChar}},
          DefaultLogical},

flang/test/Semantics/spec-expr.f90

subroutine s7bii(dummy)
   ! Should be an error since "dummy" is deferred, but all compilers handle it
   real, dimension(len(dummy)) :: realArray
 end subroutine s7bii
 
 ! a specification inquiry where each designator or argument is
 !   (b) a variable that is not an optional dummy argument, and whose
 !     properties inquired about are not
 !  (iii) defined by an expression that is not a restricted expression,
-subroutine s7biii()
+subroutine s7biii(x, y)
+  real, intent(out) :: x(:)
+  real, optional :: y(:)
   integer, parameter :: localConst = 5
   integer :: local = 5
   ! OK, since "localConst" is a constant
   real, dimension(localConst) :: realArray1
   !ERROR: Invalid specification expression: reference to local entity 'local'
   real, dimension(local) :: realArray2
+  real, dimension(size(realArray1)) :: realArray3 ! ok
+  real, dimension(size(x)) :: realArray4 ! ok
+  real, dimension(merge(1,2,present(y))) :: realArray5 ! ok
+  !ERROR: Invalid specification expression: reference to OPTIONAL dummy argument 'y'
+  real, dimension(size(y)) :: realArray6
 end subroutine s7biii
 
 ! a specification inquiry that is a constant expression,
 subroutine s8()
   integer :: iVar
   real, dimension(bit_size(iVar)) :: realArray
 end subroutine s8
 

flang/test/Semantics/symbol13.f90

 ! RUN: %python %S/test_symbols.py %s %flang_fc1
 ! Old-style "*length" specifiers (R723)
 
 !DEF: /f1 (Function) Subprogram CHARACTER(1_8,1)
 !DEF: /f1/x1 INTENT(IN) ObjectEntity CHARACTER(2_4,1)
 !DEF: /f1/x2 INTENT(IN) ObjectEntity CHARACTER(3_4,1)
 character*1 function f1(x1, x2)
  !DEF: /f1/n PARAMETER ObjectEntity INTEGER(4)
  integer, parameter :: n = 2
  !REF: /f1/n
  !REF: /f1/x1
  !REF: /f1/x2
- !DEF: /f1/len ELEMENTAL, INTRINSIC, PURE (Function) ProcEntity
+ !DEF: /f1/len INTRINSIC, PURE (Function) ProcEntity
  character*(n), intent(in) :: x1, x2*(len(x1)+1)
  !DEF: /f1/t DerivedType
  type :: t
   !REF: /f1/len
   !REF: /f1/x2
   !DEF: /f1/t/c1 ObjectEntity CHARACTER(4_4,1)
   !DEF: /f1/t/c2 ObjectEntity CHARACTER(6_8,1)
   character*(len(x2)+1) :: c1, c2*6
  end type t
 end function f1