[flang] Create names to allow access to inaccessible specifics

[klausler]

Summary

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.

[tskeith]

flang/include/flang/Semantics/tools.h

41

This is only used in a boolean context, so it could be something like bool IsInModFile(const Scope &).

flang/include/flang/Semantics/expression.h

private:
   std::optional<characteristics::Procedure> CheckCall(
       parser::CharBlock, const ProcedureDesignator &, ActualArguments &);
   using AdjustActuals =
       std::optional<std::function<bool(const Symbol &, ActualArguments &)>>;
   bool ResolveForward(const Symbol &);
   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);
   std::optional<CalleeAndArguments> GetCalleeAndArguments(
       const parser::ProcedureDesignator &, ActualArguments &&,
       bool isSubroutine, bool mightBeStructureConstructor = false);
 
   void CheckForBadRecursion(parser::CharBlock, const semantics::Symbol &);

flang/include/flang/Semantics/semantics.h

 
 #include "scope.h"
 #include "symbol.h"
 #include "flang/Common/Fortran-features.h"
 #include "flang/Evaluate/common.h"
 #include "flang/Evaluate/intrinsics.h"
 #include "flang/Parser/message.h"
 #include <iosfwd>
+#include <set>
 #include <string>
 #include <vector>
 
 namespace llvm {
 class raw_ostream;
 }
 
 namespace Fortran::common {
public:
   // If so, emit a message.
   void WarnIndexVarRedefine(const parser::CharBlock &, const Symbol &);
   void CheckIndexVarRedefine(const parser::CharBlock &, const Symbol &);
   void CheckIndexVarRedefine(const parser::Variable &);
   void CheckIndexVarRedefine(const parser::Name &);
   void ActivateIndexVar(const parser::Name &, IndexVarKind);
   void DeactivateIndexVar(const parser::Name &);
   SymbolVector GetIndexVars(IndexVarKind);
+  SourceName SaveTempName(std::string &&);
   SourceName GetTempName(const Scope &);
 
 private:
   void CheckIndexVarRedefine(
       const parser::CharBlock &, const Symbol &, parser::MessageFixedText &&);
   void CheckError(const Symbol &);
 
   const common::IntrinsicTypeDefaultKinds &defaultKinds_;
private:
   evaluate::FoldingContext foldingContext_;
   ConstructStack constructStack_;
   struct IndexVarInfo {
     parser::CharBlock location;
     IndexVarKind kind;
   };
   std::map<SymbolRef, const IndexVarInfo> activeIndexVars_;
   std::set<SymbolRef> errorSymbols_;
-  std::vector<std::string> tempNames_;
+  std::set<std::string> tempNames_;
 };
 
 class Semantics {
 public:
   explicit Semantics(SemanticsContext &context, parser::Program &program,
       parser::CharBlock charBlock, bool debugModuleWriter = false)
       : context_{context}, program_{program} {
     context.set_debugModuleWriter(debugModuleWriter);

flang/include/flang/Semantics/tools.h

 // Note: Here ProgramUnit includes internal subprograms while TopLevelUnit
 // does not. "program-unit" in the Fortran standard matches TopLevelUnit.
 const Scope &GetTopLevelUnitContaining(const Scope &);
 const Scope &GetTopLevelUnitContaining(const Symbol &);
 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 &);
 const Symbol *FindPointerComponent(const DerivedTypeSpec &);
 const Symbol *FindPointerComponent(const DeclTypeSpec &);
 const Symbol *FindPointerComponent(const Symbol &);
 const Symbol *FindInterface(const Symbol &);
 const Symbol *FindSubprogram(const Symbol &);

flang/lib/Evaluate/check-expression.cpp

if (scope_.IsDerivedType() && !IsConstantExpr(inq) &&
       return "non-constant reference to a type parameter inquiry not "
              "allowed for derived type components or type parameter values";
     }
     return std::nullopt;
   }
 
   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";
       }
       // TODO: other checks for standard module procedures
     } else {
       const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())};
       if (scope_.IsDerivedType()) { // C750, C754
         if ((context_.intrinsics().IsIntrinsic(intrin.name) &&

flang/lib/Semantics/expression.cpp

void AddAssignmentConversion(
       const DynamicType &lhsType, const DynamicType &rhsType);
   bool OkLogicalIntegerAssignment(TypeCategory lhs, TypeCategory rhs);
   int GetRank(std::size_t) const;
   bool IsBOZLiteral(std::size_t i) const {
     return std::holds_alternative<BOZLiteralConstant>(GetExpr(i).u);
   }
   void SayNoMatch(const std::string &, bool isAssignment = false);
   std::string TypeAsFortran(std::size_t);
-  bool AnyUntypedOperand();
+  bool AnyUntypedOrMissingOperand();
 
   ExpressionAnalyzer &context_;
   ActualArguments actuals_;
   parser::CharBlock source_;
   bool fatalErrors_{false};
   const bool isProcedureCall_; // false for user-defined op or assignment
   const Symbol *sawDefinedOp_{nullptr};
 };
if (std::optional<characteristics::Procedure> procedure{
         if (!adjustActuals.value()(specific, localActuals)) {
           continue;
         }
       }
       if (semantics::CheckInterfaceForGeneric(
               *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()}) {
     if (const Symbol * extended{parentScope->FindComponent(symbol.name())}) {
       if (extended->GetUltimate().has<semantics::GenericDetails>()) {
         if (const Symbol *
             result{ResolveGeneric(*extended, actuals, adjustActuals, false)}) {
           return result;
         }
       }
     }
   }
   if (mightBeStructureConstructor && details.derivedType()) {
     return details.derivedType();
   }
   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,
         symbol.name());
   } else {
     Say("No specific procedure of generic '%s' matches the actual arguments"_err_en_US,
         symbol.name());
   }
if (lhs && rhs) {
       }
     }
   }
   return true; // no proven problem
 }
 
 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;
   }
   {
     auto restorer{context_.GetContextualMessages().DiscardMessages()};
     std::string oprNameString{
         isUserOp ? std::string{opr} : "operator("s + opr + ')'};
if (rank0 > 0 && rank1 > 0 && rank0 != rank1) {
       context_.Say("No intrinsic or user-defined %s matches "
                    "operand types %s and %s"_err_en_US,
           opr, type0, type1);
     }
   }
 }
 
 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
         ? "CHARACTER(KIND="s + std::to_string(type->kind()) + ')'
         : ToUpperCase(type->AsFortran());
   } else {
     return "untyped";
   }
 }
 
