[flang] Safer hermetic module file reading (#121002)

When a hermetic module file is read, use a new scope to hold its
dependent modules so that they don't conflict with any modules in the
global scope.

Author: klausler

flang/docs/ModFiles.md

@@ -164,3 +164,13 @@ a diagnostic but we still wouldn't have line numbers.
 To provide line numbers and character positions or source lines as the user
 wrote them we would have to save some amount of provenance information in the
 module file as well.
+
+## Hermetic modules files
+
+Top-level module files for libraries can be build with `-fhermetic-module-files`.
+This option causes these module files to contain copies of all of the non-intrinsic
+modules on which they depend, so that non-top-level local modules and the
+modules of dependent libraries need not also be packaged with the library.
+When the compiler reads a hermetic module file, the copies of the dependent
+modules are read into their own scope, and will not conflict with other modules
+of the same name that client code might `USE`.

flang/include/flang/Common/Fortran-features.h

@@ -73,7 +73,8 @@ ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
     PreviousScalarUse, RedeclaredInaccessibleComponent, ImplicitShared,
     IndexVarRedefinition, IncompatibleImplicitInterfaces, BadTypeForTarget,
     VectorSubscriptFinalization, UndefinedFunctionResult, UselessIomsg,
-    MismatchingDummyProcedure, SubscriptedEmptyArray, UnsignedLiteralTruncation)
+    MismatchingDummyProcedure, SubscriptedEmptyArray, UnsignedLiteralTruncation,
+    CompatibleDeclarationsFromDistinctModules)
 
 using LanguageFeatures = EnumSet<LanguageFeature, LanguageFeature_enumSize>;
 using UsageWarnings = EnumSet<UsageWarning, UsageWarning_enumSize>;

flang/include/flang/Evaluate/type.h

@@ -510,6 +510,8 @@ bool AreSameDerivedType(
     const semantics::DerivedTypeSpec &, const semantics::DerivedTypeSpec &);
 bool AreSameDerivedTypeIgnoringTypeParameters(
     const semantics::DerivedTypeSpec &, const semantics::DerivedTypeSpec &);
+bool AreSameDerivedTypeIgnoringSequence(
+    const semantics::DerivedTypeSpec &, const semantics::DerivedTypeSpec &);
 
 // For generating "[extern] template class", &c. boilerplate
 #define EXPAND_FOR_EACH_INTEGER_KIND(M, P, S) \

flang/include/flang/Semantics/semantics.h

@@ -110,6 +110,12 @@ class SemanticsContext {
   }
   Scope &globalScope() { return globalScope_; }
   Scope &intrinsicModulesScope() { return intrinsicModulesScope_; }
+  Scope *currentHermeticModuleFileScope() {
+    return currentHermeticModuleFileScope_;
+  }
+  void set_currentHermeticModuleFileScope(Scope *scope) {
+    currentHermeticModuleFileScope_ = scope;
+  }
   parser::Messages &messages() { return messages_; }
   evaluate::FoldingContext &foldingContext() { return foldingContext_; }
   parser::AllCookedSources &allCookedSources() { return allCookedSources_; }
