[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 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

   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 &);

   bool useSavedTypedExprs_{true};
   bool inWhereBody_{false};
   bool inDataStmtConstant_{false};
+  bool inStmtFunctionDefinition_{false};
   friend class ArgumentAnalyzer;
 };
 

flang/include/flang/Semantics/symbol.h

 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

flang/lib/Evaluate/check-expression.cpp

 
 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

     // 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;
         }

flang/lib/Semantics/check-declarations.cpp

       }
     }
   }
+  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()) {

flang/lib/Semantics/expression.cpp

   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());
 }

         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());

         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);

flang/lib/Semantics/resolve-names.cpp

   // 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;
     }

   }
   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);

   }
   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.

 
 // 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;
   }
-  if (auto type{evaluate::DynamicType::From(*symbol)}) {
-    auto converted{ConvertToType(*type, std::move(*expr))};
-    if (!converted) {
-      context().SetError(*symbol);
-      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)}) {
+      if (auto converted{ConvertToType(*type, std::move(*expr))}) {
+        details->set_stmtFunction(std::move(*converted));
+      }
+    } else {
+      details->set_stmtFunction(std::move(*expr));
     }
-    details.set_stmtFunction(std::move(*converted));
-  } else {
-    details.set_stmtFunction(std::move(*expr));
+  }
+  if (!details->stmtFunction()) {
+    context().SetError(*symbol);
   }
 }
 

       resolver_.CheckBindings(tbps);
     }
   }
+  bool Pre(const parser::StmtFunctionStmt &stmtFunc) { return false; }
 
 private:
   void Init(const parser::Name &name,

   }
   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

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