-bool ArgumentAnalyzer::AnyUntypedOperand() {
+bool ArgumentAnalyzer::AnyUntypedOrMissingOperand() {
   for (const auto &actual : actuals_) {
-    if (!actual.value().GetType()) {
+    if (!actual || !actual->GetType()) {
       return true;
     }
   }
   return false;
 }
 
 } // namespace Fortran::evaluate
 

flang/lib/Semantics/resolve-names.cpp

ModuleVisitor::SymbolRename ModuleVisitor::AddUse(
   if (!useModuleScope_) {
     return {}; // error occurred finding module
   }
   if (!useSymbol) {
     Say(useName, "'%s' not found in module '%s'"_err_en_US, MakeOpName(useName),
         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 {};
   }
   auto &localSymbol{MakeSymbol(localName)};
   DoAddUse(useName, localName, localSymbol, *useSymbol);
   return {&localSymbol, useSymbol};
 }

flang/lib/Semantics/semantics.cpp

SymbolVector SemanticsContext::GetIndexVars(IndexVarKind kind) {
   for (const auto &[symbol, info] : activeIndexVars_) {
     if (info.kind == kind) {
       result.push_back(symbol);
     }
   }
   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_) {
+    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() {
   return ValidateLabels(context_, program_) &&
       parser::CanonicalizeDo(program_) && // force line break
       CanonicalizeAcc(context_.messages(), program_) &&
       CanonicalizeOmp(context_.messages(), program_) &&
       PerformStatementSemantics(context_, program_) &&

flang/lib/Semantics/tools.cpp

const Scope &GetTopLevelUnitContaining(const Symbol &symbol) {
   return GetTopLevelUnitContaining(symbol.owner());
 }
 
 const Scope *FindModuleContaining(const Scope &start) {
   return FindScopeContaining(
       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) {
     switch (scope.kind()) {
     case Scope::Kind::Module:
     case Scope::Kind::MainProgram:
     case Scope::Kind::Subprogram:
     case Scope::Kind::BlockData:

 bool IsPolymorphicAllocatable(const Symbol &symbol) {
   return IsAllocatable(symbol) && IsPolymorphic(symbol);
 }
 
 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,
             symbol.name(), moduleScope->GetName().value()};
       }
     }
   }
   return std::nullopt;

flang/test/Semantics/modfile39.f90

+! 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