@@ -313,6 +319,7 @@ class SemanticsContext {
   evaluate::TargetCharacteristics targetCharacteristics_;
   Scope globalScope_;
   Scope &intrinsicModulesScope_;
+  Scope *currentHermeticModuleFileScope_{nullptr};
   ScopeIndex scopeIndex_;
   parser::Messages messages_;
   evaluate::FoldingContext foldingContext_;

flang/include/flang/Semantics/symbol.h

@@ -605,12 +605,12 @@ class UseDetails {
 class UseErrorDetails {
 public:
   UseErrorDetails(const UseDetails &);
-  UseErrorDetails &add_occurrence(const SourceName &, const Scope &);
-  using listType = std::list<std::pair<SourceName, const Scope *>>;
-  const listType occurrences() const { return occurrences_; };
+  UseErrorDetails &add_occurrence(const SourceName &, const Symbol &);
+  using ListType = std::list<std::pair<SourceName, const Symbol *>>;
+  const ListType occurrences() const { return occurrences_; };
 
 private:
-  listType occurrences_;
+  ListType occurrences_;
 };
 
 // A symbol host-associated from an enclosing scope.

flang/lib/Evaluate/type.cpp

@@ -293,11 +293,13 @@ using SetOfDerivedTypePairs =
 
 static bool AreSameDerivedType(const semantics::DerivedTypeSpec &,
     const semantics::DerivedTypeSpec &, bool ignoreTypeParameterValues,
-    bool ignoreLenParameters, SetOfDerivedTypePairs &inProgress);
+    bool ignoreLenParameters, bool ignoreSequence,
+    SetOfDerivedTypePairs &inProgress);
 
 // F2023 7.5.3.2
 static bool AreSameComponent(const semantics::Symbol &x,
-    const semantics::Symbol &y, SetOfDerivedTypePairs &inProgress) {
+    const semantics::Symbol &y, bool ignoreSequence,
+    SetOfDerivedTypePairs &inProgress) {
   if (x.attrs() != y.attrs()) {
     return false;
   }
@@ -325,7 +327,8 @@ static bool AreSameComponent(const semantics::Symbol &x,
               !yType->IsUnlimitedPolymorphic() ||
           (!xType->IsUnlimitedPolymorphic() &&
               !AreSameDerivedType(xType->GetDerivedTypeSpec(),
-                  yType->GetDerivedTypeSpec(), false, false, inProgress))) {
+                  yType->GetDerivedTypeSpec(), false, false, ignoreSequence,
+                  inProgress))) {
         return false;
       }
     } else if (!xType->IsTkLenCompatibleWith(*yType)) {
@@ -449,7 +452,8 @@ static bool AreTypeParamCompatible(const semantics::DerivedTypeSpec &x,
 // F2023 7.5.3.2
 static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
     const semantics::DerivedTypeSpec &y, bool ignoreTypeParameterValues,
-    bool ignoreLenParameters, SetOfDerivedTypePairs &inProgress) {
+    bool ignoreLenParameters, bool ignoreSequence,
+    SetOfDerivedTypePairs &inProgress) {
   if (&x == &y) {
     return true;
   }
@@ -472,7 +476,12 @@ static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
   inProgress.insert(thisQuery);
   const auto &xDetails{xSymbol.get<semantics::DerivedTypeDetails>()};
   const auto &yDetails{ySymbol.get<semantics::DerivedTypeDetails>()};
-  if (!(xDetails.sequence() && yDetails.sequence()) &&
+  if (xDetails.sequence() != yDetails.sequence() ||
+      xSymbol.attrs().test(semantics::Attr::BIND_C) !=
+          ySymbol.attrs().test(semantics::Attr::BIND_C)) {
+    return false;
+  }
+  if (!ignoreSequence && !(xDetails.sequence() && yDetails.sequence()) &&
       !(xSymbol.attrs().test(semantics::Attr::BIND_C) &&
           ySymbol.attrs().test(semantics::Attr::BIND_C))) {
     // PGI does not enforce this requirement; all other Fortran
@@ -493,7 +502,8 @@ static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
     const auto yLookup{ySymbol.scope()->find(*yComponentName)};
     if (xLookup == xSymbol.scope()->end() ||
         yLookup == ySymbol.scope()->end() ||
-        !AreSameComponent(*xLookup->second, *yLookup->second, inProgress)) {
+        !AreSameComponent(
+            *xLookup->second, *yLookup->second, ignoreSequence, inProgress)) {
       return false;
     }
   }
@@ -503,13 +513,19 @@ static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
 bool AreSameDerivedType(
     const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
   SetOfDerivedTypePairs inProgress;
-  return AreSameDerivedType(x, y, false, false, inProgress);
+  return AreSameDerivedType(x, y, false, false, false, inProgress);
 }
 
 bool AreSameDerivedTypeIgnoringTypeParameters(
     const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
   SetOfDerivedTypePairs inProgress;
-  return AreSameDerivedType(x, y, true, true, inProgress);
+  return AreSameDerivedType(x, y, true, true, false, inProgress);
+}
+
+bool AreSameDerivedTypeIgnoringSequence(
+    const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
+  SetOfDerivedTypePairs inProgress;
+  return AreSameDerivedType(x, y, false, false, true, inProgress);
 }
 
 static bool AreSameDerivedType(
@@ -536,7 +552,7 @@ static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
   } else {
     SetOfDerivedTypePairs inProgress;
     if (AreSameDerivedType(*x, *y, ignoreTypeParameterValues,
-            ignoreLenTypeParameters, inProgress)) {
+            ignoreLenTypeParameters, false, inProgress)) {
       return true;
     } else {
       return isPolymorphic &&

flang/lib/Semantics/mod-file.cpp

@@ -1366,6 +1366,12 @@ Scope *ModFileReader::Read(SourceName name, std::optional<bool> isIntrinsic,
       name.ToString(), isIntrinsic.value_or(false))};
   if (!isIntrinsic.value_or(false) && !ancestor) {
     // Already present in the symbol table as a usable non-intrinsic module?
+    if (Scope * hermeticScope{context_.currentHermeticModuleFileScope()}) {
+      auto it{hermeticScope->find(name)};
+      if (it != hermeticScope->end()) {
+        return it->second->scope();
+      }
+    }
     auto it{context_.globalScope().find(name)};
     if (it != context_.globalScope().end()) {
       Scope *scope{it->second->scope()};
@@ -1544,9 +1550,22 @@ Scope *ModFileReader::Read(SourceName name, std::optional<bool> isIntrinsic,
   // Process declarations from the module file
   auto wasModuleFileName{context_.foldingContext().moduleFileName()};
   context_.foldingContext().set_moduleFileName(name);
+  // Are there multiple modules in the module file due to it having been
+  // created under -fhermetic-module-files?  If so, process them first in
+  // their own nested scope that will be visible only to USE statements
+  // within the module file.
+  if (parseTree.v.size() > 1) {
+    parser::Program hermeticModules{std::move(parseTree.v)};
+    parseTree.v.emplace_back(std::move(hermeticModules.v.front()));
+    hermeticModules.v.pop_front();
+    Scope &hermeticScope{topScope.MakeScope(Scope::Kind::Global)};
+    context_.set_currentHermeticModuleFileScope(&hermeticScope);
+    ResolveNames(context_, hermeticModules, hermeticScope);
+  }
   GetModuleDependences(context_.moduleDependences(), sourceFile->content());
   ResolveNames(context_, parseTree, topScope);
   context_.foldingContext().set_moduleFileName(wasModuleFileName);
+  context_.set_currentHermeticModuleFileScope(nullptr);
   if (!moduleSymbol) {
     // Submodule symbols' storage are owned by their parents' scopes,
     // but their names are not in their parents' dictionaries -- we