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

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.

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

flang/lib/Semantics/check-declarations.cpp

@@ -1869,10 +1869,8 @@ void CheckHelper::CheckGenericOps(const Scope &scope) {
 
 static const std::string *DefinesBindCName(const Symbol &symbol) {
   const auto *subp{symbol.detailsIf<SubprogramDetails>()};
-  if ((subp && !subp->isInterface() &&
+  if ((subp && !subp->isInterface()) || symbol.has<ObjectEntityDetails>() ||
-          ClassifyProcedure(symbol) != ProcedureDefinitionClass::Internal) ||
+      symbol.has<CommonBlockDetails>()) {
-      symbol.has<ObjectEntityDetails>() || symbol.has<CommonBlockDetails>() ||
-      symbol.has<ProcEntityDetails>()) {
     // Symbol defines data or entry point
     return symbol.GetBindName();
   } else {
@@ -1893,14 +1891,15 @@ void CheckHelper::CheckBindC(const Symbol &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>() && other.has<CommonBlockDetails>() &&
-      if ((!symbol.has<CommonBlockDetails>() ||
+          symbol.name() == other.name()) {
-              symbol.name() != other.name()) &&
+        // Two common blocks can have the same BIND(C) name so long as
-          DefinesBindCName(other) && !context_.HasError(other)) {
+        // 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);

flang/lib/Semantics/resolve-names.cpp

@@ -1662,12 +1662,18 @@ void AttrsVisitor::SetBindNameOn(Symbol &symbol) {
   }
   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(" ")};
@@ -4172,10 +4178,10 @@ Symbol &DeclarationVisitor::DeclareUnknownEntity(
       SetType(name, *type);
     }
     charInfo_.length.reset();
-    SetBindNameOn(symbol);
     if (symbol.attrs().test(Attr::EXTERNAL)) {
       ConvertToProcEntity(symbol);
     }
+    SetBindNameOn(symbol);
     return symbol;
   }
 }

flang/lib/Semantics/tools.cpp

@@ -1091,7 +1091,9 @@ const Symbol *FindSeparateModuleSubprogramInterface(const Symbol *proc) {
 
 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;

flang/test/Semantics/bind-c01.f90

@@ -3,14 +3,14 @@
 
 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
 

flang/test/Semantics/bind-c04.f90

@@ -11,7 +11,7 @@ subroutine sub(x, y)
     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

flang/test/Semantics/bind-c05.f90

@@ -0,0 +1,13 @@
+! 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

@@ -5,17 +5,17 @@ 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/
 
@@ -24,7 +24,7 @@ module m
   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/
@@ -34,7 +34,7 @@ module m
   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
@@ -66,6 +66,6 @@ module a
 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