[flang] Check constraint C1577 for statement functions

[klausler]

Summary

Check most of the requiremens of constraint C1577 for statement functions.
The restrictions that prevent recursion are hard errors; the others seem
to be benign legacies and are caught as portability warnings.

[jeanPerier]

LGTM

flang/include/flang/Evaluate/check-expression.h

 template <typename A>
 bool IsSimplyContiguous(const A &x, FoldingContext &context) {
   return IsContiguous(x, context).value_or(false);
 }
 
 template <typename A> bool IsErrorExpr(const A &);
 extern template bool IsErrorExpr(const Expr<SomeType> &);
 
+std::optional<parser::Message> CheckStatementFunction(
+    const Symbol &, const Expr<SomeType> &, FoldingContext &);
+
 } // namespace Fortran::evaluate
 #endif

flang/include/flang/Semantics/expression.h

public:
   }
   MaybeExpr Analyze(const parser::StructureComponent &);
   MaybeExpr Analyze(const parser::SignedIntLiteralConstant &);
   MaybeExpr Analyze(const parser::SignedRealLiteralConstant &);
   MaybeExpr Analyze(const parser::SignedComplexLiteralConstant &);
   MaybeExpr Analyze(const parser::StructureConstructor &);
   MaybeExpr Analyze(const parser::InitialDataTarget &);
   MaybeExpr Analyze(const parser::NullInit &);
+  MaybeExpr Analyze(const parser::StmtFunctionStmt &);
 
   void Analyze(const parser::CallStmt &);
   const Assignment *Analyze(const parser::AssignmentStmt &);
   const Assignment *Analyze(const parser::PointerAssignmentStmt &);
 
   // Builds a typed Designator from an untyped DataRef
   MaybeExpr Designate(DataRef &&);
 
private:
   semantics::SemanticsContext &context_;
   FoldingContext &foldingContext_{context_.foldingContext()};
   std::map<parser::CharBlock, int> impliedDos_; // values are INTEGER kinds
   bool isWholeAssumedSizeArrayOk_{false};
   bool isNullPointerOk_{false};
   bool useSavedTypedExprs_{true};
   bool inWhereBody_{false};
   bool inDataStmtConstant_{false};
+  bool inStmtFunctionDefinition_{false};
   friend class ArgumentAnalyzer;
 };
 
 inline bool AreConformable(int leftRank, int rightRank) {
   return leftRank == 0 || rightRank == 0 || leftRank == rightRank;
 }
 
 template <typename L, typename R>

flang/include/flang/Semantics/symbol.h

