[flang-commits] [flang] dafd3cf - [flang] Complement one-to-one association check of bind name and entity name

[via flang-commits]

Author: Peixin-Qiao
Date: 2022-06-14T10:34:38+08:00
New Revision: dafd3cf8b1cc9dae0ae1fabc2fd1ad4379119d11

URL: https://github.com/llvm/llvm-project/commit/dafd3cf8b1cc9dae0ae1fabc2fd1ad4379119d11
DIFF: https://github.com/llvm/llvm-project/commit/dafd3cf8b1cc9dae0ae1fabc2fd1ad4379119d11.diff

LOG: [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

Added: 
    flang/test/Semantics/declarations03.f90

Modified: 
    flang/lib/Semantics/check-declarations.cpp
    flang/lib/Semantics/resolve-names.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index fff0197bf9a8..c8260f598c15 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -46,6 +46,7 @@ class CheckHelper {
   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 bdd8416427bc..99a5da166f5e 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 000000000000..a6709c25684f
--- /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