[flang] Make proc characterization error conditional for generics

flang/include/flang/Evaluate/characteristics.h

@@ -365,7 +365,7 @@ struct Procedure {
   static std::optional<Procedure> Characterize(
       const semantics::Symbol &, FoldingContext &);
   static std::optional<Procedure> Characterize(
-      const ProcedureDesignator &, FoldingContext &);
+      const ProcedureDesignator &, FoldingContext &, bool emitError);
   static std::optional<Procedure> Characterize(
       const ProcedureRef &, FoldingContext &);
   static std::optional<Procedure> Characterize(

flang/lib/Evaluate/characteristics.cpp

@@ -576,11 +576,11 @@ static std::optional<DummyArgument> CharacterizeDummyArgument(
     semantics::UnorderedSymbolSet seenProcs);
 static std::optional<FunctionResult> CharacterizeFunctionResult(
     const semantics::Symbol &symbol, FoldingContext &context,
-    semantics::UnorderedSymbolSet seenProcs);
+    semantics::UnorderedSymbolSet seenProcs, bool emitError);
 
 static std::optional<Procedure> CharacterizeProcedure(
     const semantics::Symbol &original, FoldingContext &context,
-    semantics::UnorderedSymbolSet seenProcs) {
+    semantics::UnorderedSymbolSet seenProcs, bool emitError) {
   const auto &symbol{ResolveAssociations(original)};
   if (seenProcs.find(symbol) != seenProcs.end()) {
     std::string procsList{GetSeenProcs(seenProcs)};
@@ -591,14 +591,21 @@ static std::optional<Procedure> CharacterizeProcedure(
     return std::nullopt;
   }
   seenProcs.insert(symbol);
+  auto CheckForNested{[&](const Symbol &symbol) {
+    if (emitError) {
+      context.messages().Say(
+          "Procedure '%s' is referenced before being sufficiently defined in a context where it must be so"_err_en_US,
+          symbol.name());
+    }
+  }};
   auto result{common::visit(
       common::visitors{
           [&](const semantics::SubprogramDetails &subp)
               -> std::optional<Procedure> {
             Procedure result;
             if (subp.isFunction()) {
               if (auto fr{CharacterizeFunctionResult(
-                      subp.result(), context, seenProcs)}) {
+                      subp.result(), context, seenProcs, emitError)}) {
                 result.functionResult = std::move(fr);
               } else {
                 return std::nullopt;
@@ -641,8 +648,8 @@ static std::optional<Procedure> CharacterizeProcedure(
             }
             if (const semantics::Symbol *
                 interfaceSymbol{proc.procInterface()}) {
-              auto result{
-                  CharacterizeProcedure(*interfaceSymbol, context, seenProcs)};
+              auto result{CharacterizeProcedure(
+                  *interfaceSymbol, context, seenProcs, /*emitError=*/false)};
               if (result && (IsDummy(symbol) || IsPointer(symbol))) {
                 // Dummy procedures and procedure pointers may not be
                 // ELEMENTAL, but we do accept the use of elemental intrinsic
@@ -675,8 +682,8 @@ static std::optional<Procedure> CharacterizeProcedure(
             }
           },
           [&](const semantics::ProcBindingDetails &binding) {
-            if (auto result{CharacterizeProcedure(
-                    binding.symbol(), context, seenProcs)}) {
+            if (auto result{CharacterizeProcedure(binding.symbol(), context,
+                    seenProcs, /*emitError=*/false)}) {
               if (binding.symbol().attrs().test(semantics::Attr::INTRINSIC)) {
                 result->attrs.reset(Procedure::Attr::Elemental);
               }
@@ -695,33 +702,32 @@ static std::optional<Procedure> CharacterizeProcedure(
             }
           },
           [&](const semantics::UseDetails &use) {
-            return CharacterizeProcedure(use.symbol(), context, seenProcs);
+            return CharacterizeProcedure(
+                use.symbol(), context, seenProcs, /*emitError=*/false);
           },
           [](const semantics::UseErrorDetails &) {
             // Ambiguous use-association will be handled later during symbol
             // checks, ignore UseErrorDetails here without actual symbol usage.
             return std::optional<Procedure>{};
           },
           [&](const semantics::HostAssocDetails &assoc) {
-            return CharacterizeProcedure(assoc.symbol(), context, seenProcs);
+            return CharacterizeProcedure(
+                assoc.symbol(), context, seenProcs, /*emitError=*/false);
           },
           [&](const semantics::GenericDetails &generic) {
             if (const semantics::Symbol * specific{generic.specific()}) {
-              return CharacterizeProcedure(*specific, context, seenProcs);
+              return CharacterizeProcedure(
+                  *specific, context, seenProcs, emitError);
             } else {
               return std::optional<Procedure>{};
             }
           },
           [&](const semantics::EntityDetails &) {
-            context.messages().Say(
-                "Procedure '%s' is referenced before being sufficiently defined in a context where it must be so"_err_en_US,
-                symbol.name());
+            CheckForNested(symbol);
             return std::optional<Procedure>{};
           },
           [&](const semantics::SubprogramNameDetails &) {
-            context.messages().Say(
-                "Procedure '%s' is referenced before being sufficiently defined in a context where it must be so"_err_en_US,
-                symbol.name());
+            CheckForNested(symbol);
             return std::optional<Procedure>{};
           },
           [&](const auto &) {
@@ -752,7 +758,8 @@ static std::optional<Procedure> CharacterizeProcedure(
 static std::optional<DummyProcedure> CharacterizeDummyProcedure(
     const semantics::Symbol &symbol, FoldingContext &context,
     semantics::UnorderedSymbolSet seenProcs) {
-  if (auto procedure{CharacterizeProcedure(symbol, context, seenProcs)}) {
+  if (auto procedure{CharacterizeProcedure(
+          symbol, context, seenProcs, /*emitError=*/true)}) {
     // Dummy procedures may not be elemental.  Elemental dummy procedure
     // interfaces are errors when the interface is not intrinsic, and that
     // error is caught elsewhere.  Elemental intrinsic interfaces are
@@ -854,7 +861,8 @@ std::optional<DummyArgument> DummyArgument::FromActual(std::string &&name,
                 std::move(name), std::move(obj));
           },
           [&](const ProcedureDesignator &designator) {
-            if (auto proc{Procedure::Characterize(designator, context)}) {
+            if (auto proc{Procedure::Characterize(
+                    designator, context, /*emitError=*/true)}) {
               return std::make_optional<DummyArgument>(
                   std::move(name), DummyProcedure{std::move(*proc)});
             } else {
@@ -988,7 +996,7 @@ bool FunctionResult::operator==(const FunctionResult &that) const {
 
 static std::optional<FunctionResult> CharacterizeFunctionResult(
     const semantics::Symbol &symbol, FoldingContext &context,
-    semantics::UnorderedSymbolSet seenProcs) {
+    semantics::UnorderedSymbolSet seenProcs, bool emitError) {
   if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     if (auto type{TypeAndShape::Characterize(
             symbol, context, /*invariantOnly=*/false)}) {
@@ -1002,8 +1010,8 @@ static std::optional<FunctionResult> CharacterizeFunctionResult(
       result.cudaDataAttr = object->cudaDataAttr();
       return result;
     }
-  } else if (auto maybeProc{
-                 CharacterizeProcedure(symbol, context, seenProcs)}) {
+  } else if (auto maybeProc{CharacterizeProcedure(
+                 symbol, context, seenProcs, emitError)}) {
     FunctionResult result{std::move(*maybeProc)};
     result.attrs.set(FunctionResult::Attr::Pointer);
     return result;
@@ -1014,7 +1022,8 @@ static std::optional<FunctionResult> CharacterizeFunctionResult(
 std::optional<FunctionResult> FunctionResult::Characterize(
     const Symbol &symbol, FoldingContext &context) {
   semantics::UnorderedSymbolSet seenProcs;
-  return CharacterizeFunctionResult(symbol, context, seenProcs);
+  return CharacterizeFunctionResult(
+      symbol, context, seenProcs, /*emitError=*/false);
 }
 
 bool FunctionResult::IsAssumedLengthCharacter() const {
@@ -1360,27 +1369,26 @@ bool Procedure::CanOverride(
 }
 
 std::optional<Procedure> Procedure::Characterize(
-    const semantics::Symbol &original, FoldingContext &context) {
+    const semantics::Symbol &symbol, FoldingContext &context) {
   semantics::UnorderedSymbolSet seenProcs;
-  return CharacterizeProcedure(original, context, seenProcs);
+  return CharacterizeProcedure(symbol, context, seenProcs, /*emitError=*/true);
 }
 
 std::optional<Procedure> Procedure::Characterize(
-    const ProcedureDesignator &proc, FoldingContext &context) {
+    const ProcedureDesignator &proc, FoldingContext &context, bool emitError) {
   if (const auto *symbol{proc.GetSymbol()}) {
-    if (auto result{
-            characteristics::Procedure::Characterize(*symbol, context)}) {
-      return result;
-    }
+    semantics::UnorderedSymbolSet seenProcs;
+    return CharacterizeProcedure(*symbol, context, seenProcs, emitError);
   } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) {
     return intrinsic->characteristics.value();
+  } else {
+    return std::nullopt;
   }
-  return std::nullopt;
 }
 
 std::optional<Procedure> Procedure::Characterize(
     const ProcedureRef &ref, FoldingContext &context) {
-  if (auto callee{Characterize(ref.proc(), context)}) {
+  if (auto callee{Characterize(ref.proc(), context, /*emitError=*/true)}) {
     if (callee->functionResult) {
       if (const Procedure *
           proc{callee->functionResult->IsProcedurePointer()}) {
@@ -1397,7 +1405,7 @@ std::optional<Procedure> Procedure::Characterize(
     return Characterize(*procRef, context);
   } else if (const auto *procDesignator{
                  std::get_if<ProcedureDesignator>(&expr.u)}) {
-    return Characterize(*procDesignator, context);
+    return Characterize(*procDesignator, context, /*emitError=*/true);
   } else if (const Symbol * symbol{UnwrapWholeSymbolOrComponentDataRef(expr)}) {
     return Characterize(*symbol, context);
   } else {
@@ -1409,7 +1417,7 @@ std::optional<Procedure> Procedure::Characterize(
 
 std::optional<Procedure> Procedure::FromActuals(const ProcedureDesignator &proc,
     const ActualArguments &args, FoldingContext &context) {
-  auto callee{Characterize(proc, context)};
+  auto callee{Characterize(proc, context, /*emitError=*/true)};
   if (callee) {
     if (callee->dummyArguments.empty() &&
         callee->attrs.test(Procedure::Attr::ImplicitInterface)) {

flang/lib/Evaluate/check-expression.cpp

@@ -666,8 +666,8 @@ class CheckSpecificationExprHelper
             "' not allowed for derived type components or type parameter"
             " values";
       }
-      if (auto procChars{
-              characteristics::Procedure::Characterize(x.proc(), context_)}) {
+      if (auto procChars{characteristics::Procedure::Characterize(
+              x.proc(), context_, /*emitError=*/true)}) {
         const auto iter{std::find_if(procChars->dummyArguments.begin(),
             procChars->dummyArguments.end(),
             [](const characteristics::DummyArgument &dummy) {
@@ -856,8 +856,8 @@ class IsContiguousHelper
   Result operator()(const Substring &) const { return std::nullopt; }
 
   Result operator()(const ProcedureRef &x) const {
-    if (auto chars{
-            characteristics::Procedure::Characterize(x.proc(), context_)}) {
+    if (auto chars{characteristics::Procedure::Characterize(
+            x.proc(), context_, /*emitError=*/true)}) {
       if (chars->functionResult) {
         const auto &result{*chars->functionResult};
         if (!result.IsProcedurePointer()) {
@@ -1103,8 +1103,8 @@ class StmtFunctionChecker
           }
         }
       }
-      if (auto chars{
-              characteristics::Procedure::Characterize(proc, context_)}) {
+      if (auto chars{characteristics::Procedure::Characterize(
+              proc, context_, /*emitError=*/true)}) {
         if (!chars->CanBeCalledViaImplicitInterface()) {
           if (severity_) {
             auto msg{

flang/lib/Evaluate/tools.cpp

@@ -1056,8 +1056,8 @@ class FindImpureCallHelper
   explicit FindImpureCallHelper(FoldingContext &c) : Base{*this}, context_{c} {}
   using Base::operator();
   Result operator()(const ProcedureRef &call) const {
-    if (auto chars{
-            characteristics::Procedure::Characterize(call.proc(), context_)}) {
+    if (auto chars{characteristics::Procedure::Characterize(
+            call.proc(), context_, /*emitError=*/false)}) {
       if (chars->attrs.test(characteristics::Procedure::Attr::Pure)) {
         return (*this)(call.arguments());
       }

flang/lib/Lower/Bridge.cpp

@@ -3700,7 +3700,8 @@ class FirConverter : public Fortran::lower::AbstractConverter {
     using DummyAttr = Fortran::evaluate::characteristics::DummyDataObject::Attr;
     if (auto procedure =
             Fortran::evaluate::characteristics::Procedure::Characterize(
-                userDefinedAssignment.proc(), getFoldingContext()))
+                userDefinedAssignment.proc(), getFoldingContext(),
+                /*emitError=*/false))
       if (!procedure->dummyArguments.empty())
         if (const auto *dataArg = std::get_if<
                 Fortran::evaluate::characteristics::DummyDataObject>(

flang/lib/Lower/CallInterface.cpp

@@ -218,7 +218,7 @@ Fortran::lower::CallerInterface::characterize() const {
       converter.getFoldingContext();
   std::optional<Fortran::evaluate::characteristics::Procedure> characteristic =
       Fortran::evaluate::characteristics::Procedure::Characterize(
-          procRef.proc(), foldingContext);
+          procRef.proc(), foldingContext, /*emitError=*/false);
   assert(characteristic && "Failed to get characteristic from procRef");
   // The characteristic may not contain the argument characteristic if the
   // ProcedureDesignator has no interface, or may mismatch in case of implicit
@@ -1571,7 +1571,7 @@ class SignatureBuilder
                    Fortran::lower::AbstractConverter &c)
       : CallInterface{c}, procDesignator{&procDes},
         proc{Fortran::evaluate::characteristics::Procedure::Characterize(
-                 procDes, converter.getFoldingContext())
+                 procDes, converter.getFoldingContext(), /*emitError=*/false)
                  .value()} {}
   /// Does the procedure characteristics being translated have alternate
   /// returns ?
@@ -1696,7 +1696,7 @@ bool Fortran::lower::mustPassLengthWithDummyProcedure(
     Fortran::lower::AbstractConverter &converter) {
   std::optional<Fortran::evaluate::characteristics::Procedure> characteristics =
       Fortran::evaluate::characteristics::Procedure::Characterize(
-          procedure, converter.getFoldingContext());
+          procedure, converter.getFoldingContext(), /*emitError=*/false);
   return ::mustPassLengthWithDummyProcedure(characteristics);
 }
 

flang/lib/Semantics/check-call.cpp

@@ -1597,8 +1597,8 @@ static void CheckReduce(
     if (const auto *expr{operation->UnwrapExpr()}) {
       if (const auto *designator{
               std::get_if<evaluate::ProcedureDesignator>(&expr->u)}) {
-        procChars =
-            characteristics::Procedure::Characterize(*designator, context);
+        procChars = characteristics::Procedure::Characterize(
+            *designator, context, /*emitError=*/true);
       } else if (const auto *ref{
                      std::get_if<evaluate::ProcedureRef>(&expr->u)}) {
         procChars = characteristics::Procedure::Characterize(*ref, context);

flang/lib/Semantics/expression.cpp

@@ -2562,7 +2562,8 @@ std::pair<const Symbol *, bool> ExpressionAnalyzer::ResolveGeneric(
       }
       if (std::optional<characteristics::Procedure> procedure{
               characteristics::Procedure::Characterize(
-                  ProcedureDesignator{specific}, context_.foldingContext())}) {
+                  ProcedureDesignator{specific}, context_.foldingContext(),
+                  /*emitError=*/false)}) {
         ActualArguments localActuals{actuals};
         if (specific.has<semantics::ProcBindingDetails>()) {
           if (!adjustActuals.value()(specific, localActuals)) {
@@ -3164,7 +3165,7 @@ std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
   }
   if (!chars) {
     chars = characteristics::Procedure::Characterize(
-        proc, context_.foldingContext());
+        proc, context_.foldingContext(), /*emitError=*/true);
   }
   bool ok{true};
   if (chars) {

flang/lib/Semantics/pointer-assignment.cpp

@@ -244,7 +244,8 @@ bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
   } else if (const auto *intrinsic{f.proc().GetSpecificIntrinsic()}) {
     funcName = intrinsic->name;
   }
-  auto proc{Procedure::Characterize(f.proc(), foldingContext_)};
+  auto proc{
+      Procedure::Characterize(f.proc(), foldingContext_, /*emitError=*/true)};
   if (!proc) {
     return false;
   }
@@ -393,7 +394,8 @@ bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
           symbol->name());
     }
   }
-  if (auto chars{Procedure::Characterize(d, foldingContext_)}) {
+  if (auto chars{
+          Procedure::Characterize(d, foldingContext_, /*emitError=*/true)}) {
     // Disregard the elemental attribute of RHS intrinsics.
     if (symbol && symbol->GetUltimate().attrs().test(Attr::INTRINSIC)) {
       chars->attrs.reset(Procedure::Attr::Elemental);

flang/test/Semantics/resolve102.f90

@@ -106,3 +106,16 @@ pure integer function g(n)
     g = size(arr)
   end function
 end
+
+module genericInSpec
+  interface int
+    procedure ifunc
+  end interface
+ contains
+  function ifunc(x)
+    integer a(int(kind(1))) ! generic is ok with most compilers
+    integer(size(a)), intent(in) :: x
+    ifunc = x
+  end
+end
+