using Details = std::variant<UnknownDetails, MainProgramDetails, ModuleDetails,
     GenericDetails, ProcBindingDetails, NamelistDetails, CommonBlockDetails,
     TypeParamDetails, MiscDetails>;
 llvm::raw_ostream &operator<<(llvm::raw_ostream &, const Details &);
 std::string DetailsToString(const Details &);
 
 class Symbol {
 public:
   ENUM_CLASS(Flag,
-      Function, // symbol is a function
+      Function, // symbol is a function or statement function
       Subroutine, // symbol is a subroutine
-      StmtFunction, // symbol is a statement function (Function is set too)
+      StmtFunction, // symbol is a statement function or result
       Implicit, // symbol is implicitly typed
       ImplicitOrError, // symbol must be implicitly typed or it's an error
       ModFile, // symbol came from .mod file
       ParentComp, // symbol is the "parent component" of an extended type
       CrayPointer, CrayPointee,
       LocalityLocal, // named in LOCAL locality-spec
       LocalityLocalInit, // named in LOCAL_INIT locality-spec
       LocalityShared, // named in SHARED locality-spec

flang/lib/Evaluate/check-expression.cpp

 };
 
 template <typename A> bool IsErrorExpr(const A &x) {
   return IsErrorExprHelper{}(x);
 }
 
 template bool IsErrorExpr(const Expr<SomeType> &);
 
+// C1577
+// TODO: Also check C1579 & C1582 here
+class StmtFunctionChecker
+    : public AnyTraverse<StmtFunctionChecker, std::optional<parser::Message>> {
+public:
+  using Result = std::optional<parser::Message>;
+  using Base = AnyTraverse<StmtFunctionChecker, Result>;
+  StmtFunctionChecker(const Symbol &sf, FoldingContext &context)
+      : Base{*this}, sf_{sf}, context_{context} {}
+  using Base::operator();
+
+  template <typename T> Result operator()(const ArrayConstructor<T> &) const {
+    return parser::Message{sf_.name(),
+        "Statement function '%s' should not contain an array constructor"_port_en_US,
+        sf_.name()};
+  }
+  Result operator()(const StructureConstructor &) const {
+    return parser::Message{sf_.name(),
+        "Statement function '%s' should not contain a structure constructor"_port_en_US,
+        sf_.name()};
+  }
+  Result operator()(const TypeParamInquiry &) const {
+    return parser::Message{sf_.name(),
+        "Statement function '%s' should not contain a type parameter inquiry"_port_en_US,
+        sf_.name()};
+  }
+  Result operator()(const ProcedureDesignator &proc) const {
+    if (const Symbol * symbol{proc.GetSymbol()}) {
+      const Symbol &ultimate{symbol->GetUltimate()};
+      if (const auto *subp{
+              ultimate.detailsIf<semantics::SubprogramDetails>()}) {
+        if (subp->stmtFunction() && &ultimate.owner() == &sf_.owner()) {
+          if (ultimate.name().begin() > sf_.name().begin()) {
+            return parser::Message{sf_.name(),
+                "Statement function '%s' may not reference another statement function '%s' that is defined later"_err_en_US,
+                sf_.name(), ultimate.name()};
+          }
+        }
+      }
+      if (auto chars{
+              characteristics::Procedure::Characterize(proc, context_)}) {
+        if (!chars->CanBeCalledViaImplicitInterface()) {
+          return parser::Message(sf_.name(),
+              "Statement function '%s' should not reference function '%s' that requires an explicit interface"_port_en_US,
+              sf_.name(), symbol->name());
+        }
+      }
+    }
+    if (proc.Rank() > 0) {
+      return parser::Message(sf_.name(),
+          "Statement function '%s' should not reference a function that returns an array"_port_en_US,
+          sf_.name());
+    }
+    return std::nullopt;
+  }
+  Result operator()(const ActualArgument &arg) const {
+    if (const auto *expr{arg.UnwrapExpr()}) {
+      if (auto result{(*this)(*expr)}) {
+        return result;
+      }
+      if (expr->Rank() > 0 && !UnwrapWholeSymbolOrComponentDataRef(*expr)) {
+        return parser::Message(sf_.name(),
+            "Statement function '%s' should not pass an array argument that is not a whole array"_port_en_US,
+            sf_.name());
+      }
+    }
+    return std::nullopt;
+  }
+
+private:
+  const Symbol &sf_;
+  FoldingContext &context_;
+};
+
+std::optional<parser::Message> CheckStatementFunction(
+    const Symbol &sf, const Expr<SomeType> &expr, FoldingContext &context) {
+  return StmtFunctionChecker{sf, context}(expr);
+}
+
 } // namespace Fortran::evaluate

flang/lib/Evaluate/tools.cpp

