diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h --- a/flang/include/flang/Semantics/expression.h +++ b/flang/include/flang/Semantics/expression.h @@ -363,6 +363,8 @@ const Symbol *ResolveGeneric(const Symbol &, const ActualArguments &, const AdjustActuals &, bool mightBeStructureConstructor = false); void EmitGenericResolutionError(const Symbol &); + const Symbol &AccessSpecific( + const Symbol &originalGeneric, const Symbol &specific); std::optional GetCalleeAndArguments(const parser::Name &, ActualArguments &&, bool isSubroutine = false, bool mightBeStructureConstructor = false); diff --git a/flang/include/flang/Semantics/semantics.h b/flang/include/flang/Semantics/semantics.h --- a/flang/include/flang/Semantics/semantics.h +++ b/flang/include/flang/Semantics/semantics.h @@ -16,6 +16,7 @@ #include "flang/Evaluate/intrinsics.h" #include "flang/Parser/message.h" #include +#include #include #include @@ -170,6 +171,7 @@ void ActivateIndexVar(const parser::Name &, IndexVarKind); void DeactivateIndexVar(const parser::Name &); SymbolVector GetIndexVars(IndexVarKind); + SourceName SaveTempName(std::string &&); SourceName GetTempName(const Scope &); private: @@ -198,7 +200,7 @@ }; std::map activeIndexVars_; std::set errorSymbols_; - std::vector tempNames_; + std::set tempNames_; }; class Semantics { diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -38,6 +38,7 @@ const Scope &GetProgramUnitContaining(const Symbol &); const Scope *FindModuleContaining(const Scope &); +const Scope *FindModuleFileContaining(const Scope &); const Scope *FindPureProcedureContaining(const Scope &); const Scope *FindPureProcedureContaining(const Symbol &); const Symbol *FindPointerComponent(const Scope &); diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp --- a/flang/lib/Evaluate/check-expression.cpp +++ b/flang/lib/Evaluate/check-expression.cpp @@ -485,16 +485,17 @@ template Result operator()(const FunctionRef &x) const { if (const auto *symbol{x.proc().GetSymbol()}) { - if (!semantics::IsPureProcedure(*symbol)) { - return "reference to impure function '"s + symbol->name().ToString() + + const Symbol &ultimate{symbol->GetUltimate()}; + if (!semantics::IsPureProcedure(ultimate)) { + return "reference to impure function '"s + ultimate.name().ToString() + "'"; } - if (semantics::IsStmtFunction(*symbol)) { + if (semantics::IsStmtFunction(ultimate)) { return "reference to statement function '"s + - symbol->name().ToString() + "'"; + ultimate.name().ToString() + "'"; } if (scope_.IsDerivedType()) { // C750, C754 - return "reference to function '"s + symbol->name().ToString() + + return "reference to function '"s + ultimate.name().ToString() + "' not allowed for derived type components or type parameter" " values"; } diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -165,7 +165,7 @@ } void SayNoMatch(const std::string &, bool isAssignment = false); std::string TypeAsFortran(std::size_t); - bool AnyUntypedOperand(); + bool AnyUntypedOrMissingOperand(); ExpressionAnalyzer &context_; ActualArguments actuals_; @@ -1943,7 +1943,8 @@ *procedure, localActuals, GetFoldingContext())) { if (CheckCompatibleArguments(*procedure, localActuals)) { if (!procedure->IsElemental()) { - return &specific; // takes priority over elemental match + // takes priority over elemental match + return &AccessSpecific(symbol, specific); } elemental = &specific; } @@ -1951,7 +1952,7 @@ } } if (elemental) { - return elemental; + return &AccessSpecific(symbol, *elemental); } // Check parent derived type if (const auto *parentScope{symbol.owner().GetDerivedTypeParent()}) { @@ -1970,6 +1971,33 @@ return nullptr; } +const Symbol &ExpressionAnalyzer::AccessSpecific( + const Symbol &originalGeneric, const Symbol &specific) { + if (const auto *hosted{ + originalGeneric.detailsIf()}) { + return AccessSpecific(hosted->symbol(), specific); + } else if (const auto *used{ + originalGeneric.detailsIf()}) { + const auto &scope{originalGeneric.owner()}; + auto iter{scope.find(specific.name())}; + if (iter != scope.end() && iter->second->has() && + &iter->second->get().symbol() == &specific) { + return specific; + } else { + // Create a renaming USE of the specific procedure. + auto rename{context_.SaveTempName( + used->symbol().owner().GetName().value().ToString() + "$" + + specific.name().ToString())}; + return *const_cast(scope) + .try_emplace(rename, specific.attrs(), + semantics::UseDetails{rename, specific}) + .first->second; + } + } else { + return specific; + } +} + void ExpressionAnalyzer::EmitGenericResolutionError(const Symbol &symbol) { if (semantics::IsGenericDefinedOp(symbol)) { Say("No specific procedure of generic operator '%s' matches the actual arguments"_err_en_US, @@ -2956,7 +2984,7 @@ MaybeExpr ArgumentAnalyzer::TryDefinedOp( const char *opr, parser::MessageFixedText &&error, bool isUserOp) { - if (AnyUntypedOperand()) { + if (AnyUntypedOrMissingOperand()) { context_.Say( std::move(error), ToUpperCase(opr), TypeAsFortran(0), TypeAsFortran(1)); return std::nullopt; @@ -3271,7 +3299,9 @@ } std::string ArgumentAnalyzer::TypeAsFortran(std::size_t i) { - if (std::optional type{GetType(i)}) { + if (i >= actuals_.size() || !actuals_[i]) { + return "missing argument"; + } else if (std::optional type{GetType(i)}) { return type->category() == TypeCategory::Derived ? "TYPE("s + type->AsFortran() + ')' : type->category() == TypeCategory::Character @@ -3282,9 +3312,9 @@ } } -bool ArgumentAnalyzer::AnyUntypedOperand() { +bool ArgumentAnalyzer::AnyUntypedOrMissingOperand() { for (const auto &actual : actuals_) { - if (!actual.value().GetType()) { + if (!actual || !actual->GetType()) { return true; } } diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -2358,7 +2358,11 @@ useModuleScope_->GetName().value()); return {}; } - if (useSymbol->attrs().test(Attr::PRIVATE)) { + if (useSymbol->attrs().test(Attr::PRIVATE) && + !FindModuleFileContaining(currScope())) { + // Privacy is not enforced in module files so that generic interfaces + // can be resolved to private specific procedures in specification + // expressions. Say(useName, "'%s' is PRIVATE in '%s'"_err_en_US, MakeOpName(useName), useModuleScope_->GetName().value()); return {}; diff --git a/flang/lib/Semantics/semantics.cpp b/flang/lib/Semantics/semantics.cpp --- a/flang/lib/Semantics/semantics.cpp +++ b/flang/lib/Semantics/semantics.cpp @@ -325,16 +325,20 @@ return result; } +SourceName SemanticsContext::SaveTempName(std::string &&name) { + return {*tempNames_.emplace(std::move(name)).first}; +} + SourceName SemanticsContext::GetTempName(const Scope &scope) { for (const auto &str : tempNames_) { - SourceName name{str}; - if (scope.find(name) == scope.end()) { - return name; + if (str.size() > 5 && str.substr(0, 5) == ".F18.") { + SourceName name{str}; + if (scope.find(name) == scope.end()) { + return name; + } } } - tempNames_.emplace_back(".F18."); - tempNames_.back() += std::to_string(tempNames_.size()); - return {tempNames_.back()}; + return SaveTempName(".F18."s + std::to_string(tempNames_.size())); } bool Semantics::Perform() { diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -52,6 +52,11 @@ start, [](const Scope &scope) { return scope.IsModule(); }); } +const Scope *FindModuleFileContaining(const Scope &start) { + return FindScopeContaining( + start, [](const Scope &scope) { return scope.IsModuleFile(); }); +} + const Scope &GetProgramUnitContaining(const Scope &start) { CHECK(!start.IsGlobal()); return DEREF(FindScopeContaining(start, [](const Scope &scope) { @@ -960,7 +965,12 @@ const Scope &scope, const Symbol &symbol) { CHECK(symbol.owner().IsDerivedType()); // symbol must be a component if (symbol.attrs().test(Attr::PRIVATE)) { - if (const Scope * moduleScope{FindModuleContaining(symbol.owner())}) { + if (FindModuleFileContaining(scope)) { + // Don't enforce component accessibility checks in module files; + // there may be forward-substituted named constants of derived type + // whose structure constructors reference private components. + } else if (const Scope * + moduleScope{FindModuleContaining(symbol.owner())}) { if (!moduleScope->Contains(scope)) { return parser::MessageFormattedText{ "PRIVATE component '%s' is only accessible within module '%s'"_err_en_US, diff --git a/flang/test/Semantics/modfile39.f90 b/flang/test/Semantics/modfile39.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/modfile39.f90 @@ -0,0 +1,48 @@ +! RUN: %S/test_modfile.sh %s %t %f18 +! Resolution of specification expression references to generic interfaces +! that resolve to private specific functions. + +module m1 + interface gen + module procedure priv + end interface + private :: priv + contains + pure integer function priv(n) + integer, intent(in) :: n + priv = n + end function +end module +!Expect: m1.mod +!module m1 +!interface gen +!procedure::priv +!end interface +!private::priv +!contains +!pure function priv(n) +!integer(4),intent(in)::n +!integer(4)::priv +!end +!end + +module m2 + use m1 + contains + subroutine s(a) + real :: a(gen(1)) + end subroutine +end module +!Expect: m2.mod +!module m2 +!use m1,only:gen +!use m1,only:m1$priv=>priv +!private::m1$priv +!contains +!subroutine s(a) +!real(4)::a(1_8:int(m1$priv(1_4),kind=8)) +!end +!end + +use m2 +end