[flang-commits] [flang] 69e2665 - [flang] BIND(C, NAME=...) corrections
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Thu Mar 2 10:10:12 PST 2023
Author: Peter Klausler
Date: 2023-03-02T10:10:06-08:00
New Revision: 69e2665c8bcf210d0cb864b86f79747af1432642
URL: https://github.com/llvm/llvm-project/commit/69e2665c8bcf210d0cb864b86f79747af1432642
DIFF: https://github.com/llvm/llvm-project/commit/69e2665c8bcf210d0cb864b86f79747af1432642.diff
LOG: [flang] BIND(C,NAME=...) corrections
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.
Differential Revision: https://reviews.llvm.org/D145107
Added:
Modified:
flang/include/flang/Semantics/symbol.h
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/mod-file.cpp
flang/lib/Semantics/mod-file.h
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/symbol.cpp
flang/test/Semantics/bind-c04.f90
flang/test/Semantics/bind-c05.f90
flang/test/Semantics/declarations02.f90
flang/test/Semantics/modfile04.f90
flang/test/Semantics/modfile21.f90
Removed:
################################################################################
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<std::string> 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<ProcEntityDetails>()}) {
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<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";
@@ -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<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)
@@ -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<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(); },
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
More information about the flang-commits
mailing list