bool IsPureProcedure(const Symbol &original) {
   } else if (!IsProcedure(symbol)) {
     return false;
   }
   if (IsStmtFunction(symbol)) {
     // Section 15.7(1) states that a statement function is PURE if it does not
     // reference an IMPURE procedure or a VOLATILE variable
     if (const auto &expr{symbol.get<SubprogramDetails>().stmtFunction()}) {
       for (const SymbolRef &ref : evaluate::CollectSymbols(*expr)) {
+        if (&*ref == &symbol) {
+          return false; // error recovery, recursion is caught elsewhere
+        }
         if (IsFunction(*ref) && !IsPureProcedure(*ref)) {
           return false;
         }
         if (ref->GetUltimate().attrs().test(Attr::VOLATILE)) {
           return false;
         }
       }
     }

flang/lib/Semantics/check-declarations.cpp

if (const Scope *entryScope{details.entryScope()}) {
     if (error) {
       if (auto *msg{messages_.Say(symbol.name(), *error)}) {
         if (subprogram) {
           msg->Attach(subprogram->name(), "Containing subprogram"_en_US);
         }
       }
     }
   }
+  if (const MaybeExpr & stmtFunction{details.stmtFunction()}) {
+    if (auto msg{evaluate::CheckStatementFunction(
+            symbol, *stmtFunction, context_.foldingContext())}) {
+      SayWithDeclaration(symbol, std::move(*msg));
+    }
+  }
   if (IsElementalProcedure(symbol)) {
     // See comment on the similar check in CheckProcEntity()
     if (details.isDummy()) {
       messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
     } else {
       for (const Symbol *dummy : details.dummyArgs()) {
         if (!dummy) { // C15100
           messages_.Say(

flang/lib/Semantics/expression.cpp

if (MaybeExpr value{Analyze(n.v.value())}) {
     // or components (e.g., T()).  Checking the result to ensure
     // that a "=>" data entity initializer actually resolved to
     // a null pointer has to be done by the caller.
     return Fold(std::move(*value));
   }
   return std::nullopt;
 }
 
+MaybeExpr ExpressionAnalyzer::Analyze(
+    const parser::StmtFunctionStmt &stmtFunc) {
+  inStmtFunctionDefinition_ = true;
+  return Analyze(std::get<parser::Scalar<parser::Expr>>(stmtFunc.t));
+}
+
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::InitialDataTarget &x) {
   return Analyze(x.value());
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::DataStmtValue &x) {
   if (const auto &repeat{
           std::get<std::optional<parser::DataStmtRepeat>>(x.t)}) {
     x.repetitions = -1;
if (details->kind() == semantics::SubprogramKind::Module) {
         // already been in the process of resolving the function's
         // specification part; but recursive function calls are not
         // allowed in specification parts (10.1.11 para 5).
         Say("The module function '%s' may not be referenced recursively in a specification expression"_err_en_US,
             symbol.name());
         context_.SetError(symbol);
         return false;
       }
+    } else if (inStmtFunctionDefinition_) {
+      semantics::ResolveSpecificationParts(context_, symbol);
+      CHECK(symbol.has<semantics::SubprogramDetails>());
     } else { // 10.1.11 para 4
       Say("The internal function '%s' may not be referenced in a specification expression"_err_en_US,
           symbol.name());
       context_.SetError(symbol);
       return false;
     }
   }
   return true;
if (!name) {
     name = &std::get<parser::ProcComponentRef>(proc.u).v.thing.component;
   }
   if (!name->symbol) {
     return false;
   } else if (name->symbol->Rank() == 0) {
     if (const Symbol *function{
             semantics::IsFunctionResultWithSameNameAsFunction(*name->symbol)}) {
       auto &msg{context.Say(funcRef.v.source,
-          "Recursive call to '%s' requires a distinct RESULT in its declaration"_err_en_US,
+          function->flags().test(Symbol::Flag::StmtFunction)
+              ? "Recursive call to statement function '%s' is not allowed"_err_en_US
+              : "Recursive call to '%s' requires a distinct RESULT in its declaration"_err_en_US,
           name->source)};
       AttachDeclaration(&msg, *function);
       name->symbol = const_cast<Symbol *>(function);
     }
     return false;
   } else {
     if (std::get<std::list<parser::ActualArgSpec>>(funcRef.v.t).empty()) {
       auto &msg{context.Say(funcRef.v.source,

flang/lib/Semantics/resolve-names.cpp

 
 // Return false if it is actually an assignment statement.
 bool SubprogramVisitor::HandleStmtFunction(const parser::StmtFunctionStmt &x) {
   const auto &name{std::get<parser::Name>(x.t)};
   const DeclTypeSpec *resultType{nullptr};
   // Look up name: provides return type or tells us if it's an array
   if (auto *symbol{FindSymbol(name)}) {
     auto *details{symbol->detailsIf<EntityDetails>()};
-    if (!details) {
+    if (!details || symbol->has<ObjectEntityDetails>() ||
+        symbol->has<ProcEntityDetails>()) {
       badStmtFuncFound_ = true;
       return false;
     }
     // TODO: check that attrs are compatible with stmt func
     resultType = details->type();
     symbol->details() = UnknownDetails{}; // will be replaced below
   }
   if (badStmtFuncFound_) {
     Say(name, "'%s' has not been declared as an array"_err_en_US);
-    return true;
+    return false;
   }
   auto &symbol{PushSubprogramScope(name, Symbol::Flag::Function)};
   symbol.set(Symbol::Flag::StmtFunction);
   EraseSymbol(symbol); // removes symbol added by PushSubprogramScope
   auto &details{symbol.get<SubprogramDetails>()};
   for (const auto &dummyName : std::get<std::list<parser::Name>>(x.t)) {
     ObjectEntityDetails dummyDetails{true};
     if (auto *dummySymbol{FindInScope(currScope().parent(), dummyName)}) {
       if (auto *d{dummySymbol->detailsIf<EntityDetails>()}) {
         if (d->type()) {
           dummyDetails.set_type(*d->type());
         }
       }
     }
     Symbol &dummy{MakeSymbol(dummyName, std::move(dummyDetails))};
     ApplyImplicitRules(dummy);
     details.add_dummyArg(dummy);
   }
   ObjectEntityDetails resultDetails;
   if (resultType) {
     resultDetails.set_type(*resultType);
   }
   resultDetails.set_funcResult(true);
   Symbol &result{MakeSymbol(name, std::move(resultDetails))};
+  result.flags().set(Symbol::Flag::StmtFunction);
   ApplyImplicitRules(result);
   details.set_result(result);
-  const auto &parsedExpr{std::get<parser::Scalar<parser::Expr>>(x.t)};
-  Walk(parsedExpr);
   // The analysis of the expression that constitutes the body of the
   // statement function is deferred to FinishSpecificationPart() so that
   // all declarations and implicit typing are complete.
   PopScope();
   return true;
 }
 
 bool SubprogramVisitor::Pre(const parser::Suffix &suffix) {
if (!inInterfaceBlock()) {
     // TODO: warn for the case where the EQUIVALENCE statement is in a
     // procedure declaration in an interface block
     CheckEquivalenceSets();
   }
 }
 
 // Analyze the bodies of statement functions now that the symbols in this
 // specification part have been fully declared and implicitly typed.
+// (Statement function references are not allowed in specification
+// expressions, so it's safe to defer processing their definitions.)
 void ResolveNamesVisitor::AnalyzeStmtFunctionStmt(
     const parser::StmtFunctionStmt &stmtFunc) {
   Symbol *symbol{std::get<parser::Name>(stmtFunc.t).symbol};
-  if (!symbol || !symbol->has<SubprogramDetails>()) {
-    return;
-  }
-  auto &details{symbol->get<SubprogramDetails>()};
-  auto expr{AnalyzeExpr(
-      context(), std::get<parser::Scalar<parser::Expr>>(stmtFunc.t))};
-  if (!expr) {
-    context().SetError(*symbol);
+  auto *details{symbol ? symbol->detailsIf<SubprogramDetails>() : nullptr};
+  if (!details || !symbol->scope()) {
     return;
   }
+  // Resolve the symbols on the RHS of the statement function.
+  PushScope(*symbol->scope());
+  const auto &parsedExpr{std::get<parser::Scalar<parser::Expr>>(stmtFunc.t)};
+  Walk(parsedExpr);
+  PopScope();
+  if (auto expr{AnalyzeExpr(context(), stmtFunc)}) {
     if (auto type{evaluate::DynamicType::From(*symbol)}) {
-    auto converted{ConvertToType(*type, std::move(*expr))};
-    if (!converted) {
-      context().SetError(*symbol);
-      return;
+      if (auto converted{ConvertToType(*type, std::move(*expr))}) {
+        details->set_stmtFunction(std::move(*converted));
       }
-    details.set_stmtFunction(std::move(*converted));
     } else {
-    details.set_stmtFunction(std::move(*expr));
+      details->set_stmtFunction(std::move(*expr));
+    }
+  }
+  if (!details->stmtFunction()) {
+    context().SetError(*symbol);
   }
 }
 
 void ResolveNamesVisitor::CheckImports() {
   auto &scope{currScope()};
   switch (scope.GetImportKind()) {
   case common::ImportKind::None:
     break;
public:
   void Post(const parser::TypeBoundProcedureStmt::WithInterface &tbps) {
     resolver_.CheckExplicitInterface(tbps.interfaceName);
   }
   void Post(const parser::TypeBoundProcedureStmt::WithoutInterface &tbps) {
     if (pushedScope_) {
       resolver_.CheckBindings(tbps);
     }
   }
+  bool Pre(const parser::StmtFunctionStmt &stmtFunc) { return false; }
 
 private:
   void Init(const parser::Name &name,
       const std::optional<parser::Initialization> &init) {
     if (init) {
       if (const auto *target{
               std::get_if<parser::InitialDataTarget>(&init->u)}) {
         resolver_.PointerInitialization(name, *target);
       }
     }
   }
 
   ResolveNamesVisitor &resolver_;
   bool pushedScope_{false};
 };
 
 // Perform checks and completions that need to happen after all of
 // the specification parts but before any of the execution parts.
 void ResolveNamesVisitor::FinishSpecificationParts(const ProgramTree &node) {
   if (!node.scope()) {
     return; // error occurred creating scope
   }
   SetScope(*node.scope());
   // The initializers of pointers, the default initializers of pointer
-  // components, and non-deferred type-bound procedure bindings have not
+  // components, non-deferred type-bound procedure bindings have not
   // yet been traversed.
   // We do that now, when any (formerly) forward references that appear
   // in those initializers will resolve to the right symbols without
   // incurring spurious errors with IMPLICIT NONE.
   DeferredCheckVisitor{*this}.Walk(node.spec());
   DeferredCheckVisitor{*this}.Walk(node.exec()); // for BLOCK
   for (Scope &childScope : currScope().children()) {
     if (childScope.IsParameterizedDerivedTypeInstantiation()) {

flang/test/Semantics/stmt-func01.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! C1577
+program main
+  type t1(k,l)
+    integer, kind :: k = kind(1)
+    integer, len :: l = 666
+    integer(k) n
+  end type t1
+  interface
+    pure integer function ifunc()
+    end function
+  end interface
+  type(t1(k=4,l=ifunc())) x1
+  !PORTABILITY: Statement function 'sf1' should not contain an array constructor
+  sf1(n) = sum([(j,j=1,n)])
+  type(t1) sf2
+  !PORTABILITY: Statement function 'sf2' should not contain a structure constructor
+  sf2(n) = t1(n)
+  !PORTABILITY: Statement function 'sf3' should not contain a type parameter inquiry
+  sf3(n) = x1%l
+  !ERROR: Recursive call to statement function 'sf4' is not allowed
+  sf4(n) = sf4(n)
+  !ERROR: Statement function 'sf5' may not reference another statement function 'sf6' that is defined later
+  sf5(n) = sf6(n)
+  real sf7
+  !ERROR: Statement function 'sf6' may not reference another statement function 'sf7' that is defined later
+  sf6(n) = sf7(n)
+  !PORTABILITY: Statement function 'sf7' should not reference function 'explicit' that requires an explicit interface
+  sf7(n) = explicit(n)
+  real :: a(3) = [1., 2., 3.]
+  !PORTABILITY: Statement function 'sf8' should not pass an array argument that is not a whole array
+  sf8(n) = sum(a(1:2))
+  sf8a(n) = sum(a) ! ok
+ contains
+  real function explicit(x,y)
+    integer, intent(in) :: x
+    integer, intent(in), optional :: y
+    explicit = x
+  end function
+  pure function arr()
+    real :: arr(2)
+    arr = [1., 2.]
+  end function
+end