[flang] Add semantic check for C1520

[peixin]

Summary

As Fortran 2018 C1520, if proc-language-binding-spec 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.
Add this check.

[klausler]

This patch fails to catch the most important part of the constraint: that only one entity may appear.

flang/lib/Semantics/resolve-names.cpp

1050

The data member should be hasBindCName_ and it is its own comment.

4687

auto *bindC{...};
hasBindCName_ = bindC && bindC->v;

[peixin]

In D127725#3582252, @klausler wrote:

This patch fails to catch the most important part of the constraint: that only one entity may appear.

It is checked in check-declarations.cpp, which has better message format. This constraint has the same style as common block and varaibles. I also add the test case in this patch. This one:

!ERROR: Two symbols have the same BIND(C) name 'aaa'
procedure(proc), bind(c, name="aaa") :: pc1, pc2

[peixin]

Address the code style comments.

[peixin]

flang/lib/Semantics/resolve-names.cpp

1050

Thanks. Fixed.

4687

This is not correct for procedure(proc), bind(c, name="bbb"), pointer :: pc3 since it has multiple parser::ProcAttrSpec. Also add one break here to speedup this analysis. Put the assignment not in the if condition will also fail for the case procedure(proc), bind(c, name="pc8"), bind(c), pointer :: pc8 (Check the test case below).

[peixin]

ping

[klausler]

flang/lib/Semantics/resolve-names.cpp

4766

Can this check be done in check-declarations?

[peixin]

flang/lib/Semantics/resolve-names.cpp

4766

It seems not since it is unknown if the bind name is from NAME= specifier. The test cases are added in this patch:

!ERROR: BIND(C) procedure with NAME= specified can neither have POINTER attribute nor be a dummy procedure
procedure(proc), bind(c, name="pc6"), pointer :: pc6

procedure(proc), bind(c), pointer :: pc7

flang/lib/Semantics/check-declarations.cpp

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<CommonBlockDetails>()) {
+      symbol.has<ObjectEntityDetails>() || symbol.has<CommonBlockDetails>() ||
+      symbol.has<ProcEntityDetails>()) {
     // Symbol defines data or entry point
     return symbol.GetBindName();
   } else {
     return nullptr;
   }
 }
 
 void CheckHelper::CheckBindC(const Symbol &symbol) {

flang/lib/Semantics/resolve-names.cpp

struct EnumeratorState {
     // Enum value must hold inside a C_INT (7.6.2).
     std::optional<int> value{0};
   } enumerationState_;
   // Set for OldParameterStmt processing
   bool inOldStyleParameterStmt_{false};
   // Set when walking DATA & array constructor implied DO loop bounds
   // to warn about use of the implied DO intex therein.
   std::optional<SourceName> checkIndexUseInOwnBounds_;
+  bool hasBindCName_{false};
 
   bool HandleAttributeStmt(Attr, const std::list<parser::Name> &);
   Symbol &HandleAttributeStmt(Attr, const parser::Name &);
   Symbol &DeclareUnknownEntity(const parser::Name &, Attrs);
   Symbol &DeclareProcEntity(const parser::Name &, Attrs, const ProcInterface &);
   void SetType(const parser::Name &, const DeclTypeSpec &);
   std::optional<DerivedTypeSpec> ResolveDerivedType(const parser::Name &);
   std::optional<DerivedTypeSpec> ResolveExtendsType(
void DeclarationVisitor::Post(const parser::FillDecl &x) {
   const auto &name{std::get<parser::Name>(x.t)};
   const_cast<SourceName &>(name.source) = context().GetTempName(currScope());
   if (OkToAddComponent(name)) {
     auto &symbol{DeclareObjectEntity(name, GetAttrs())};
     currScope().symbol()->get<DerivedTypeDetails>().add_component(symbol);
   }
   ClearArraySpec();
 }
-bool DeclarationVisitor::Pre(const parser::ProcedureDeclarationStmt &) {
+bool DeclarationVisitor::Pre(const parser::ProcedureDeclarationStmt &x) {
   CHECK(!interfaceName_);
+  const auto &procAttrSpec{std::get<std::list<parser::ProcAttrSpec>>(x.t)};
+  for (const parser::ProcAttrSpec &procAttr : procAttrSpec) {
+    if (auto *bindC{std::get_if<parser::LanguageBindingSpec>(&procAttr.u)}) {
+      if (bindC->v.has_value()) {
+        hasBindCName_ = true;
+        break;
+      }
+    }
+  }
   return BeginDecl();
 }
 void DeclarationVisitor::Post(const parser::ProcedureDeclarationStmt &) {
   interfaceName_ = nullptr;
+  hasBindCName_ = false;
   EndDecl();
 }
 bool DeclarationVisitor::Pre(const parser::DataComponentDefStmt &x) {
   // Overrides parse tree traversal so as to handle attributes first,
   // so POINTER & ALLOCATABLE enable forward references to derived types.
   Walk(std::get<std::list<parser::ComponentAttrSpec>>(x.t));
   set_allowForwardReferenceToDerivedType(
       GetAttrs().HasAny({Attr::POINTER, Attr::ALLOCATABLE}));
void DeclarationVisitor::Post(const parser::ProcDecl &x) {
   if (!dtDetails) {
     attrs.set(Attr::EXTERNAL);
   }
   Symbol &symbol{DeclareProcEntity(name, attrs, interface)};
   symbol.ReplaceName(name.source);
   if (dtDetails) {
     dtDetails->add_component(symbol);
   }
+  if (hasBindCName_ && (IsPointer(symbol) || IsDummy(symbol))) {
+    Say(symbol.name(),
+        "BIND(C) procedure with NAME= specified can neither have POINTER attribute nor be a dummy procedure"_err_en_US);
+  }
 }
 
 bool DeclarationVisitor::Pre(const parser::TypeBoundProcedurePart &) {
   derivedTypeInfo_.sawContains = true;
   return true;
 }
 
 // Resolve binding names from type-bound generics, saved in genericBindings_.

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'
+  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
+
+  procedure(proc), bind(c) :: pc4, pc5
+
+  !ERROR: BIND(C) procedure with NAME= specified can neither have POINTER attribute nor be a dummy procedure
+  procedure(proc), bind(c, name="pc6"), pointer :: pc6
+
+  procedure(proc), bind(c), pointer :: pc7
+
+  procedure(proc), bind(c) :: y
+
+  !WARNING: Attribute 'BIND(C)' cannot be used more than once
+  !ERROR: BIND(C) procedure with NAME= specified can neither have POINTER attribute nor be a dummy procedure
+  procedure(proc), bind(c, name="pc8"), bind(c), pointer :: pc8
+
+end

flang/test/Semantics/modfile16.f90

 ! RUN: %python %S/test_modfile.py %s %flang_fc1
 module m
   character(2), parameter :: prefix = 'c_'
   integer, bind(c, name='c_a') :: a
-  procedure(sub), bind(c, name=prefix//'b'), pointer :: b
+  procedure(sub), bind(c, name=prefix//'b') :: b
   type, bind(c) :: t
     real :: c
   end type
 contains
   subroutine sub() bind(c, name='sub')
   end
 end
 
 !Expect: m.mod
 !module m
 !  character(2_4,1),parameter::prefix="c_"
 !  integer(4),bind(c, name="c_a")::a
-!  procedure(sub),bind(c, name="c_b"),pointer::b
+!  procedure(sub),bind(c, name="c_b")::b
 !  type,bind(c)::t
 !    real(4)::c
 !  end type
 !contains
 !  subroutine sub() bind(c, name="sub")
 !  end
 !end