Index: flang/lib/Evaluate/tools.cpp =================================================================== --- flang/lib/Evaluate/tools.cpp +++ flang/lib/Evaluate/tools.cpp @@ -1199,20 +1199,21 @@ } bool IsFunction(const Symbol &symbol) { - return std::visit( - common::visitors{ - [](const SubprogramDetails &x) { return x.isFunction(); }, - [&](const SubprogramNameDetails &) { - return symbol.test(Symbol::Flag::Function); - }, - [](const ProcEntityDetails &x) { - const auto &ifc{x.interface()}; - return ifc.type() || (ifc.symbol() && IsFunction(*ifc.symbol())); - }, - [](const ProcBindingDetails &x) { return IsFunction(x.symbol()); }, - [](const auto &) { return false; }, - }, - symbol.GetUltimate().details()); + const Symbol &ultimate{symbol.GetUltimate()}; + return ultimate.test(Symbol::Flag::Function) || + std::visit(common::visitors{ + [](const SubprogramDetails &x) { return x.isFunction(); }, + [](const ProcEntityDetails &x) { + const auto &ifc{x.interface()}; + return ifc.type() || + (ifc.symbol() && IsFunction(*ifc.symbol())); + }, + [](const ProcBindingDetails &x) { + return IsFunction(x.symbol()); + }, + [](const auto &) { return false; }, + }, + ultimate.details()); } bool IsFunction(const Scope &scope) { Index: flang/lib/Semantics/resolve-names.cpp =================================================================== --- flang/lib/Semantics/resolve-names.cpp +++ flang/lib/Semantics/resolve-names.cpp @@ -746,6 +746,7 @@ class SubprogramVisitor : public virtual ScopeHandler, public InterfaceVisitor { public: + ~SubprogramVisitor(); bool HandleStmtFunction(const parser::StmtFunctionStmt &); bool Pre(const parser::SubroutineStmt &); void Post(const parser::SubroutineStmt &); @@ -759,7 +760,6 @@ void Post(const parser::InterfaceBody::Function &); bool Pre(const parser::Suffix &); bool Pre(const parser::PrefixSpec &); - void Post(const parser::ImplicitPart &); bool BeginSubprogram( const parser::Name &, Symbol::Flag, bool hasModulePrefix = false); @@ -768,18 +768,21 @@ void EndSubprogram(); protected: + void FinishFunctionResult(); // Set when we see a stmt function that is really an array element assignment bool badStmtFuncFound_{false}; private: // Info about the current function: parse tree of the type in the PrefixSpec; // name and symbol of the function result from the Suffix; source location. - struct { + struct FuncInfo { const parser::DeclarationTypeSpec *parsedType{nullptr}; const parser::Name *resultName{nullptr}; Symbol *resultSymbol{nullptr}; std::optional source; - } funcInfo_; + bool inFunctionStmt{false}; // true between Pre/Post of FunctionStmt + }; + std::vector funcInfoStack_; // Edits an existing symbol created for earlier calls to a subprogram or ENTRY // so that it can be replaced by a later definition. @@ -1456,6 +1459,7 @@ void ResolveSpecificationParts(ProgramTree &); void AddSubpNames(ProgramTree &); bool BeginScopeForNode(const ProgramTree &); + void EndScopeForNode(const ProgramTree &); void FinishSpecificationParts(const ProgramTree &); void FinishDerivedTypeInstantiation(Scope &); void ResolveExecutionParts(const ProgramTree &); @@ -2943,6 +2947,8 @@ // SubprogramVisitor implementation +SubprogramVisitor::~SubprogramVisitor() { CHECK(funcInfoStack_.empty()); } + // Return false if it is actually an assignment statement. bool SubprogramVisitor::HandleStmtFunction(const parser::StmtFunctionStmt &x) { const auto &name{std::get(x.t)}; @@ -2998,7 +3004,22 @@ bool SubprogramVisitor::Pre(const parser::Suffix &suffix) { if (suffix.resultName) { - funcInfo_.resultName = &suffix.resultName.value(); + if (IsFunction(currScope())) { + if (!funcInfoStack_.empty()) { + FuncInfo &info{funcInfoStack_.back()}; + if (info.inFunctionStmt) { + info.resultName = &suffix.resultName.value(); + } else { + // will check the result name in Post(EntryStmt) + } + } + } else { + Message &msg{Say(*suffix.resultName, + "RESULT(%s) may appear only in a function"_err_en_US)}; + if (const Symbol * subprogram{InclusiveScope().symbol()}) { + msg.Attach(subprogram->name(), "Containing subprogram"_en_US); + } + } } return true; } @@ -3006,13 +3027,15 @@ bool SubprogramVisitor::Pre(const parser::PrefixSpec &x) { // Save this to process after UseStmt and ImplicitPart if (const auto *parsedType{std::get_if(&x.u)}) { - if (funcInfo_.parsedType) { // C1543 + CHECK(!funcInfoStack_.empty()); + FuncInfo &info{funcInfoStack_.back()}; + if (info.parsedType) { // C1543 Say(currStmtSource().value(), "FUNCTION prefix cannot specify the type more than once"_err_en_US); return false; } else { - funcInfo_.parsedType = parsedType; - funcInfo_.source = currStmtSource(); + info.parsedType = parsedType; + info.source = currStmtSource(); return false; } } else { @@ -3020,17 +3043,21 @@ } } -void SubprogramVisitor::Post(const parser::ImplicitPart &) { - // If the function has a type in the prefix, process it now - if (funcInfo_.parsedType) { - messageHandler().set_currStmtSource(funcInfo_.source); - if (const auto *type{ProcessTypeSpec(*funcInfo_.parsedType, true)}) { - if (!context().HasError(funcInfo_.resultSymbol)) { - funcInfo_.resultSymbol->SetType(*type); +void SubprogramVisitor::FinishFunctionResult() { + // If the function has a type in the prefix, process it now. + if (IsFunction(currScope())) { + CHECK(!funcInfoStack_.empty()); + FuncInfo &info{funcInfoStack_.back()}; + if (info.parsedType) { + messageHandler().set_currStmtSource(info.source); + if (const auto *type{ProcessTypeSpec(*info.parsedType, true)}) { + if (!context().HasError(info.resultSymbol)) { + info.resultSymbol->SetType(*type); + } } + info.parsedType = nullptr; } } - funcInfo_ = {}; } bool SubprogramVisitor::Pre(const parser::InterfaceBody::Subroutine &x) { @@ -3054,6 +3081,10 @@ return BeginAttrs(); } bool SubprogramVisitor::Pre(const parser::FunctionStmt &) { + CHECK(!funcInfoStack_.empty()); + FuncInfo &info{funcInfoStack_.back()}; + CHECK(!info.inFunctionStmt); + info.inFunctionStmt = true; return BeginAttrs(); } bool SubprogramVisitor::Pre(const parser::EntryStmt &) { return BeginAttrs(); } @@ -3079,9 +3110,13 @@ details.add_dummyArg(dummy); } const parser::Name *funcResultName; - if (funcInfo_.resultName && funcInfo_.resultName->source != name.source) { + CHECK(!funcInfoStack_.empty()); + FuncInfo &info{funcInfoStack_.back()}; + CHECK(info.inFunctionStmt); + info.inFunctionStmt = false; + if (info.resultName && info.resultName->source != name.source) { // Note that RESULT is ignored if it has the same name as the function. - funcResultName = funcInfo_.resultName; + funcResultName = info.resultName; } else { EraseSymbol(name); // was added by PushSubprogramScope funcResultName = &name; @@ -3093,28 +3128,35 @@ // add function result to function scope EntityDetails funcResultDetails; funcResultDetails.set_funcResult(true); - funcInfo_.resultSymbol = + funcInfoStack_.back().resultSymbol = &MakeSymbol(*funcResultName, std::move(funcResultDetails)); - details.set_result(*funcInfo_.resultSymbol); + details.set_result(*funcInfoStack_.back().resultSymbol); } - // C1560. - if (funcInfo_.resultName && funcInfo_.resultName->source == name.source) { - Say(funcInfo_.resultName->source, + if (info.resultName && info.resultName->source == name.source) { + Say(info.resultName->source, "The function name should not appear in RESULT, references to '%s' " - "inside" - " the function will be considered as references to the result only"_en_US, + "inside the function will be considered as references to the " + "result only"_en_US, name.source); // RESULT name was ignored above, the only side effect from doing so will be // the inability to make recursive calls. The related parser::Name is still // resolved to the created function result symbol because every parser::Name // should be resolved to avoid internal errors. - Resolve(*funcInfo_.resultName, funcInfo_.resultSymbol); + Resolve(*info.resultName, info.resultSymbol); } name.symbol = currScope().symbol(); // must not be function result symbol // Clear the RESULT() name now in case an ENTRY statement in the implicit-part // has a RESULT() suffix. - funcInfo_.resultName = nullptr; + info.resultName = nullptr; + // If there was a type on the function statement, and it is an intrinsic + // type, process that type now so that inquiries in specification expressions + // will work. Derived types are deferred to the end of the specification part + // so that they can resolve to a locally declared type. + if (info.parsedType && + std::holds_alternative(info.parsedType->u)) { + FinishFunctionResult(); + } } SubprogramDetails &SubprogramVisitor::PostSubprogramStmt( @@ -3138,15 +3180,15 @@ return; } const auto &name{std::get(stmt.t)}; - const auto *parentDetails{subprogram->detailsIf()}; - bool inFunction{parentDetails && parentDetails->isFunction()}; - const parser::Name *resultName{funcInfo_.resultName}; + const parser::Name *resultName{nullptr}; + if (const auto &maybeSuffix{ + std::get>(stmt.t)}) { + resultName = common::GetPtrFromOptional(maybeSuffix->resultName); + } + bool inFunction{IsFunction(currScope())}; if (resultName) { // RESULT(result) is present - funcInfo_.resultName = nullptr; if (!inFunction) { - Say2(resultName->source, - "RESULT(%s) may appear only in a function"_err_en_US, - subprogram->name(), "Containing subprogram"_en_US); + // error was already emitted for the suffix } else if (resultName->source == subprogram->name()) { // C1574 Say2(resultName->source, "RESULT(%s) may not have the same name as the function"_err_en_US, @@ -3292,12 +3334,13 @@ if (details.isFunction()) { currScope().erase(symbol->name()); newDetails.set_result(*currScope().CopySymbol(details.result())); + funcInfoStack_.emplace_back(); // just to be popped later } } return true; } -// A subprogram declared with SUBROUTINE or FUNCTION +// A subprogram or interface declared with SUBROUTINE or FUNCTION bool SubprogramVisitor::BeginSubprogram( const parser::Name &name, Symbol::Flag subpFlag, bool hasModulePrefix) { if (hasModulePrefix && currScope().IsGlobal()) { // C1547 @@ -3314,10 +3357,18 @@ return false; } PushSubprogramScope(name, subpFlag); + if (IsFunction(currScope())) { + funcInfoStack_.emplace_back(); + } return true; } -void SubprogramVisitor::EndSubprogram() { PopScope(); } +void SubprogramVisitor::EndSubprogram() { + if (IsFunction(currScope())) { + funcInfoStack_.pop_back(); + } + PopScope(); +} bool SubprogramVisitor::HandlePreviousCalls( const parser::Name &name, Symbol &symbol, Symbol::Flag subpFlag) { @@ -6687,6 +6738,7 @@ void ResolveNamesVisitor::FinishSpecificationPart( const std::list &decls) { badStmtFuncFound_ = false; + FinishFunctionResult(); CheckImports(); bool inModule{currScope().kind() == Scope::Kind::Module}; for (auto &pair : currScope()) { @@ -6979,7 +7031,7 @@ ResolveSpecificationParts(child); } ExecutionPartSkimmer{*this}.Walk(node.exec()); - PopScope(); + EndScopeForNode(node); // Ensure that every object entity has a type. for (auto &pair : *node.scope()) { ApplyImplicitRules(*pair.second); @@ -7029,6 +7081,10 @@ } } +void ResolveNamesVisitor::EndScopeForNode(const ProgramTree &node) { + EndSubprogram(); +} + // Some analyses and checks, such as the processing of initializers of // pointers, are deferred until all of the pertinent specification parts // have been visited. This deferred processing enables the use of forward Index: flang/test/Semantics/resolve108.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/resolve108.f90 @@ -0,0 +1,69 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Tests attempts at forward references to local names in a FUNCTION prefix + +! This case is not an error, but will elicit bogus errors if the +! result type of the function is badly resolved. +module m1 + type t1 + sequence + integer not_m + end type + contains + type(t1) function foo(n) + integer, intent(in) :: n + type t1 + sequence + integer m + end type + foo%m = n + end function +end module + +subroutine s1 + use :: m1, only: foo + type t1 + sequence + integer m + end type + type(t1) x + x = foo(234) + print *, x +end subroutine + +module m2 + integer, parameter :: k = kind(1.e0) + contains + real(kind=k) function foo(n) + integer, parameter :: k = kind(1.d0) + integer, intent(in) :: n + foo = n + end function +end module + +subroutine s2 + use :: m2, only: foo + !If we got the type of foo right, this declaration will fail + !due to an attempted division by zero. + !ERROR: Must be a constant value + integer, parameter :: test = 1 / (kind(foo(1)) - kind(1.e0)) +end subroutine + +module m3 + integer, parameter :: k = kind(1.e0) + contains + real(kind=kind(x)) function foo(x) + !ERROR: The type of 'x' has already been implicitly declared + real(kind=kind(1.0d0)) x + foo = n + end function +end module + +module m4 + contains + !ERROR: Must be a constant value + real(n) function foo(x) + integer, parameter :: n = kind(foo) + real(n), intent(in) :: x + foo = x + end function +end module