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

[peixin]

Summary

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.

[peixin]

ping

[klausler]

flang/lib/Semantics/check-declarations.cpp

380

Would be less confusing if you reversed the test and deleted the return statement.

flang/lib/Semantics/resolve-names.cpp

1677

This is written in a confusing style. Try this:

auto oldName{symbol.GetBindName()};
symbol.SetBindName(std::move(*label));
if (oldName) {
  if (auto newName{symbol.GetBindName()}) {
    if (*oldName != *newName) {
      // error
    }
  }
}

[peixin]

Addressed the comments from @klausler .

flang/lib/Semantics/check-declarations.cpp

380

Fixed.

flang/lib/Semantics/resolve-names.cpp

1677

symbol.GetBindName() returns the pointer to oldName. After symbol.SetBindName, oldName points to the new symbol.GetBindName(). So oldName must store the value of bind name. But change the style as suggested.

[jeanPerier]

flang/lib/Semantics/resolve-names.cpp

1685

if (std::string newBindName* = symbol.GetBindName()) {
...
}

[peixin]

Address the comments from @jeanPerier .

[klausler]

This program no longer compiles after this patch:

subroutine subr

bind(c,name="foo") /blk/
integer j
common /blk/ j
print *, j

end
program main

bind(c,name="foo") /blk/
integer j
common /blk/ j
j = 123
call subr

end

[peixin]

In D126961#3587604, @klausler wrote:

This program no longer compiles after this patch:

subroutine subr

bind(c,name="foo") /blk/
integer j
common /blk/ j
print *, j

end
program main

bind(c,name="foo") /blk/
integer j
common /blk/ j
j = 123
call subr

end

Thanks for this. @jeanPerier has sent me one similar regression test yesterday and it has been fixed by https://reviews.llvm.org/rG60e359943bfc22155cd239c9b40b3e4c41026915.

flang/lib/Semantics/check-declarations.cpp

public:
   void Check(const Bound &bound) { CheckSpecExpr(bound.GetExplicit()); }
   void Check(const ShapeSpec &spec) {
     Check(spec.lbound());
     Check(spec.ubound());
   }
   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 &);
 
 private:
   template <typename A> void CheckSpecExpr(const A &x) {
     evaluate::CheckSpecificationExpr(x, DEREF(scope_), foldingContext_);
   }
   void CheckValue(const Symbol &, const DerivedTypeSpec *);
void CheckHelper::Check(const Symbol &symbol) {
   if (symbol.owner().IsModule() && IsAutomatic(symbol)) {
     messages_.Say(
         "Automatic data object '%s' may not appear in the specification part"
         " of a module"_err_en_US,
         symbol.name());
   }
 }
 
+void CheckHelper::CheckCommonBlock(const Symbol &symbol) { CheckBindC(symbol); }
+
 void CheckHelper::CheckValue(
     const Symbol &symbol, const DerivedTypeSpec *derived) { // C863 - C865
   if (!IsDummy(symbol)) {
     messages_.Say(
         "VALUE attribute may apply only to a dummy argument"_err_en_US);
   }
   if (IsProcedure(symbol)) {
     messages_.Say(
if (scope.IsParameterizedDerivedTypeInstantiation()) {
     auto restorer{common::ScopedSet(
         scopeIsUninstantiatedPDT_, scope.IsParameterizedDerivedType())};
     for (const auto &set : scope.equivalenceSets()) {
       CheckEquivalenceSet(set);
     }
     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);
       // A program shall consist of exactly one main program (5.2.2).
       if (child.kind() == Scope::Kind::MainProgram) {
         ++mainProgCnt;
         if (mainProgCnt > 1) {
           messages_.Say(child.sourceRange(),
void CheckHelper::CheckGenericOps(const Scope &scope) {
   }
   helper.Check(scope);
 }
 
 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 {
     return nullptr;
   }
 }
 
 void CheckHelper::CheckBindC(const Symbol &symbol) {
   if (!symbol.attrs().test(Attr::BIND_C)) {
     return;
   }
   CheckConflicting(symbol, Attr::BIND_C, Attr::PARAMETER);
   if (symbol.has<ObjectEntityDetails>() && !symbol.owner().IsModule()) {
     messages_.Say(symbol.name(),
         "A variable with BIND(C) attribute may only appear in the specification part of a module"_err_en_US);
   }
   if (const std::string * name{DefinesBindCName(symbol)}) {
     auto pair{bindC_.emplace(*name, 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);
         }
         context_.SetError(symbol);
         context_.SetError(other);
       }
     }

flang/lib/Semantics/resolve-names.cpp

if (first == std::string::npos) {
       Say(currStmtSource().value(), "Blank binding label ignored"_warn_en_US);
       return;
     }
     auto last{label->find_last_not_of(" ")};
     label = label->substr(first, last - first + 1);
   } 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) {
   CHECK(attrs_);
   if (CheckAndSet(Attr::BIND_C)) {
     if (x.v) {
       bindName_ = EvaluateExpr(*x.v);
     }

flang/test/Semantics/declarations03.f90

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