diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h index 82c31c0c40430..8aa065b025a4f 100644 --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -365,7 +365,7 @@ struct Procedure { static std::optional Characterize( const semantics::Symbol &, FoldingContext &); static std::optional Characterize( - const ProcedureDesignator &, FoldingContext &); + const ProcedureDesignator &, FoldingContext &, bool emitError); static std::optional Characterize( const ProcedureRef &, FoldingContext &); static std::optional Characterize( diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp index 688a856220a11..20f7476425ace 100644 --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -576,11 +576,11 @@ static std::optional CharacterizeDummyArgument( semantics::UnorderedSymbolSet seenProcs); static std::optional CharacterizeFunctionResult( const semantics::Symbol &symbol, FoldingContext &context, - semantics::UnorderedSymbolSet seenProcs); + semantics::UnorderedSymbolSet seenProcs, bool emitError); static std::optional 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,6 +591,13 @@ static std::optional 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) @@ -598,7 +605,7 @@ static std::optional CharacterizeProcedure( 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 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 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,7 +702,8 @@ static std::optional 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 @@ -703,25 +711,23 @@ static std::optional CharacterizeProcedure( return std::optional{}; }, [&](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{}; } }, [&](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{}; }, [&](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{}; }, [&](const auto &) { @@ -752,7 +758,8 @@ static std::optional CharacterizeProcedure( static std::optional 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::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( std::move(name), DummyProcedure{std::move(*proc)}); } else { @@ -988,7 +996,7 @@ bool FunctionResult::operator==(const FunctionResult &that) const { static std::optional CharacterizeFunctionResult( const semantics::Symbol &symbol, FoldingContext &context, - semantics::UnorderedSymbolSet seenProcs) { + semantics::UnorderedSymbolSet seenProcs, bool emitError) { if (const auto *object{symbol.detailsIf()}) { if (auto type{TypeAndShape::Characterize( symbol, context, /*invariantOnly=*/false)}) { @@ -1002,8 +1010,8 @@ static std::optional 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 CharacterizeFunctionResult( std::optional 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::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::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::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::Characterize( return Characterize(*procRef, context); } else if (const auto *procDesignator{ std::get_if(&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::Characterize( std::optional 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)) { diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp index 0e14aa0957294..7e42db7b6ed7a 100644 --- a/flang/lib/Evaluate/check-expression.cpp +++ b/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{ diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp index f514a25b01024..9a5f9130632ee 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/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()); } diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp index 47bd6ace4e4b5..8b62fe8c022f8 100644 --- a/flang/lib/Lower/Bridge.cpp +++ b/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>( diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp index 2d4d17a2ef12e..5ad244600328c 100644 --- a/flang/lib/Lower/CallInterface.cpp +++ b/flang/lib/Lower/CallInterface.cpp @@ -218,7 +218,7 @@ Fortran::lower::CallerInterface::characterize() const { converter.getFoldingContext(); std::optional 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 characteristics = Fortran::evaluate::characteristics::Procedure::Characterize( - procedure, converter.getFoldingContext()); + procedure, converter.getFoldingContext(), /*emitError=*/false); return ::mustPassLengthWithDummyProcedure(characteristics); } diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index bd2f755855172..6cbc3565dc377 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/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(&expr->u)}) { - procChars = - characteristics::Procedure::Characterize(*designator, context); + procChars = characteristics::Procedure::Characterize( + *designator, context, /*emitError=*/true); } else if (const auto *ref{ std::get_if(&expr->u)}) { procChars = characteristics::Procedure::Characterize(*ref, context); diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index 6af86de9dd81c..a270e4b385e8d 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -2562,7 +2562,8 @@ std::pair ExpressionAnalyzer::ResolveGeneric( } if (std::optional procedure{ characteristics::Procedure::Characterize( - ProcedureDesignator{specific}, context_.foldingContext())}) { + ProcedureDesignator{specific}, context_.foldingContext(), + /*emitError=*/false)}) { ActualArguments localActuals{actuals}; if (specific.has()) { if (!adjustActuals.value()(specific, localActuals)) { @@ -3164,7 +3165,7 @@ std::optional ExpressionAnalyzer::CheckCall( } if (!chars) { chars = characteristics::Procedure::Characterize( - proc, context_.foldingContext()); + proc, context_.foldingContext(), /*emitError=*/true); } bool ok{true}; if (chars) { diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp index 4b4ce153084d8..60a496a63cb38 100644 --- a/flang/lib/Semantics/pointer-assignment.cpp +++ b/flang/lib/Semantics/pointer-assignment.cpp @@ -244,7 +244,8 @@ bool PointerAssignmentChecker::Check(const evaluate::FunctionRef &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); diff --git a/flang/test/Semantics/resolve102.f90 b/flang/test/Semantics/resolve102.f90 index 11f2ce9c8ea56..8f6e2246a57e7 100644 --- a/flang/test/Semantics/resolve102.f90 +++ b/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 +