diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h index f547138f5a116..a8a6eb922a045 100644 --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -1103,8 +1103,7 @@ extern template semantics::UnorderedSymbolSet CollectCudaSymbols( bool HasVectorSubscript(const Expr &); // Utilities for attaching the location of the declaration of a symbol -// of interest to a message, if both pointers are non-null. Handles -// the case of USE association gracefully. +// of interest to a message. Handles the case of USE association gracefully. parser::Message *AttachDeclaration(parser::Message &, const Symbol &); parser::Message *AttachDeclaration(parser::Message *, const Symbol &); template diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp index f8e873008ceab..f0fe54a0af308 100644 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -147,7 +147,8 @@ class CheckHelper { void CheckProcedureAssemblyName(const Symbol &symbol); void CheckExplicitSave(const Symbol &); parser::Messages WhyNotInteroperableDerivedType(const Symbol &); - parser::Messages WhyNotInteroperableObject(const Symbol &); + parser::Messages WhyNotInteroperableObject( + const Symbol &, bool allowNonInteroperableType = false); parser::Messages WhyNotInteroperableFunctionResult(const Symbol &); parser::Messages WhyNotInteroperableProcedure(const Symbol &, bool isError); void CheckBindC(const Symbol &); @@ -2999,7 +3000,8 @@ parser::Messages CheckHelper::WhyNotInteroperableDerivedType( return msgs; } -parser::Messages CheckHelper::WhyNotInteroperableObject(const Symbol &symbol) { +parser::Messages CheckHelper::WhyNotInteroperableObject( + const Symbol &symbol, bool allowNonInteroperableType) { parser::Messages msgs; if (examinedByWhyNotInteroperable_.find(symbol) != examinedByWhyNotInteroperable_.end()) { @@ -3035,8 +3037,13 @@ parser::Messages CheckHelper::WhyNotInteroperableObject(const Symbol &symbol) { if (const auto *type{symbol.GetType()}) { const auto *derived{type->AsDerived()}; if (derived && !derived->typeSymbol().attrs().test(Attr::BIND_C)) { - if (!context_.IsEnabled( - common::LanguageFeature::NonBindCInteroperability)) { + if (allowNonInteroperableType) { // portability warning only + evaluate::AttachDeclaration( + context_.Warn(common::UsageWarning::Portability, symbol.name(), + "The derived type of this interoperable object should be BIND(C)"_port_en_US), + derived->typeSymbol()); + } else if (!context_.IsEnabled( + common::LanguageFeature::NonBindCInteroperability)) { msgs.Say(symbol.name(), "The derived type of an interoperable object must be BIND(C)"_err_en_US) .Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US); @@ -3176,7 +3183,13 @@ parser::Messages CheckHelper::WhyNotInteroperableProcedure( "A dummy procedure of an interoperable procedure should be BIND(C)"_warn_en_US); } } else if (dummy->has()) { - dummyMsgs = WhyNotInteroperableObject(*dummy); + // Emit only optional portability warnings for non-interoperable + // types when the dummy argument is not VALUE and will be implemented + // on the C side by either a cdesc_t * or a void *. F'2023 18.3.7 (5) + bool allowNonInteroperableType{!dummy->attrs().test(Attr::VALUE) && + (IsDescriptor(*dummy) || IsAssumedType(*dummy))}; + dummyMsgs = + WhyNotInteroperableObject(*dummy, allowNonInteroperableType); } else { CheckBindC(*dummy); } diff --git a/flang/test/Semantics/bind-c17.f90 b/flang/test/Semantics/bind-c17.f90 new file mode 100644 index 0000000000000..8e0ecde67a0a5 --- /dev/null +++ b/flang/test/Semantics/bind-c17.f90 @@ -0,0 +1,10 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic -Werror +module m + type a ! not BIND(C) + end type + contains + subroutine sub(x) bind(c) + !PORTABILITY: The derived type of this interoperable object should be BIND(C) + type(a), pointer, intent(in) :: x + end +end