[flang] Create names to allow access to inaccessible specifics

When a reference to a generic interface occurs in a specification
expression that must be emitted to a module file, we have a problem
when the generic resolves to a function whose name is inaccessible
due to being PRIVATE or due to a conflict with another use of the
same name in the scope.  In these cases, construct a new name for
the specific procedure and emit a renaming USE to the module file.
Also, relax enforcement of PRIVATE when analyzing module files.

Differential Revision: https://reviews.llvm.org/D94815

9 files changed, 123 insertions, 21 deletions

diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h
index e095928..7b252ba 100644
--- a/flang/include/flang/Semantics/expression.h
+++ b/flang/include/flang/Semantics/expression.h
@@ -363,6 +363,8 @@ private:
   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);
diff --git a/flang/include/flang/Semantics/semantics.h b/flang/include/flang/Semantics/semantics.h
index de3d9ae..4f4bfc7 100644
--- 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 <iosfwd>
+#include <set>
 #include <string>
 #include <vector>
 
@@ -170,6 +171,7 @@ public:
   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 @@ private:
   };
   std::map<SymbolRef, const IndexVarInfo> activeIndexVars_;
   std::set<SymbolRef> errorSymbols_;
-  std::vector<std::string> tempNames_;
+  std::set<std::string> tempNames_;
 };
 
 class Semantics {
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index 1a0e284..e809b30 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -38,6 +38,7 @@ const Scope &GetProgramUnitContaining(const Scope &);
 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
index 45bfde0..4bedbe8 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -485,16 +485,17 @@ public:
 
   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";
       }
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index a4961af..56a26d7 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -165,7 +165,7 @@ private:
   }
   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 @@ const Symbol *ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol,
               *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 @@ const Symbol *ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol,
     }
   }
   if (elemental) {
-    return elemental;
+    return &AccessSpecific(symbol, *elemental);
   }
   // Check parent derived type
   if (const auto *parentScope{symbol.owner().GetDerivedTypeParent()}) {
@@ -1970,6 +1971,33 @@ const Symbol *ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol,
   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,
@@ -2956,7 +2984,7 @@ bool ArgumentAnalyzer::CheckConformance() const {
 
 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 @@ void ArgumentAnalyzer::SayNoMatch(const std::string &opr, bool isAssignment) {
 }
 
 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
@@ -3282,9 +3312,9 @@ std::string ArgumentAnalyzer::TypeAsFortran(std::size_t i) {
   }
 }
 
-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
index cef4f00..5d9ee35 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -2358,7 +2358,11 @@ ModuleVisitor::SymbolRename ModuleVisitor::AddUse(
         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
index fb560aa..f299897 100644
--- a/flang/lib/Semantics/semantics.cpp
+++ b/flang/lib/Semantics/semantics.cpp
@@ -325,16 +325,20 @@ SymbolVector SemanticsContext::GetIndexVars(IndexVarKind kind) {
   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
index 81dde88..1bc0086 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -52,6 +52,11 @@ const Scope *FindModuleContaining(const Scope &start) {
       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 @@ std::optional<parser::MessageFormattedText> CheckAccessibleComponent(
     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
index 0000000..f9d7570
--- /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