[flang] Enforce C1552, no binding labels allowed for internal procedures

[klausler]

Summary

If BIND(C) appears on an internal procedure, it must have a null binding
label, i.e. BIND(C,NAME="").

Also address conflicts with D127725 which was merged during development.

flang/lib/Semantics/check-declarations.cpp

if (ultimate.has<DerivedTypeDetails>()) {
       }
     }
   }
   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<CommonBlockDetails>() ||
-      symbol.has<ProcEntityDetails>()) {
+  if ((subp && !subp->isInterface()) || 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};
-      // Two common blocks with the same name can have the same BIND(C) name.
-      if ((!symbol.has<CommonBlockDetails>() ||
-              symbol.name() != other.name()) &&
-          DefinesBindCName(other) && !context_.HasError(other)) {
+      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 symbols have the same BIND(C) name '%s'"_err_en_US,
+                "Two entities have the same BIND(C) name '%s'"_err_en_US,
                 *name)}) {
-          msg->Attach(other.name(), "Conflicting symbol"_en_US);
+          msg->Attach(other.name(), "Conflicting declaration"_en_US);
         }
         context_.SetError(symbol);
         context_.SetError(other);
       }
     }
   }
   if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
     if (!proc->interface().symbol() ||

flang/lib/Semantics/resolve-names.cpp

 }
 
 void AttrsVisitor::SetBindNameOn(Symbol &symbol) {
   if (!attrs_ || !attrs_->test(Attr::BIND_C)) {
     return;
   }
   std::optional<std::string> label{
       evaluate::GetScalarConstantValue<evaluate::Ascii>(bindName_)};
-  // 18.9.2(2): discard leading and trailing blanks, ignore if all blank
+  if (ClassifyProcedure(symbol) == ProcedureDefinitionClass::Internal) {
+    if (label) { // C1552: no NAME= allowed even if null
+      Say(symbol.name(),
+          "An internal procedure may not have a BIND(C,NAME=) binding label"_err_en_US);
+    }
+    return;
+  }
+  // 18.9.2(2): discard leading and trailing blanks
   if (label) {
     auto first{label->find_first_not_of(" ")};
     if (first == std::string::npos) {
       // Empty NAME= means no binding at all (18.10.2p2)
-      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.
Symbol &DeclarationVisitor::DeclareUnknownEntity(
   if (!arraySpec().empty() || !coarraySpec().empty()) {
     return DeclareObjectEntity(name, attrs);
   } else {
     Symbol &symbol{DeclareEntity<EntityDetails>(name, attrs)};
     if (auto *type{GetDeclTypeSpec()}) {
       SetType(name, *type);
     }
     charInfo_.length.reset();
-    SetBindNameOn(symbol);
     if (symbol.attrs().test(Attr::EXTERNAL)) {
       ConvertToProcEntity(symbol);
     }
+    SetBindNameOn(symbol);
     return symbol;
   }
 }
 
 bool DeclarationVisitor::HasCycle(
     const Symbol &procSymbol, const ProcInterface &interface) {
   SourceOrderedSymbolSet procsInCycle;
   procsInCycle.insert(procSymbol);

flang/lib/Semantics/tools.cpp

if (const auto *subprogram{proc->detailsIf<SubprogramDetails>()}) {
       }
     }
   }
   return nullptr;
 }
 
 ProcedureDefinitionClass ClassifyProcedure(const Symbol &symbol) { // 15.2.2
   const Symbol &ultimate{symbol.GetUltimate()};
-  if (ultimate.attrs().test(Attr::INTRINSIC)) {
+  if (!IsProcedure(ultimate)) {
+    return ProcedureDefinitionClass::None;
+  } else if (ultimate.attrs().test(Attr::INTRINSIC)) {
     return ProcedureDefinitionClass::Intrinsic;
   } 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;

flang/test/Semantics/bind-c01.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! Check for multiple symbols being defined with with same BIND(C) name
 
 module m1
   integer, bind(c, name="x1") :: x1
-  !ERROR: Two symbols have the same BIND(C) name 'x1'
+  !ERROR: Two entities have the same BIND(C) name 'x1'
   integer, bind(c, name=" x1 ") :: x2
  contains
   subroutine x3() bind(c, name="x3")
   end subroutine
 end module
 
-!ERROR: Two symbols have the same BIND(C) name 'x3'
+!ERROR: Two entities have the same BIND(C) name 'x3'
 subroutine x4() bind(c, name=" x3 ")
 end subroutine
 
 ! Ensure no error in this situation
 module m2
  interface
   subroutine x5() bind(c, name=" x5 ")
   end subroutine

flang/test/Semantics/bind-c04.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! Check for C1520
 ! If proc-language-binding-spec (bind(c)) with NAME= is specified, then
 ! proc-decl-list shall contain exactly one proc-decl, which shall neither have
 ! the POINTER attribute nor be a dummy procedure.
 
 subroutine sub(x, y)
 
   interface
     subroutine proc() bind(c)
     end
   end interface
 
-  !ERROR: Two symbols have the same BIND(C) name 'aaa'
+  !Acceptable (as an extension)
   procedure(proc), bind(c, name="aaa") :: pc1, pc2
 
   !ERROR: BIND(C) procedure with NAME= specified can neither have POINTER attribute nor be a dummy procedure
   procedure(proc), bind(c, name="bbb"), pointer :: pc3
 
   !ERROR: BIND(C) procedure with NAME= specified can neither have POINTER attribute nor be a dummy procedure
   procedure(proc), bind(c, name="ccc") :: x
 

flang/test/Semantics/bind-c05.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Check for C1552
+program main
+ contains
+  subroutine internal1() bind(c) ! ok
+  end subroutine
+  !ERROR: An internal procedure may not have a BIND(C,NAME=) binding label
+  subroutine internal2() bind(c,name="internal2")
+  end subroutine
+  !ERROR: An internal procedure may not have a BIND(C,NAME=) binding label
+  subroutine internal3() bind(c,name="")
+  end subroutine
+end

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'
+  !ERROR: Two entities 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'
+  !ERROR: Two entities 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'
+  !ERROR: Two entities 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'
+  !ERROR: Two entities 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'
+  !ERROR: Two entities 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
 
subroutine common2()
   bind(c, name='xcom') /com/ ! no error
 end subroutine
 
 module a
   integer, bind(c, name="int") :: i
 end module
 
 module b
-  !ERROR: Two symbols have the same BIND(C) name 'int'
+  !ERROR: Two entities have the same BIND(C) name 'int'
   integer, bind(c, name="int") :: i
 end module