[flang] Check for global name conflicts (19.2)

Global names should be checked for conflicts even when not BIND(C).

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

diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index c320c23..490608b 100644 (file)
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -113,6 +113,7 @@ private:
     return msg;
   }
   bool IsResultOkToDiffer(const FunctionResult &);
+  void CheckGlobalName(const Symbol &);
   void CheckBindC(const Symbol &);
   void CheckBindCFunctionResult(const Symbol &);
   // Check functions for defined I/O procedures
@@ -154,11 +155,11 @@ private:
   // Cache of calls to Procedure::Characterize(Symbol)
   std::map<SymbolRef, std::optional<Procedure>, SymbolAddressCompare>
       characterizeCache_;
-  // Collection of symbols with BIND(C) names
-  std::map<std::string, SymbolRef> bindC_;
   // Collection of module procedure symbols with non-BIND(C)
   // global names, qualified by their module.
   std::map<std::pair<SourceName, const Symbol *>, SymbolRef> moduleProcs_;
+  // Collection of symbols with global names, BIND(C) or otherwise
+  std::map<std::string, SymbolRef> globalNames_;
   // Derived types that have defined input/output procedures
   std::vector<TypeWithDefinedIo> seenDefinedIoTypes_;
 };
@@ -253,6 +254,7 @@ void CheckHelper::Check(const Symbol &symbol) {
     CheckVolatile(symbol, derived);
   }
   CheckBindC(symbol);
+  CheckGlobalName(symbol);
   if (isDone) {
     return; // following checks do not apply
   }
@@ -316,7 +318,9 @@ void CheckHelper::Check(const Symbol &symbol) {
   if (type) { // Section 7.2, paragraph 7
     bool canHaveAssumedParameter{IsNamedConstant(symbol) ||
         (IsAssumedLengthCharacter(symbol) && // C722
-            IsExternal(symbol)) ||
+            (IsExternal(symbol) ||
+                ClassifyProcedure(symbol) ==
+                    ProcedureDefinitionClass::Dummy)) ||
         symbol.test(Symbol::Flag::ParentComp)};
     if (!IsStmtFunctionDummy(symbol)) { // C726
       if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
@@ -351,7 +355,7 @@ void CheckHelper::Check(const Symbol &symbol) {
       }
     }
   }
