[flang] BIND(C,NAME=...) corrections

[klausler]

Summary

The Fortran standard's various restrictions on the use of BIND(C)
often depend more on the presence or absence of an explicit NAME=
specification rather than on its value, but semantics and module
file generation aren't making distinctions between explicit NAME=
specifications that happen to match the default name and declarations
that don't have NAME=. Tweak semantics and module file generation
to conform, and also complain when named BIND(C) attributes are
erroneously applied to entities that can't support them, like
ABSTRACT interfaces.

[klausler]

Include an omitted update to a test.

flang/include/flang/Semantics/symbol.h

 private:
 };
 
 class WithBindName {
 public:
   const std::string *bindName() const {
     return bindName_ ? &*bindName_ : nullptr;
   }
+  bool isExplicitBindName() const { return isExplicitBindName_; }
   void set_bindName(std::string &&name) { bindName_ = std::move(name); }
+  void set_isExplicitBindName(bool yes) { isExplicitBindName_ = yes; }
 
 private:
   std::optional<std::string> bindName_;
+  bool isExplicitBindName_{false};
 };
 
 // A subroutine or function definition, or a subprogram interface defined
 // in an INTERFACE block as part of the definition of a dummy procedure
 // or a procedure pointer (with just POINTER).
 class SubprogramDetails : public WithBindName {
 public:
   bool isFunction() const { return result_ != nullptr; }
public:
   inline const Symbol &GetUltimate() const;
 
   inline DeclTypeSpec *GetType();
   inline const DeclTypeSpec *GetType() const;
   void SetType(const DeclTypeSpec &);
 
   const std::string *GetBindName() const;
   void SetBindName(std::string &&);
+  bool GetIsExplicitBindName() const;
+  void SetIsExplicitBindName(bool);
   bool IsFuncResult() const;
   bool IsObjectArray() const;
   bool IsSubprogram() const;
   bool IsFromModFile() const;
   bool HasExplicitInterface() const {
     return common::visit(
         common::visitors{
             [](const SubprogramDetails &) { return true; },

flang/lib/Semantics/check-declarations.cpp

 
 void CheckHelper::CheckBindC(const Symbol &symbol) {
   if (!symbol.attrs().test(Attr::BIND_C)) {
     return;
   }
   CheckConflicting(symbol, Attr::BIND_C, Attr::PARAMETER);
   CheckConflicting(symbol, Attr::BIND_C, Attr::ELEMENTAL);
   if (const std::string * bindName{symbol.GetBindName()};
-      bindName && !bindName->empty()) {
+      bindName) { // BIND(C,NAME=...)
+    if (!bindName->empty()) {
       bool ok{bindName->front() == '_' || parser::IsLetter(bindName->front())};
       for (char ch : *bindName) {
         ok &= ch == '_' || parser::IsLetter(ch) || parser::IsDecimalDigit(ch);
       }
       if (!ok) {
         messages_.Say(symbol.name(),
             "Symbol has a BIND(C) name that is not a valid C language identifier"_err_en_US);
         context_.SetError(symbol);
       }
     }
+  }
+  if (symbol.GetIsExplicitBindName()) { // C1552, C1529
+    auto defClass{ClassifyProcedure(symbol)};
+    if (IsProcedurePointer(symbol)) {
+      messages_.Say(symbol.name(),
+          "A procedure pointer may not have a BIND attribute with a name"_err_en_US);
+      context_.SetError(symbol);
+    } else if (defClass == ProcedureDefinitionClass::None ||
+        IsExternal(symbol)) {
+    } else if (symbol.attrs().test(Attr::ABSTRACT)) {
+      messages_.Say(symbol.name(),
+          "An ABSTRACT interface may not have a BIND attribute with a name"_err_en_US);
+      context_.SetError(symbol);
+    } else if (defClass == ProcedureDefinitionClass::Internal ||
+        defClass == ProcedureDefinitionClass::Dummy) {
+      messages_.Say(symbol.name(),
+          "An internal or dummy procedure may not have a BIND(C,NAME=) binding label"_err_en_US);
+      context_.SetError(symbol);
+    }
+  }
   if (symbol.detailsIf<ObjectEntityDetails>()) {
     if (!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);
       context_.SetError(symbol);
     }
     if (auto extents{evaluate::GetConstantExtents(foldingContext_, symbol)};
         extents && evaluate::GetSize(*extents) == 0) {
       SayWithDeclaration(symbol, symbol.name(),
           "Interoperable array must have at least one element"_err_en_US);
     }
+    if (const auto *type{symbol.GetType()}) {
+      if (const auto *derived{type->AsDerived()}) {
+        if (!derived->typeSymbol().attrs().test(Attr::BIND_C)) {
+          if (auto *msg{messages_.Say(symbol.name(),
+                  "The derived type of a BIND(C) object must also be BIND(C)"_err_en_US)}) {
+            msg->Attach(
+                derived->typeSymbol().name(), "Non-interoperable type"_en_US);
+          }
+          context_.SetError(symbol);
+        }
+      } else if (!IsInteroperableIntrinsicType(*type)) {
+        messages_.Say(symbol.name(),
+            "A BIND(C) object must have an interoperable type"_err_en_US);
+        context_.SetError(symbol);
+      }
+    }
   } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
     if (!proc->procInterface() ||
         !proc->procInterface()->attrs().test(Attr::BIND_C)) {
       messages_.Say(symbol.name(),
           "An interface name with BIND attribute must be specified if the BIND attribute is specified in a procedure declaration statement"_err_en_US);
       context_.SetError(symbol);
     }
   } else if (const auto *derived{symbol.detailsIf<DerivedTypeDetails>()}) {

flang/lib/Semantics/mod-file.h

private:
   void PutDerivedType(const Symbol &, const Scope * = nullptr);
   void PutDECStructure(const Symbol &, const Scope * = nullptr);
   void PutTypeParam(llvm::raw_ostream &, const Symbol &);
   void PutSubprogram(const Symbol &);
   void PutGeneric(const Symbol &);
   void PutUse(const Symbol &);
   void PutUseExtraAttr(Attr, const Symbol &, const Symbol &);
   llvm::raw_ostream &PutAttrs(llvm::raw_ostream &, Attrs,
-      const std::string * = nullptr, std::string before = ","s,
+      const std::string * = nullptr, bool = false, std::string before = ","s,
       std::string after = ""s) const;
 };
 
 class ModFileReader {
 public:
   // directories specifies where to search for module files
   ModFileReader(SemanticsContext &context) : context_{context} {}
   // Find and read the module file for a module or submodule.

flang/lib/Semantics/mod-file.cpp

common::visit(
             decls_ << "common/" << symbol.name();
             char sep = '/';
             for (const auto &object : x.objects()) {
               decls_ << sep << object->name();
               sep = ',';
             }
             decls_ << '\n';
             if (symbol.attrs().test(Attr::BIND_C)) {
-              PutAttrs(decls_, symbol.attrs(), x.bindName(), ""s);
+              PutAttrs(decls_, symbol.attrs(), x.bindName(),
+                  x.isExplicitBindName(), ""s);
               decls_ << "::/" << symbol.name() << "/\n";
             }
           },
           [](const HostAssocDetails &) {},
           [](const MiscDetails &) {},
           [&](const auto &) {
             PutEntity(decls_, symbol);
             if (symbol.test(Symbol::Flag::OmpThreadprivate)) {
void ModFileWriter::PutSubprogram(const Symbol &symbol) {
   if (!ss.str().empty()) {
     decls_ << ss.str().substr(1) << "::" << symbol.name() << '\n';
   }
   bool isInterface{details.isInterface()};
   llvm::raw_ostream &os{isInterface ? decls_ : contains_};
   if (isInterface) {
     os << (isAbstract ? "abstract " : "") << "interface\n";
   }
-  PutAttrs(os, prefixAttrs, nullptr, ""s, " "s);
+  PutAttrs(os, prefixAttrs, nullptr, false, ""s, " "s);
   os << (details.isFunction() ? "function " : "subroutine ");
   os << symbol.name() << '(';
   int n = 0;
   for (const auto &dummy : details.dummyArgs()) {
     if (n++ > 0) {
       os << ',';
     }
     if (dummy) {
       os << dummy->name();
     } else {
       os << "*";
     }
   }
   os << ')';
-  PutAttrs(os, bindAttrs, details.bindName(), " "s, ""s);
+  PutAttrs(os, bindAttrs, details.bindName(), details.isExplicitBindName(),
+      " "s, ""s);
   if (details.isFunction()) {
     const Symbol &result{details.result()};
     if (result.name() != symbol.name()) {
       os << " result(" << result.name() << ')';
     }
   }
   os << '\n';
 
void PutBound(llvm::raw_ostream &os, const Bound &x) {
   }
 }
 
 // Write an entity (object or procedure) declaration.
 // writeType is called to write out the type.
 void ModFileWriter::PutEntity(llvm::raw_ostream &os, const Symbol &symbol,
     std::function<void()> writeType, Attrs attrs) {
   writeType();
-  PutAttrs(os, attrs, symbol.GetBindName());
+  PutAttrs(os, attrs, symbol.GetBindName(), symbol.GetIsExplicitBindName());
   if (symbol.owner().kind() == Scope::Kind::DerivedType &&
       context_.IsTempName(symbol.name().ToString())) {
     os << "::%FILL";
   } else {
     os << "::" << symbol.name();
   }
 }
 
 // Put out each attribute to os, surrounded by `before` and `after` and
 // mapped to lower case.
 llvm::raw_ostream &ModFileWriter::PutAttrs(llvm::raw_ostream &os, Attrs attrs,
-    const std::string *bindName, std::string before, std::string after) const {
+    const std::string *bindName, bool isExplicitBindName, std::string before,
+    std::string after) const {
   attrs.set(Attr::PUBLIC, false); // no need to write PUBLIC
   attrs.set(Attr::EXTERNAL, false); // no need to write EXTERNAL
   if (isSubmodule_) {
     attrs.set(Attr::PRIVATE, false);
   }
-  if (bindName) {
-    os << before << "bind(c, name=\"" << *bindName << "\")" << after;
+  if (bindName || isExplicitBindName) {
+    os << before << "bind(c";
+    if (isExplicitBindName) {
+      os << ",name=\"" << (bindName ? *bindName : ""s) << '"';
+    }
+    os << ')' << after;
     attrs.set(Attr::BIND_C, false);
   }
   for (std::size_t i{0}; i < Attr_enumSize; ++i) {
     Attr attr{static_cast<Attr>(i)};
     if (attrs.test(attr)) {
       PutAttr(os << before, attr) << after;
     }
   }

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_)};
-  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) {
+    symbol.SetIsExplicitBindName(true);
     auto first{label->find_first_not_of(" ")};
     if (first == std::string::npos) {
       // Empty NAME= means no binding at all (18.10.2p2)
       return;
     }
     auto last{label->find_last_not_of(" ")};
     label = label->substr(first, last - first + 1);
   } else {
-    label = parser::ToLowerCaseLetters(symbol.name().ToString());
+    label = 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()) {
void DeclarationVisitor::Post(const parser::ProcDecl &x) {
   if (!dtDetails) {
     attrs.set(Attr::EXTERNAL);
   }
   Symbol &symbol{DeclareProcEntity(name, attrs, procInterface)};
   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/lib/Semantics/symbol.cpp

common::visit(
           x.set_bindName(std::move(name));
         } else {
           DIE("bind name not allowed on this kind of symbol");
         }
       },
       details_);
 }
 
+bool Symbol::GetIsExplicitBindName() const {
+  return common::visit(
+      [&](auto &x) -> bool {
+        if constexpr (HasBindName<decltype(&x)>) {
+          return x.isExplicitBindName();
+        } else {
+          return false;
+        }
+      },
+      details_);
+}
+
+void Symbol::SetIsExplicitBindName(bool yes) {
+  common::visit(
+      [&](auto &x) {
+        if constexpr (HasBindName<decltype(&x)>) {
+          x.set_isExplicitBindName(yes);
+        } else {
+          DIE("bind name not allowed on this kind of symbol");
+        }
+      },
+      details_);
+}
+
 bool Symbol::IsFuncResult() const {
   return common::visit(
       common::visitors{[](const EntityDetails &x) { return x.isFuncResult(); },
           [](const ObjectEntityDetails &x) { return x.isFuncResult(); },
           [](const ProcEntityDetails &x) { return x.isFuncResult(); },
           [](const HostAssocDetails &x) { return x.symbol().IsFuncResult(); },
           [](const auto &) { return false; }},
       details_);

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
 
+  abstract interface
+    !ERROR: An ABSTRACT interface may not have a BIND attribute with a name
+    subroutine aproc1() bind(c,name="foo")
+    end
+    subroutine aproc2() bind(c) ! ok
+    end
+  end interface
+
   !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
+  !ERROR: A procedure pointer may not have a BIND attribute with a name
   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
+  !ERROR: An internal or dummy procedure may not have a BIND(C,NAME=) binding label
   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
+  !ERROR: A procedure pointer may not have a BIND attribute with a name
   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
+  !ERROR: A procedure pointer may not have a BIND attribute with a name
   procedure(proc), bind(c, name="pc8"), bind(c), pointer :: pc8
 
 end

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
+  !ERROR: An internal or dummy 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
+  !ERROR: An internal or dummy procedure may not have a BIND(C,NAME=) binding label
   subroutine internal3() bind(c,name="")
   end subroutine
 end

flang/test/Semantics/declarations02.f90

module m
   type :: my_type1
     integer :: x4
   end type
   type, bind(c) :: my_type2
     integer :: x5
   end type
 
   !ERROR: 't1' may not have both the BIND(C) and PARAMETER attributes
+  !ERROR: The derived type of a BIND(C) object must also be BIND(C)
   type(my_type1), bind(c), parameter :: t1 = my_type1(1)
   !ERROR: 't2' may not have both the BIND(C) and PARAMETER attributes
   type(my_type2), bind(c), parameter :: t2 = my_type2(1)
 
   type(my_type2), parameter :: t3 = my_type2(1) ! no error
   !ERROR: 't4' may not have both the BIND(C) and PARAMETER attributes
+  !ERROR: The derived type of a BIND(C) object must also be BIND(C)
   type(my_type1), parameter :: t4 = my_type1(1)
   !ERROR: 't5' may not have both the BIND(C) and PARAMETER attributes
   type(my_type2), parameter :: t5 = my_type2(1)
   bind(c) :: t4, t5
 
 end

flang/test/Semantics/modfile04.f90

contains
   end subroutine
 end module m3
 
 !Expect: m1.mod
 !module m1
 !type::t
 !end type
 !contains
-!pure subroutine ss(x,y) bind(c, name="ss")
+!pure subroutine ss(x,y) bind(c)
 !logical(4),intent(in)::x
 !real(4),intent(inout)::y
 !end
 !function f1() result(x)
 !real(4)::x
 !end
 !function f2(y)
 !complex(4)::y

flang/test/Semantics/modfile21.f90

 !  real(4)::z
 !  real(4)::u
 !  real(4)::v
 !  complex(4)::w
 !  real(4)::cb
 !  common/cb/x,y,z
 !  bind(c, name="CB")::/cb/
 !  common/cb2/a,b,c
-!  bind(c, name="cb2")::/cb2/
+!  bind(c)::/cb2/
 !  common/b/cb
 !  common//t,w,u,v
 !end