[flang] Accept interoperable types without BIND(C) #91363
Merged
Conversation
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
llvmbot
added
flang
|
@llvm/pr-subscribers-flang-semantics Author: Peter Klausler (klausler) ChangesA derived type that meets (most of) the requirements of an interoperable type but doesn't actually have the BIND(C) attribute can be accepted as an interoperable type, with optional warnings. Patch is 23.38 KiB, truncated to 20.00 KiB below, full version: https://github.com/llvm/llvm-project/pull/91363.diff 8 Files Affected:
diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index 9030207d9bda5d..e0deb6f2f18297 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -120,6 +120,10 @@ end
appear in real applications, but are still non-conforming under the
incomplete tests in F'2023 15.4.3.4.5.
These cases are compiled with optional portability warnings.
+* `PROCEDURE(), BIND(C) :: PROC` is not conforming, as there is no
+ procedure interface. This compiler accepts it, since there is otherwise
+ no way to declare an interoperable dummy procedure with an arbitrary
+ interface like `void (*)()`.
## Extensions, deletions, and legacy features supported by default
@@ -351,6 +355,9 @@ end
when necessary to the type of the result.
An `OPTIONAL`, `POINTER`, or `ALLOCATABLE` argument after
the first two cannot be converted, as it may not be present.
+* A derived type that meets (most of) the requirements of an interoperable
+ derived type can be used as such where an interoperable type is
+ required, with warnings, even if it lacks the BIND(C) attribute.
### Extensions supported when enabled by options
diff --git a/flang/include/flang/Common/Fortran-features.h b/flang/include/flang/Common/Fortran-features.h
index 6b3e37cd9c25f1..07ed7f43c1e73d 100644
--- a/flang/include/flang/Common/Fortran-features.h
+++ b/flang/include/flang/Common/Fortran-features.h
@@ -48,7 +48,8 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines,
ImpliedDoIndexScope, DistinctCommonSizes, OddIndexVariableRestrictions,
IndistinguishableSpecifics, SubroutineAndFunctionSpecifics,
EmptySequenceType, NonSequenceCrayPointee, BranchIntoConstruct,
- BadBranchTarget, ConvertedArgument, HollerithPolymorphic, ListDirectedSize)
+ BadBranchTarget, ConvertedArgument, HollerithPolymorphic, ListDirectedSize,
+ NonBindCInteroperability)
// Portability and suspicious usage warnings
ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index c1d9538e557f57..8717c9d091cfda 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -115,11 +115,16 @@ class CheckHelper {
}
return msg;
}
+ bool InModuleFile() const {
+ return FindModuleFileContaining(context_.FindScope(messages_.at())) !=
+ nullptr;
+ }
template <typename... A> parser::Message *WarnIfNotInModuleFile(A &&...x) {
- if (FindModuleFileContaining(context_.FindScope(messages_.at()))) {
+ if (InModuleFile()) {
return nullptr;
+ } else {
+ return messages_.Say(std::forward<A>(x)...);
}
- return messages_.Say(std::forward<A>(x)...);
}
template <typename... A>
parser::Message *WarnIfNotInModuleFile(parser::CharBlock source, A &&...x) {
@@ -132,6 +137,8 @@ class CheckHelper {
void CheckGlobalName(const Symbol &);
void CheckProcedureAssemblyName(const Symbol &symbol);
void CheckExplicitSave(const Symbol &);
+ parser::Messages WhyNotInteroperableDerivedType(
+ const Symbol &, UnorderedSymbolSet &checked);
void CheckBindC(const Symbol &);
void CheckBindCFunctionResult(const Symbol &);
// Check functions for defined I/O procedures
@@ -2758,11 +2765,117 @@ void CheckHelper::CheckProcedureAssemblyName(const Symbol &symbol) {
}
}
+parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
+ const Symbol &symbol, UnorderedSymbolSet &checked) {
+ parser::Messages msgs;
+ if (checked.find(symbol) != checked.end()) {
+ return msgs;
+ }
+ checked.insert(symbol);
+ if (const auto *derived{symbol.detailsIf<DerivedTypeDetails>()}) {
+ if (derived->sequence()) { // C1801
+ msgs.Say(symbol.name(),
+ "An interoperable derived type cannot not have the SEQUENCE attribute"_err_en_US);
+ } else if (!derived->paramDecls().empty()) { // C1802
+ msgs.Say(symbol.name(),
+ "An interoperable derived type cannot have a type parameter"_err_en_US);
+ } else if (const auto *parent{
+ symbol.scope()->GetDerivedTypeParent()}) { // C1803
+ if (symbol.attrs().test(Attr::BIND_C)) {
+ msgs.Say(symbol.name(),
+ "A derived type with the BIND attribute cannot be an extended derived type"_err_en_US);
+ } else {
+ bool interoperableParent{true};
+ if (parent->symbol()) {
+ if (auto bad{
+ WhyNotInteroperableDerivedType(*parent->symbol(), checked)};
+ bad.AnyFatalError()) {
+ auto &msg{msgs.Say(symbol.name(),
+ "The parent of an interoperable type is not interoperable"_err_en_US)};
+ bad.AttachTo(msg, parser::Severity::None);
+ interoperableParent = false;
+ }
+ }
+ if (interoperableParent) {
+ msgs.Say(symbol.name(),
+ "An interoperable type should not be an extended derived type"_warn_en_US);
+ }
+ }
+ }
+ const Symbol *parentComponent{symbol.scope()
+ ? derived->GetParentComponent(*symbol.scope())
+ : nullptr};
+ for (const auto &pair : *symbol.scope()) {
+ const Symbol &component{*pair.second};
+ if (&component == parentComponent) {
+ continue; // was checked above
+ }
+ if (IsProcedure(component)) { // C1804
+ msgs.Say(component.name(),
+ "An interoperable derived type cannot have a type bound procedure"_err_en_US);
+ } else if (IsAllocatableOrPointer(component)) { // C1806
+ msgs.Say(component.name(),
+ "An interoperable derived type cannot have a pointer or allocatable component"_err_en_US);
+ } else if (const auto *type{component.GetType()}) {
+ if (const auto *derived{type->AsDerived()}) {
+ if (auto bad{WhyNotInteroperableDerivedType(
+ derived->typeSymbol(), checked)};
+ bad.AnyFatalError()) {
+ auto &msg{msgs.Say(component.name(),
+ "Component '%s' of an interoperable derived type must have an interoperable type but does not"_err_en_US,
+ component.name())};
+ bad.AttachTo(msg, parser::Severity::None);
+ } else if (!derived->typeSymbol().GetUltimate().attrs().test(
+ Attr::BIND_C)) {
+ msgs.Say(component.name(),
+ "Derived type of component '%s' of an interoperable derived type should have the BIND attribute"_warn_en_US,
+ component.name())
+ .Attach(derived->typeSymbol().name(),
+ "Non-BIND(C) component type"_en_US);
+ }
+ } else if (!IsInteroperableIntrinsicType(
+ *type, context_.languageFeatures())) {
+ auto maybeDyType{evaluate::DynamicType::From(*type)};
+ if (type->category() == DeclTypeSpec::Logical) {
+ if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {
+ msgs.Say(component.name(),
+ "A LOGICAL component of an interoperable type should have the interoperable KIND=C_BOOL"_port_en_US);
+ }
+ } else if (type->category() == DeclTypeSpec::Character &&
+ maybeDyType && maybeDyType->kind() == 1) {
+ if (context_.ShouldWarn(common::UsageWarning::BindCCharLength)) {
+ msgs.Say(component.name(),
+ "A CHARACTER component of an interoperable type should have length 1"_port_en_US);
+ }
+ } else {
+ msgs.Say(component.name(),
+ "Each component of an interoperable derived type must have an interoperable type"_err_en_US);
+ }
+ }
+ }
+ if (auto extents{
+ evaluate::GetConstantExtents(foldingContext_, &component)};
+ extents && evaluate::GetSize(*extents) == 0) {
+ msgs.Say(component.name(),
+ "An array component of an interoperable type must have at least one element"_err_en_US);
+ }
+ }
+ if (derived->componentNames().empty()) { // F'2023 C1805
+ if (context_.ShouldWarn(common::LanguageFeature::EmptyBindCDerivedType)) {
+ msgs.Say(symbol.name(),
+ "A derived type with the BIND attribute should not be empty"_port_en_US);
+ }
+ }
+ }
+ return msgs;
+}
+
void CheckHelper::CheckBindC(const Symbol &symbol) {
bool isExplicitBindC{symbol.attrs().test(Attr::BIND_C)};
if (isExplicitBindC) {
- CheckConflicting(symbol, Attr::BIND_C, Attr::PARAMETER);
CheckConflicting(symbol, Attr::BIND_C, Attr::ELEMENTAL);
+ CheckConflicting(symbol, Attr::BIND_C, Attr::INTRINSIC);
+ CheckConflicting(symbol, Attr::BIND_C, Attr::PARAMETER);
} else {
// symbol must be interoperable (e.g., dummy argument of interoperable
// procedure interface) but is not itself BIND(C).
@@ -2832,13 +2945,30 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
}
if (const auto *type{symbol.GetType()}) {
const auto *derived{type->AsDerived()};
- if (derived && !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);
+ if (derived) {
+ if (isExplicitBindC) {
+ 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 {
+ UnorderedSymbolSet checked;
+ if (auto bad{WhyNotInteroperableDerivedType(
+ derived->typeSymbol(), checked)};
+ !bad.empty()) {
+ if (bad.AnyFatalError()) {
+ if (auto *msg{messages_.Say(symbol.name(),
+ "The derived type of an interoperable object must be interoperable, but is not"_err_en_US)}) {
+ bad.AttachTo(*msg, parser::Severity::None);
+ }
+ context_.SetError(symbol);
+ }
+ }
}
- context_.SetError(symbol);
}
if (type->IsAssumedType() || IsAssumedLengthCharacter(symbol)) {
// ok
@@ -2881,17 +3011,20 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
"An interoperable pointer must not be CONTIGUOUS"_err_en_US);
}
} else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
- if (!proc->procInterface() ||
- !proc->procInterface()->attrs().test(Attr::BIND_C)) {
- if (proc->isDummy()) {
- messages_.Say(symbol.name(),
- "A dummy procedure to an interoperable procedure must also be interoperable"_err_en_US);
- context_.SetError(symbol);
- } else {
- 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);
+ if (!IsBindCProcedure(symbol) && proc->isDummy()) {
+ messages_.Say(symbol.name(),
+ "A dummy procedure to an interoperable procedure must also be interoperable"_err_en_US);
+ context_.SetError(symbol);
+ } else if (!proc->procInterface()) {
+ if (context_.ShouldWarn(
+ common::LanguageFeature::NonBindCInteroperability)) {
+ WarnIfNotInModuleFile(symbol.name(),
+ "An interface name with BIND attribute should be specified if the BIND attribute is specified in a procedure declaration statement"_warn_en_US);
}
+ } else if (!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 *subp{symbol.detailsIf<SubprogramDetails>()}) {
for (const Symbol *dummy : subp->dummyArgs()) {
@@ -2903,77 +3036,18 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
context_.SetError(symbol);
}
}
- } else if (const auto *derived{symbol.detailsIf<DerivedTypeDetails>()}) {
- if (derived->sequence()) { // C1801
- messages_.Say(symbol.name(),
- "A derived type with the BIND attribute cannot have the SEQUENCE attribute"_err_en_US);
- context_.SetError(symbol);
- } else if (!derived->paramDecls().empty()) { // C1802
- messages_.Say(symbol.name(),
- "A derived type with the BIND attribute has type parameter(s)"_err_en_US);
- context_.SetError(symbol);
- } else if (symbol.scope()->GetDerivedTypeParent()) { // C1803
- messages_.Say(symbol.name(),
- "A derived type with the BIND attribute cannot extend from another derived type"_err_en_US);
- context_.SetError(symbol);
- } else {
- for (const auto &pair : *symbol.scope()) {
- const Symbol *component{&*pair.second};
- if (IsProcedure(*component)) { // C1804
- messages_.Say(component->name(),
- "A derived type with the BIND attribute cannot have a type bound procedure"_err_en_US);
- context_.SetError(symbol);
- }
- if (IsAllocatableOrPointer(*component)) { // C1806
- messages_.Say(component->name(),
- "A derived type with the BIND attribute cannot have a pointer or allocatable component"_err_en_US);
- context_.SetError(symbol);
- }
- if (const auto *type{component->GetType()}) {
- if (const auto *derived{type->AsDerived()}) {
- if (!derived->typeSymbol().attrs().test(Attr::BIND_C)) {
- if (auto *msg{messages_.Say(component->name(),
- "Component '%s' of an interoperable derived type must have the BIND attribute"_err_en_US,
- component->name())}) {
- msg->Attach(derived->typeSymbol().name(),
- "Non-interoperable component type"_en_US);
- }
- context_.SetError(symbol);
- }
- } else if (!IsInteroperableIntrinsicType(
- *type, context_.languageFeatures())) {
- auto maybeDyType{evaluate::DynamicType::From(*type)};
- if (type->category() == DeclTypeSpec::Logical) {
- if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {
- WarnIfNotInModuleFile(component->name(),
- "A LOGICAL component of a BIND(C) type should have the interoperable KIND=C_BOOL"_port_en_US);
- }
- } else if (type->category() == DeclTypeSpec::Character &&
- maybeDyType && maybeDyType->kind() == 1) {
- if (context_.ShouldWarn(common::UsageWarning::BindCCharLength)) {
- WarnIfNotInModuleFile(component->name(),
- "A CHARACTER component of a BIND(C) type should have length 1"_port_en_US);
- }
- } else {
- messages_.Say(component->name(),
- "Each component of an interoperable derived type must have an interoperable type"_err_en_US);
- context_.SetError(symbol);
- }
- }
- }
- if (auto extents{
- evaluate::GetConstantExtents(foldingContext_, component)};
- extents && evaluate::GetSize(*extents) == 0) {
- messages_.Say(component->name(),
- "An array component of an interoperable type must have at least one element"_err_en_US);
- context_.SetError(symbol);
- }
+ } else if (symbol.has<DerivedTypeDetails>()) {
+ UnorderedSymbolSet checked;
+ if (auto msgs{WhyNotInteroperableDerivedType(symbol, checked)};
+ !msgs.empty()) {
+ if (msgs.AnyFatalError()) {
+ context_.SetError(symbol);
}
- }
- if (derived->componentNames().empty()) { // F'2023 C1805
- if (context_.ShouldWarn(common::LanguageFeature::EmptyBindCDerivedType)) {
- WarnIfNotInModuleFile(symbol.name(),
- "A derived type with the BIND attribute is empty"_port_en_US);
+ if (msgs.AnyFatalError() ||
+ (!InModuleFile() &&
+ context_.ShouldWarn(
+ common::LanguageFeature::NonBindCInteroperability))) {
+ context_.messages().Annex(std::move(msgs));
}
}
}
diff --git a/flang/test/Semantics/bind-c03.f90 b/flang/test/Semantics/bind-c03.f90
index 65d52e964ca46e..c37cb2bccb1f2f 100644
--- a/flang/test/Semantics/bind-c03.f90
+++ b/flang/test/Semantics/bind-c03.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! Check for C1521
! If proc-language-binding-spec (bind(c)) is specified, the proc-interface
! shall appear, it shall be an interface-name, and interface-name shall be
@@ -24,7 +24,10 @@ subroutine proc3() bind(c)
!ERROR: An interface name with BIND attribute must be specified if the BIND attribute is specified in a procedure declaration statement
procedure(proc2), bind(c) :: pc2
- !ERROR: An interface name with BIND attribute must be specified if the BIND attribute is specified in a procedure declaration statement
+ !WARNING: An interface name with BIND attribute should be specified if the BIND attribute is specified in a procedure declaration statement
procedure(integer), bind(c) :: pc3
+ !WARNING: An interface name with BIND attribute should be specified if the BIND attribute is specified in a procedure declaration statement
+ procedure(), bind(c) :: pc5
+
end
diff --git a/flang/test/Semantics/bind-c06.f90 b/flang/test/Semantics/bind-c06.f90
index 4c25722cb7752f..d37b86e2ca6d90 100644
--- a/flang/test/Semantics/bind-c06.f90
+++ b/flang/test/Semantics/bind-c06.f90
@@ -16,19 +16,19 @@ program main
integer :: i
end type
- ! ERROR: A derived type with the BIND attribute cannot have the SEQUENCE attribute
+ ! ERROR: An interoperable derived type cannot not have the SEQUENCE attribute
type, bind(c) :: t1
sequence
integer :: x
end type
- ! ERROR: A derived type with the BIND attribute has type parameter(s)
+ ! ERROR: An interoperable derived type cannot have a type parameter
type, bind(c) :: t2(k)
integer, KIND :: k
integer :: x
end type
- ! ERROR: A derived type with the BIND attribute cannot extend from another derived type
+ ! ERROR: A derived type with the BIND attribute cannot be an extended derived type
type, bind(c), extends(v) :: t3
integer :: x
end type
@@ -36,21 +36,21 @@ program main
type, bind(c) :: t4
integer :: x
contains
- ! ERROR: A derived type with the BIND attribute cannot have a type bound procedure
+ ! ERROR: An interoperable derived type cannot have a type bound procedure
procedure, nopass :: b => s
end type
- ! WARNING: A derived type with the BIND attribute is empty
+ ! WARNING: A derived type with the BIND attribute should not be empty
type, bind(c) :: t5
end type
type, bind(c) :: t6
- ! ERROR: A derived type with the BIND attribute cannot have a pointer or allocatable component
+ ! ERROR: An interoperable derived type cannot have a pointer or allocatable component
integer, pointer :: x
end type
type, bind(c) :: t7
- ! ERROR: A derived type with the BIND attribute cannot have a pointer or allocatable component
+ ! ERROR: An interoperable derived type cannot have a pointer or allocatable component
integer, allocatable :: y
end type
@@ -58,14 +58,20 @@ program main
integer :: x
end type
+ type :: t8a
+ integer, pointer :: x
+ end type
+
type, bind(c) :: t9
- !ERROR: Component 'y' of an interoperable derived type must have the BIND attribute
- type(t8) :: y
+ !WARNING: Derived type of component 'x' of an interoperable derived type should have the BIND attribute
+ type(t8) :: x
+ !ERROR: Component 'y' of an interoperable derived type must have an interoperable type but does not
+ type(t8a) :: y
integer :...
[truncated]
|
|
Thank you for adding the extension. Is this going to be warnings under no special flags? |
clementval
reviewed
May 7, 2024
clementval
approved these changes
May 7, 2024
The warnings would have to be enabled to be seen when building your modules, and warnings never appear for things that a read from module files. |
klausler
force-pushed
the
zhen
branch
2 times, most recently
from
f61b267 to
f62f387
Compare
A derived type that meets (most of) the requirements of an interoperable type but doesn't actually have the BIND(C) attribute can be accepted as an interoperable type, with optional warnings.
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
A derived type that meets (most of) the requirements of an interoperable type but doesn't actually have the BIND(C) attribute can be accepted as an interoperable type, with optional warnings.