-  if (IsAssumedLengthCharacter(symbol) && IsExternal(symbol)) { // C723
+  if (IsAssumedLengthCharacter(symbol) && IsFunction(symbol)) { // C723
     if (symbol.attrs().test(Attr::RECURSIVE)) {
       messages_.Say(
           "An assumed-length CHARACTER(*) function cannot be RECURSIVE"_err_en_US);
@@ -360,21 +364,24 @@ void CheckHelper::Check(const Symbol &symbol) {
       messages_.Say(
           "An assumed-length CHARACTER(*) function cannot return an array"_err_en_US);
     }
-    if (IsElementalProcedure(symbol)) {
-      messages_.Say(
-          "An assumed-length CHARACTER(*) function cannot be ELEMENTAL"_err_en_US);
-    } else if (IsPureProcedure(symbol)) {
-      messages_.Say(
-          "An assumed-length CHARACTER(*) function cannot be PURE"_err_en_US);
+    if (!IsStmtFunction(symbol)) {
+      if (IsElementalProcedure(symbol)) {
+        messages_.Say(
+            "An assumed-length CHARACTER(*) function cannot be ELEMENTAL"_err_en_US);
+      } else if (IsPureProcedure(symbol)) {
+        messages_.Say(
+            "An assumed-length CHARACTER(*) function cannot be PURE"_err_en_US);
+      }
     }
     if (const Symbol *result{FindFunctionResult(symbol)}) {
       if (IsPointer(*result)) {
         messages_.Say(
             "An assumed-length CHARACTER(*) function cannot return a POINTER"_err_en_US);
       }
-    } else if (IsPointer(symbol)) {
+    } else if (IsProcedurePointer(symbol) && IsDummy(symbol)) {
       messages_.Say(
-          "A procedure pointer should not have assumed-length CHARACTER(*) result type"_port_en_US);
+          "A dummy procedure pointer should not have assumed-length CHARACTER(*) result type"_port_en_US);
+      // The non-dummy case is a hard error that's caught elsewhere.
     }
   }
   if (symbol.attrs().test(Attr::VALUE)) {
@@ -420,7 +427,10 @@ void CheckHelper::Check(const Symbol &symbol) {
   }
 }
 
-void CheckHelper::CheckCommonBlock(const Symbol &symbol) { CheckBindC(symbol); }
+void CheckHelper::CheckCommonBlock(const Symbol &symbol) {
+  CheckGlobalName(symbol);
+  CheckBindC(symbol);
+}
 
 void CheckHelper::CheckBindCFunctionResult(const Symbol &symbol) { // C1553
   if (!innermostSymbol_ || !IsBindCProcedure(*innermostSymbol_)) {
@@ -1060,7 +1070,7 @@ void CheckHelper::CheckSubprogram(
 }
 
 void CheckHelper::CheckLocalVsGlobal(const Symbol &symbol) {
-  if (IsProcedure(symbol) && IsExternal(symbol)) {
+  if (IsExternal(symbol)) {
     if (const Symbol *global{FindGlobal(symbol)}; global && global != &symbol) {
       std::string interfaceName{symbol.name().ToString()};
       if (const auto *bind{symbol.GetBindName()}) {
@@ -1095,8 +1105,13 @@ void CheckHelper::CheckLocalVsGlobal(const Symbol &symbol) {
             }
           }
         }
-        evaluate::AttachDeclaration(msg, *global);
-        evaluate::AttachDeclaration(msg, symbol);
+        if (msg) {
+          if (msg->IsFatal()) {
+            context_.SetError(symbol);
+          }
+          evaluate::AttachDeclaration(msg, *global);
+          evaluate::AttachDeclaration(msg, symbol);
+        }
       }
     }
   }
@@ -2080,14 +2095,75 @@ void CheckHelper::CheckGenericOps(const Scope &scope) {
   helper.Check(scope);
 }
 
-static const std::string *DefinesBindCName(const Symbol &symbol) {
+static bool IsSubprogramDefinition(const Symbol &symbol) {
   const auto *subp{symbol.detailsIf<SubprogramDetails>()};
-  if ((subp && !subp->isInterface()) || symbol.has<ObjectEntityDetails>() ||
-      symbol.has<CommonBlockDetails>()) {
-    // Symbol defines data or entry point
-    return symbol.GetBindName();
+  return subp && !subp->isInterface() && symbol.scope() &&
+      symbol.scope()->kind() == Scope::Kind::Subprogram;
+}
+
+static bool IsBlockData(const Symbol &symbol) {
+  return symbol.scope() && symbol.scope()->kind() == Scope::Kind::BlockData;
+}
+
+static bool IsExternalProcedureDefinition(const Symbol &symbol) {
+  return IsBlockData(symbol) ||
+      (IsSubprogramDefinition(symbol) &&
+          (IsExternal(symbol) || symbol.GetBindName()));
+}
+
+static std::optional<std::string> DefinesGlobalName(const Symbol &symbol) {
+  if (const auto *module{symbol.detailsIf<ModuleDetails>()}) {
+    if (!module->isSubmodule() && !symbol.owner().IsIntrinsicModules()) {
+      return symbol.name().ToString();
+    }
+  } else if (IsBlockData(symbol)) {
+    return symbol.name().ToString();
   } else {
-    return nullptr;
+    const std::string *bindC{symbol.GetBindName()};
+    if (symbol.has<CommonBlockDetails>() ||
+        IsExternalProcedureDefinition(symbol)) {
+      return bindC ? *bindC : symbol.name().ToString();
+    } else if (bindC &&
+        (symbol.has<ObjectEntityDetails>() || IsModuleProcedure(symbol))) {
+      return *bindC;
+    }
+  }
+  return std::nullopt;
+}
+
+// 19.2 p2
+void CheckHelper::CheckGlobalName(const Symbol &symbol) {
+  if (auto global{DefinesGlobalName(symbol)}) {
+    auto pair{globalNames_.emplace(std::move(*global), symbol)};
+    if (!pair.second) {
+      const Symbol &other{*pair.first->second};
+      if (context_.HasError(symbol) || context_.HasError(other)) {
+        // don't pile on
+      } else if (symbol.has<CommonBlockDetails>() &&
+          other.has<CommonBlockDetails>() && symbol.name() == other.name()) {
+        // Two common blocks can have the same global name so long as
+        // they're not in the same scope.
+      } else if ((IsProcedure(symbol) || IsBlockData(symbol)) &&
+          (IsProcedure(other) || IsBlockData(other)) &&
+          (!IsExternalProcedureDefinition(symbol) ||
+              !IsExternalProcedureDefinition(other))) {
+        // both are procedures/BLOCK DATA, not both definitions
+      } else if (symbol.has<ModuleDetails>()) {
+        messages_.Say(symbol.name(),
+            "Module '%s' conflicts with a global name"_port_en_US,
+            pair.first->first);
+      } else if (other.has<ModuleDetails>()) {
+        messages_.Say(symbol.name(),
+            "Global name '%s' conflicts with a module"_port_en_US,
+            pair.first->first);
+      } else if (auto *msg{messages_.Say(symbol.name(),
+                     "Two entities have the same global name '%s'"_err_en_US,
+                     pair.first->first)}) {
+        msg->Attach(other.name(), "Conflicting declaration"_en_US);
+        context_.SetError(symbol);
+        context_.SetError(other);
+      }
+    }
   }
 }
 
@@ -2102,25 +2178,6 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
         "A variable with BIND(C) attribute may only appear in the specification part of a module"_err_en_US);
     context_.SetError(symbol);
   }
-  if (const std::string *name{DefinesBindCName(symbol)}) {
-    auto pair{bindC_.emplace(*name, symbol)};
-    if (!pair.second) {
-      const Symbol &other{*pair.first->second};
-      if (symbol.has<CommonBlockDetails>() && other.has<CommonBlockDetails>() &&
-          symbol.name() == other.name()) {
-        // Two common blocks can have the same BIND(C) name so long as
-        // they're not in the same scope.
-      } else if (!context_.HasError(other)) {
-        if (auto *msg{messages_.Say(symbol.name(),
-                "Two entities have the same BIND(C) name '%s'"_err_en_US,
-                *name)}) {
-          msg->Attach(other.name(), "Conflicting declaration"_en_US);
-        }
-        context_.SetError(symbol);
-        context_.SetError(other);
-      }
-    }
-  }
   if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
     if (!proc->procInterface() ||
         !proc->procInterface()->attrs().test(Attr::BIND_C)) {

diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 4c10135..f4d3d88 100644 (file)
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -2541,7 +2541,7 @@ bool ScopeHandler::ConvertToProcEntity(Symbol &symbol) {
     if (IsFunctionResult(symbol) &&
         !(IsPointer(symbol) && symbol.attrs().test(Attr::EXTERNAL))) {
       // Don't turn function result into a procedure pointer unless both
-      // POUNTER and EXTERNAL
+      // POINTER and EXTERNAL
       return false;
     }
     funcResultStack_.CompleteTypeIfFunctionResult(symbol);
@@ -3242,6 +3242,8 @@ void InterfaceVisitor::ResolveSpecificsInGeneric(Symbol &generic) {
       case ProcedureDefinitionClass::Intrinsic:
       case ProcedureDefinitionClass::External:
       case ProcedureDefinitionClass::Internal:
+      case ProcedureDefinitionClass::Dummy:
+      case ProcedureDefinitionClass::Pointer:
         break;
       case ProcedureDefinitionClass::None:
         Say(*name, "'%s' is not a procedure"_err_en_US);

diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 562692e..4bed8a0 100644 (file)
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -1042,14 +1042,12 @@ ProcedureDefinitionClass ClassifyProcedure(const Symbol &symbol) { // 15.2.2
     return ProcedureDefinitionClass::None;
   } else if (ultimate.attrs().test(Attr::INTRINSIC)) {
     return ProcedureDefinitionClass::Intrinsic;
+  } else if (IsDummy(ultimate)) {
+    return ProcedureDefinitionClass::Dummy;
+  } else if (IsProcedurePointer(symbol)) {
+    return ProcedureDefinitionClass::Pointer;
   } else if (ultimate.attrs().test(Attr::EXTERNAL)) {
     return ProcedureDefinitionClass::External;
-  } else if (const auto *procDetails{ultimate.detailsIf<ProcEntityDetails>()}) {
-    if (procDetails->isDummy()) {
-      return ProcedureDefinitionClass::Dummy;
-    } else if (IsPointer(ultimate)) {
-      return ProcedureDefinitionClass::Pointer;
-    }
   } else if (const auto *nameDetails{
                  ultimate.detailsIf<SubprogramNameDetails>()}) {
     switch (nameDetails->kind()) {

diff --git a/flang/test/Lower/pointer-initial-target-2.f90 b/flang/test/Lower/pointer-initial-target-2.f90
index 9a7393d..102f8e8 100644 (file)
--- a/flang/test/Lower/pointer-initial-target-2.f90
+++ b/flang/test/Lower/pointer-initial-target-2.f90
@@ -36,7 +36,7 @@ block data tied
 end block data
 
 ! Test pointer in a common with initial target in the same common.
-block data snake
+block data bdsnake
   integer, target :: b = 42
   integer, pointer :: p => b
   common /snake/ p, b

diff --git a/flang/test/Semantics/bind-c01.f90 b/flang/test/Semantics/bind-c01.f90
index 6e3824d..f0546b3 100644 (file)
--- a/flang/test/Semantics/bind-c01.f90
+++ b/flang/test/Semantics/bind-c01.f90
@@ -3,14 +3,14 @@
 
 module m1
   integer, bind(c, name="x1") :: x1
-  !ERROR: Two entities have the same BIND(C) name 'x1'
+  !ERROR: Two entities have the same global name 'x1'
   integer, bind(c, name=" x1 ") :: x2
  contains
   subroutine x3() bind(c, name="x3")
   end subroutine
 end module
 
-!ERROR: Two entities have the same BIND(C) name 'x3'
+!ERROR: Two entities have the same global name 'x3'
 subroutine x4() bind(c, name=" x3 ")
 end subroutine
 

diff --git a/flang/test/Semantics/bind-c02.f90 b/flang/test/Semantics/bind-c02.f90
index 18b9094..c1b44cc 100644 (file)
--- a/flang/test/Semantics/bind-c02.f90
+++ b/flang/test/Semantics/bind-c02.f90
@@ -18,6 +18,7 @@ module m
   !ERROR: Only variable and named common block can be in BIND statement
   bind(c) :: sub
 
+  !PORTABILITY: Global name 'm' conflicts with a module
   !PORTABILITY: Name 'm' declared in a module should not have the same name as the module
   bind(c) :: m ! no error for implicit type variable
 

diff --git a/flang/test/Semantics/call01.f90 b/flang/test/Semantics/call01.f90
index 7147692..40f7bef 100644 (file)
--- a/flang/test/Semantics/call01.f90
+++ b/flang/test/Semantics/call01.f90
@@ -119,11 +119,11 @@ function f14(n) result(res)
 end function
 
 subroutine s01(f1, f2, fp1, fp2)
-  !PORTABILITY: A procedure pointer should not have assumed-length CHARACTER(*) result type
+  !PORTABILITY: A dummy procedure pointer should not have assumed-length CHARACTER(*) result type
   character*(*) :: f1, f3, fp1
   external :: f1, f3
   pointer :: fp1
-  !PORTABILITY: A procedure pointer should not have assumed-length CHARACTER(*) result type
+  !PORTABILITY: A dummy procedure pointer should not have assumed-length CHARACTER(*) result type
   procedure(character*(*)), pointer :: fp2
   interface
     character*(*) function f2()

diff --git a/flang/test/Semantics/call31.f90 b/flang/test/Semantics/call31.f90
index 16c7344..eb44111 100644 (file)
--- a/flang/test/Semantics/call31.f90
+++ b/flang/test/Semantics/call31.f90
@@ -4,9 +4,9 @@
       module m
        contains
         subroutine subr(parg)
-          !PORTABILITY: A procedure pointer should not have assumed-length CHARACTER(*) result type
+          !PORTABILITY: A dummy procedure pointer should not have assumed-length CHARACTER(*) result type
           procedure(character(*)), pointer :: parg
-          !PORTABILITY: A procedure pointer should not have assumed-length CHARACTER(*) result type
+          !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result
           procedure(character(*)), pointer :: plocal
           print *, parg()
           plocal => parg
@@ -14,7 +14,7 @@
         end subroutine
 
         subroutine subr_1(parg_1)
-          !PORTABILITY: A procedure pointer should not have assumed-length CHARACTER(*) result type
+          !PORTABILITY: A dummy procedure pointer should not have assumed-length CHARACTER(*) result type
           procedure(character(*)), pointer :: parg_1
           print *, parg_1()
         end subroutine

diff --git a/flang/test/Semantics/declarations03.f90 b/flang/test/Semantics/declarations03.f90
index 11de6dc..6eda65c 100644 (file)
--- a/flang/test/Semantics/declarations03.f90
+++ b/flang/test/Semantics/declarations03.f90
@@ -5,17 +5,17 @@ module m
 
   integer :: x, y, z, w, i, j, k
 
-  !ERROR: Two entities have the same BIND(C) name 'aa'
+  !ERROR: Two entities have the same global name 'aa'
   common /blk1/ x, /blk2/ y
   bind(c, name="aa") :: /blk1/, /blk2/
 
   integer :: t
-  !ERROR: Two entities have the same BIND(C) name 'bb'
+  !ERROR: Two entities have the same global name 'bb'
   common /blk3/ z
   bind(c, name="bb") :: /blk3/, t
 
   integer :: t2
-  !ERROR: Two entities have the same BIND(C) name 'cc'
+  !ERROR: Two entities have the same global name 'cc'
   common /blk4/ w
   bind(c, name="cc") :: t2, /blk4/
 
@@ -24,7 +24,7 @@ module m
   bind(c, name="dd") :: /blk5/
   bind(c, name="ee") :: /blk5/
 
-  !ERROR: Two entities have the same BIND(C) name 'ff'
+  !ERROR: Two entities have the same global name 'ff'
   common /blk6/ j, /blk7/ k
   bind(c, name="ff") :: /blk6/
   bind(c, name="ff") :: /blk7/
@@ -34,7 +34,7 @@ module m
   bind(c, name="gg") :: s1
   bind(c, name="hh") :: s1
 
-  !ERROR: Two entities have the same BIND(C) name 'ii'
+  !ERROR: Two entities have the same global name 'ii'
   integer :: s2, s3
   bind(c, name="ii") :: s2
   bind(c, name="ii") :: s3
@@ -66,6 +66,6 @@ module a
 end module
 
 module b
-  !ERROR: Two entities have the same BIND(C) name 'int'
+  !ERROR: Two entities have the same global name 'int'
   integer, bind(c, name="int") :: i
 end module

diff --git a/flang/test/Semantics/declarations04.f90 b/flang/test/Semantics/declarations04.f90
new file mode 100644 (file)
index 0000000..f061cb9
--- /dev/null
+++ b/flang/test/Semantics/declarations04.f90
@@ -0,0 +1,25 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! test global name conflicts
+
+subroutine ext1
+end
+
+subroutine ext2
+  !ERROR: Two entities have the same global name 'ext1'
+  common /ext1/ x
+end
+
+module ext4
+ contains
+  !ERROR: Two entities have the same global name 'ext2'
+  subroutine foo() bind(c,name="ext2")
+  end
+  !ERROR: Two entities have the same global name 'ext3'
+  subroutine bar() bind(c,name="ext3")
+  end
+end
+
+block data ext3
+  !PORTABILITY: Global name 'ext4' conflicts with a module
+  common /ext4/ x
+end