diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h index 03fae985a0886..6a480b44d5a8a 100644 --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -70,10 +70,13 @@ class WithBindName { 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 bindName_; + bool isExplicitBindName_{false}; }; // A subroutine or function definition, or a subprogram interface defined @@ -622,6 +625,8 @@ class Symbol { const std::string *GetBindName() const; void SetBindName(std::string &&); + bool GetIsExplicitBindName() const; + void SetIsExplicitBindName(bool); bool IsFuncResult() const; bool IsObjectArray() const; bool IsSubprogram() const; diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp index fa86ed0da6259..bfb90e2f8fa3c 100644 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -2219,14 +2219,35 @@ void CheckHelper::CheckBindC(const Symbol &symbol) { CheckConflicting(symbol, Attr::BIND_C, Attr::PARAMETER); CheckConflicting(symbol, Attr::BIND_C, Attr::ELEMENTAL); if (const std::string * bindName{symbol.GetBindName()}; - bindName && !bindName->empty()) { - bool ok{bindName->front() == '_' || parser::IsLetter(bindName->front())}; - for (char ch : *bindName) { - ok &= ch == '_' || parser::IsLetter(ch) || parser::IsDecimalDigit(ch); + 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 (!ok) { + } + 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(), - "Symbol has a BIND(C) name that is not a valid C language identifier"_err_en_US); + "An internal or dummy procedure may not have a BIND(C,NAME=) binding label"_err_en_US); context_.SetError(symbol); } } @@ -2241,6 +2262,22 @@ void CheckHelper::CheckBindC(const Symbol &symbol) { 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()}) { if (!proc->procInterface() || !proc->procInterface()->attrs().test(Attr::BIND_C)) { diff --git a/flang/lib/Semantics/mod-file.cpp b/flang/lib/Semantics/mod-file.cpp index 22633054f0ca7..77ba4280a634b 100644 --- a/flang/lib/Semantics/mod-file.cpp +++ b/flang/lib/Semantics/mod-file.cpp @@ -321,7 +321,8 @@ void ModFileWriter::PutSymbol( } 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"; } }, @@ -455,7 +456,7 @@ void ModFileWriter::PutSubprogram(const Symbol &symbol) { 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; @@ -470,7 +471,8 @@ void ModFileWriter::PutSubprogram(const Symbol &symbol) { } } 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()) { @@ -766,7 +768,7 @@ void PutBound(llvm::raw_ostream &os, const Bound &x) { void ModFileWriter::PutEntity(llvm::raw_ostream &os, const Symbol &symbol, std::function 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"; @@ -778,14 +780,19 @@ void ModFileWriter::PutEntity(llvm::raw_ostream &os, const Symbol &symbol, // 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) { diff --git a/flang/lib/Semantics/mod-file.h b/flang/lib/Semantics/mod-file.h index 04f6e06bb0b40..f09e2ec9529b3 100644 --- a/flang/lib/Semantics/mod-file.h +++ b/flang/lib/Semantics/mod-file.h @@ -74,7 +74,7 @@ class ModFileWriter { 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; }; diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index edd5a604632d5..b9aa4c19af9cf 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -1699,15 +1699,9 @@ void AttrsVisitor::SetBindNameOn(Symbol &symbol) { } std::optional label{ evaluate::GetScalarConstantValue(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) @@ -1716,7 +1710,7 @@ void AttrsVisitor::SetBindNameOn(Symbol &symbol) { 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; @@ -5091,10 +5085,6 @@ void DeclarationVisitor::Post(const parser::ProcDecl &x) { 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 &) { diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp index 8e7db6dcbfb5b..348ca338fa58c 100644 --- a/flang/lib/Semantics/symbol.cpp +++ b/flang/lib/Semantics/symbol.cpp @@ -332,6 +332,30 @@ void Symbol::SetBindName(std::string &&name) { details_); } +bool Symbol::GetIsExplicitBindName() const { + return common::visit( + [&](auto &x) -> bool { + if constexpr (HasBindName) { + return x.isExplicitBindName(); + } else { + return false; + } + }, + details_); +} + +void Symbol::SetIsExplicitBindName(bool yes) { + common::visit( + [&](auto &x) { + if constexpr (HasBindName) { + 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(); }, diff --git a/flang/test/Semantics/bind-c04.f90 b/flang/test/Semantics/bind-c04.f90 index b9b766bd97f05..a4aaffb239fde 100644 --- a/flang/test/Semantics/bind-c04.f90 +++ b/flang/test/Semantics/bind-c04.f90 @@ -11,18 +11,26 @@ 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 @@ -30,7 +38,7 @@ subroutine proc() bind(c) 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 diff --git a/flang/test/Semantics/bind-c05.f90 b/flang/test/Semantics/bind-c05.f90 index 2924d54a99ab4..edc9fa8166b68 100644 --- a/flang/test/Semantics/bind-c05.f90 +++ b/flang/test/Semantics/bind-c05.f90 @@ -4,10 +4,10 @@ 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 diff --git a/flang/test/Semantics/declarations02.f90 b/flang/test/Semantics/declarations02.f90 index 016888fff5e1d..439527a0edb6a 100644 --- a/flang/test/Semantics/declarations02.f90 +++ b/flang/test/Semantics/declarations02.f90 @@ -18,12 +18,14 @@ module m 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) diff --git a/flang/test/Semantics/modfile04.f90 b/flang/test/Semantics/modfile04.f90 index 7c94401e08fca..c0829c4417984 100644 --- a/flang/test/Semantics/modfile04.f90 +++ b/flang/test/Semantics/modfile04.f90 @@ -53,7 +53,7 @@ end module m3 !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 diff --git a/flang/test/Semantics/modfile21.f90 b/flang/test/Semantics/modfile21.f90 index 513a5bdf3bfaf..72f3c1e933107 100644 --- a/flang/test/Semantics/modfile21.f90 +++ b/flang/test/Semantics/modfile21.f90 @@ -29,7 +29,7 @@ module m ! 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