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<CalleeAndArguments> GetCalleeAndArguments(const parser::Name &,
ActualArguments &&, bool isSubroutine = false,
bool mightBeStructureConstructor = false);
#include "flang/Evaluate/intrinsics.h"
#include "flang/Parser/message.h"
#include <iosfwd>
+#include <set>
#include <string>
#include <vector>
void ActivateIndexVar(const parser::Name &, IndexVarKind);
void DeactivateIndexVar(const parser::Name &);
SymbolVector GetIndexVars(IndexVarKind);
+ SourceName SaveTempName(std::string &&);
SourceName GetTempName(const Scope &);
private:
};
std::map<SymbolRef, const IndexVarInfo> activeIndexVars_;
std::set<SymbolRef> errorSymbols_;
- std::vector<std::string> tempNames_;
+ std::set<std::string> tempNames_;
};
class Semantics {
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 &);
template <typename T> Result operator()(const FunctionRef<T> &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";
}
}
void SayNoMatch(const std::string &, bool isAssignment = false);
std::string TypeAsFortran(std::size_t);
- bool AnyUntypedOperand();
+ bool AnyUntypedOrMissingOperand();
ExpressionAnalyzer &context_;
ActualArguments actuals_;
*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;
}
}
}
if (elemental) {
- return elemental;
+ return &AccessSpecific(symbol, *elemental);
}
// Check parent derived type
if (const auto *parentScope{symbol.owner().GetDerivedTypeParent()}) {
return nullptr;
}
+const Symbol &ExpressionAnalyzer::AccessSpecific(
+ const Symbol &originalGeneric, const Symbol &specific) {
+ if (const auto *hosted{
+ originalGeneric.detailsIf<semantics::HostAssocDetails>()}) {
+ return AccessSpecific(hosted->symbol(), specific);
+ } else if (const auto *used{
+ originalGeneric.detailsIf<semantics::UseDetails>()}) {
+ const auto &scope{originalGeneric.owner()};
+ auto iter{scope.find(specific.name())};
+ if (iter != scope.end() && iter->second->has<semantics::UseDetails>() &&
+ &iter->second->get<semantics::UseDetails>().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<semantics::Scope &>(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,
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;
}
std::string ArgumentAnalyzer::TypeAsFortran(std::size_t i) {
- if (std::optional<DynamicType> type{GetType(i)}) {
+ if (i >= actuals_.size() || !actuals_[i]) {
+ return "missing argument";
+ } else if (std::optional<DynamicType> type{GetType(i)}) {
return type->category() == TypeCategory::Derived
? "TYPE("s + type->AsFortran() + ')'
: type->category() == TypeCategory::Character
}
}
-bool ArgumentAnalyzer::AnyUntypedOperand() {
+bool ArgumentAnalyzer::AnyUntypedOrMissingOperand() {
for (const auto &actual : actuals_) {
- if (!actual.value().GetType()) {
+ if (!actual || !actual->GetType()) {
return true;
}
}
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 {};
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() {
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) {
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,
--- /dev/null
+! 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