From dafd3cf8b1cc9dae0ae1fabc2fd1ad4379119d11 Mon Sep 17 00:00:00 2001
From: Peixin-Qiao <qiaopeixin@huawei.com>
Date: Tue, 14 Jun 2022 10:34:38 +0800
Subject: [PATCH] [flang] Complement one-to-one association check of bind name
 and entity name

As Fortran 2018 C802 and C873, if bind name is specified, there can only
be only one entity. The check for common block is missed before. As
Fortran 2018 8.5.5 point 2, the bind name is one identifier, which is
unique. That is, one entity can not have multiple bind names. Also add
this check.

Reviewed By: klausler, Jean Perier

Differential Revision: https://reviews.llvm.org/D126961
---
 flang/lib/Semantics/check-declarations.cpp | 10 ++++--
 flang/lib/Semantics/resolve-names.cpp      | 12 +++++++
 flang/test/Semantics/declarations03.f90    | 50 ++++++++++++++++++++++++++++++
 3 files changed, 70 insertions(+), 2 deletions(-)
 create mode 100644 flang/test/Semantics/declarations03.f90

diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index fff0197..c8260f5 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -46,6 +46,7 @@ public:
   void Check(const ArraySpec &);
   void Check(const DeclTypeSpec &, bool canHaveAssumedTypeParameters);
   void Check(const Symbol &);
+  void CheckCommonBlock(const Symbol &);
   void Check(const Scope &);
   const Procedure *Characterize(const Symbol &);
 
@@ -375,6 +376,8 @@ void CheckHelper::Check(const Symbol &symbol) {
   }
 }
 
+void CheckHelper::CheckCommonBlock(const Symbol &symbol) { CheckBindC(symbol); }
+
 void CheckHelper::CheckValue(
     const Symbol &symbol, const DerivedTypeSpec *derived) { // C863 - C865
   if (!IsDummy(symbol)) {
@@ -1729,6 +1732,9 @@ void CheckHelper::Check(const Scope &scope) {
     for (const auto &pair : scope) {
       Check(*pair.second);
     }
+    for (const auto &pair : scope.commonBlocks()) {
+      CheckCommonBlock(*pair.second);
+    }
     int mainProgCnt{0};
     for (const Scope &child : scope.children()) {
       Check(child);
@@ -1865,7 +1871,7 @@ static const std::string *DefinesBindCName(const Symbol &symbol) {
   const auto *subp{symbol.detailsIf<SubprogramDetails>()};
   if ((subp && !subp->isInterface() &&
           ClassifyProcedure(symbol) != ProcedureDefinitionClass::Internal) ||
-      symbol.has<ObjectEntityDetails>()) {
+      symbol.has<ObjectEntityDetails>() || symbol.has<CommonBlockDetails>()) {
     // Symbol defines data or entry point
     return symbol.GetBindName();
   } else {
@@ -1887,7 +1893,7 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
     if (!pair.second) {
       const Symbol &other{*pair.first->second};
       if (DefinesBindCName(other) && !context_.HasError(other)) {
-        if (auto *msg{messages_.Say(
+        if (auto *msg{messages_.Say(symbol.name(),
                 "Two symbols have the same BIND(C) name '%s'"_err_en_US,
                 *name)}) {
           msg->Attach(other.name(), "Conflicting symbol"_en_US);
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index bdd8416..99a5da1 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -1674,7 +1674,19 @@ void AttrsVisitor::SetBindNameOn(Symbol &symbol) {
   } else {
     label = parser::ToLowerCaseLetters(symbol.name().ToString());
   }
+  // Check if a symbol has two Bind names.
+  std::string oldBindName;
+  if (symbol.GetBindName()) {
+    oldBindName = *symbol.GetBindName();
+  }
   symbol.SetBindName(std::move(*label));
+  if (!oldBindName.empty()) {
+    if (const std::string * newBindName{symbol.GetBindName()}) {
+      if (oldBindName.compare(*newBindName) != 0) {
+        Say(symbol.name(), "The entity '%s' has multiple BIND names"_err_en_US);
+      }
+    }
+  }
 }
 
 void AttrsVisitor::Post(const parser::LanguageBindingSpec &x) {
diff --git a/flang/test/Semantics/declarations03.f90 b/flang/test/Semantics/declarations03.f90
new file mode 100644
index 0000000..a6709c2
--- /dev/null
+++ b/flang/test/Semantics/declarations03.f90
@@ -0,0 +1,50 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! test bind(c) name conflict
+
+module m
+
+  integer :: x, y, z, w, i, j, k
+
+  !ERROR: Two symbols have the same BIND(C) name 'aa'
+  common /blk1/ x, /blk2/ y
+  bind(c, name="aa") :: /blk1/, /blk2/
+
+  integer :: t
+  !ERROR: Two symbols have the same BIND(C) name 'bb'
+  common /blk3/ z
+  bind(c, name="bb") :: /blk3/, t
+
+  integer :: t2
+  !ERROR: Two symbols have the same BIND(C) name 'cc'
+  common /blk4/ w
+  bind(c, name="cc") :: t2, /blk4/
+
+  !ERROR: The entity 'blk5' has multiple BIND names
+  common /blk5/ i
+  bind(c, name="dd") :: /blk5/
+  bind(c, name="ee") :: /blk5/
+
+  !ERROR: Two symbols have the same BIND(C) name 'ff'
+  common /blk6/ j, /blk7/ k
+  bind(c, name="ff") :: /blk6/
+  bind(c, name="ff") :: /blk7/
+
+  !ERROR: The entity 's1' has multiple BIND names
+  integer :: s1
+  bind(c, name="gg") :: s1
+  bind(c, name="hh") :: s1
+
+  !ERROR: Two symbols have the same BIND(C) name 'ii'
+  integer :: s2, s3
+  bind(c, name="ii") :: s2
+  bind(c, name="ii") :: s3
+
+  !ERROR: The entity 's4' has multiple BIND names
+  integer, bind(c, name="ss1") :: s4
+  bind(c, name="jj") :: s4
+
+  !ERROR: The entity 's5' has multiple BIND names
+  bind(c, name="kk") :: s5
+  integer, bind(c, name="ss2") :: s5
+
+end
-- 
2.7.4