[flang] Relax checking of dummy procedures under BIND(C) (#92474)
As was done recently to allow derived types that are not explicitly BIND(C), but meet the requirements of BIND(C), to be acceptable for use in contexts nominally requiring BIND(C), this patch allows procedures that are not explicitly BIND(C) to be used in contexts that nominally require BIND(C) so long as (1) they meet the requirements of BIND(C), and (2) don't use dummy arguments whose implementations may vary under BIND(C), such as VALUE.
This commit is contained in:
Peter Klausler
GitHub
parent
fe2ff54590
commit
ab7930bd9f
@ -213,8 +213,7 @@ inline bool IsCUDADeviceContext(const Scope *scope) {
|
||||
}
|
||||
|
||||
inline bool HasCUDAAttr(const Symbol &sym) {
|
||||
if (const auto *details{
|
||||
sym.GetUltimate().detailsIf<semantics::ObjectEntityDetails>()}) {
|
||||
if (const auto *details{sym.GetUltimate().detailsIf<ObjectEntityDetails>()}) {
|
||||
if (details->cudaDataAttr()) {
|
||||
return true;
|
||||
}
|
||||
@ -224,17 +223,18 @@ inline bool HasCUDAAttr(const Symbol &sym) {
|
||||
|
||||
inline bool NeedCUDAAlloc(const Symbol &sym) {
|
||||
bool inDeviceSubprogram{IsCUDADeviceContext(&sym.owner())};
|
||||
if (Fortran::semantics::IsDummy(sym))
|
||||
if (IsDummy(sym)) {
|
||||
return false;
|
||||
if (const auto *details{
|
||||
sym.GetUltimate().detailsIf<semantics::ObjectEntityDetails>()}) {
|
||||
}
|
||||
if (const auto *details{sym.GetUltimate().detailsIf<ObjectEntityDetails>()}) {
|
||||
if (details->cudaDataAttr() &&
|
||||
(*details->cudaDataAttr() == common::CUDADataAttr::Device ||
|
||||
*details->cudaDataAttr() == common::CUDADataAttr::Managed ||
|
||||
*details->cudaDataAttr() == common::CUDADataAttr::Unified)) {
|
||||
// Descriptor is allocated on host when in host context.
|
||||
if (Fortran::semantics::IsAllocatable(sym))
|
||||
if (IsAllocatable(sym)) {
|
||||
return inDeviceSubprogram;
|
||||
}
|
||||
return true;
|
||||
}
|
||||
}
|
||||
@ -246,7 +246,7 @@ std::optional<common::CUDADataAttr> GetCUDADataAttr(const Symbol *);
|
||||
|
||||
// Return an error if a symbol is not accessible from a scope
|
||||
std::optional<parser::MessageFormattedText> CheckAccessibleSymbol(
|
||||
const semantics::Scope &, const Symbol &);
|
||||
const Scope &, const Symbol &);
|
||||
|
||||
// Analysis of image control statements
|
||||
bool IsImageControlStmt(const parser::ExecutableConstruct &);
|
||||
@ -706,14 +706,13 @@ inline const parser::Name *getDesignatorNameIfDataRef(
|
||||
bool CouldBeDataPointerValuedFunction(const Symbol *);
|
||||
|
||||
template <typename R, typename T>
|
||||
std::optional<R> GetConstExpr(
|
||||
Fortran::semantics::SemanticsContext &semanticsContext, const T &x) {
|
||||
using DefaultCharConstantType = Fortran::evaluate::Ascii;
|
||||
if (const auto *expr{Fortran::semantics::GetExpr(semanticsContext, x)}) {
|
||||
const auto foldExpr{Fortran::evaluate::Fold(
|
||||
semanticsContext.foldingContext(), Fortran::common::Clone(*expr))};
|
||||
std::optional<R> GetConstExpr(SemanticsContext &semanticsContext, const T &x) {
|
||||
using DefaultCharConstantType = evaluate::Ascii;
|
||||
if (const auto *expr{GetExpr(semanticsContext, x)}) {
|
||||
const auto foldExpr{evaluate::Fold(
|
||||
semanticsContext.foldingContext(), common::Clone(*expr))};
|
||||
if constexpr (std::is_same_v<R, std::string>) {
|
||||
return Fortran::evaluate::GetScalarConstantValue<DefaultCharConstantType>(
|
||||
return evaluate::GetScalarConstantValue<DefaultCharConstantType>(
|
||||
foldExpr);
|
||||
}
|
||||
}
|
||||
|
||||
@ -139,8 +139,10 @@ private:
|
||||
void CheckProcedureAssemblyName(const Symbol &symbol);
|
||||
void CheckExplicitSave(const Symbol &);
|
||||
parser::Messages WhyNotInteroperableDerivedType(const Symbol &, bool isError);
|
||||
parser::Messages WhyNotInteroperableObject(const Symbol &, bool isError);
|
||||
parser::Messages WhyNotInteroperableFunctionResult(const Symbol &);
|
||||
parser::Messages WhyNotInteroperableProcedure(const Symbol &, bool isError);
|
||||
void CheckBindC(const Symbol &);
|
||||
void CheckBindCFunctionResult(const Symbol &);
|
||||
// Check functions for defined I/O procedures
|
||||
void CheckDefinedIoProc(
|
||||
const Symbol &, const GenericDetails &, common::DefinedIo);
|
||||
@ -189,8 +191,8 @@ private:
|
||||
// Collection of target dependent assembly names of external and BIND(C)
|
||||
// procedures.
|
||||
std::map<std::string, SymbolRef> procedureAssemblyNames_;
|
||||
// Derived types that have been examined by WhyNotInteroperableDerivedType
|
||||
UnorderedSymbolSet examinedByWhyNotInteroperableDerivedType_;
|
||||
// Derived types that have been examined by WhyNotInteroperable_XXX
|
||||
UnorderedSymbolSet examinedByWhyNotInteroperable_;
|
||||
};
|
||||
|
||||
class DistinguishabilityHelper {
|
||||
@ -438,7 +440,6 @@ void CheckHelper::Check(const Symbol &symbol) {
|
||||
messages_.Say(
|
||||
"A function result may not also be a named constant"_err_en_US);
|
||||
}
|
||||
CheckBindCFunctionResult(symbol);
|
||||
}
|
||||
if (IsAutomatic(symbol)) {
|
||||
if (const Symbol * common{FindCommonBlockContaining(symbol)}) {
|
||||
@ -510,35 +511,6 @@ void CheckHelper::CheckExplicitSave(const Symbol &symbol) {
|
||||
}
|
||||
}
|
||||
|
||||
void CheckHelper::CheckBindCFunctionResult(const Symbol &symbol) { // C1553
|
||||
if (!innermostSymbol_ || !IsBindCProcedure(*innermostSymbol_)) {
|
||||
return;
|
||||
}
|
||||
if (IsPointer(symbol) || IsAllocatable(symbol)) {
|
||||
messages_.Say(
|
||||
"BIND(C) function result cannot have ALLOCATABLE or POINTER attribute"_err_en_US);
|
||||
}
|
||||
if (const DeclTypeSpec * type{symbol.GetType()};
|
||||
type && type->category() == DeclTypeSpec::Character) {
|
||||
bool isConstOne{false}; // 18.3.1(1)
|
||||
if (const auto &len{type->characterTypeSpec().length().GetExplicit()}) {
|
||||
if (auto constLen{evaluate::ToInt64(*len)}) {
|
||||
isConstOne = constLen == 1;
|
||||
}
|
||||
}
|
||||
if (!isConstOne) {
|
||||
messages_.Say(
|
||||
"BIND(C) character function result must have length one"_err_en_US);
|
||||
}
|
||||
}
|
||||
if (symbol.Rank() > 0) {
|
||||
messages_.Say("BIND(C) function result must be scalar"_err_en_US);
|
||||
}
|
||||
if (symbol.Corank()) {
|
||||
messages_.Say("BIND(C) function result cannot be a coarray"_err_en_US);
|
||||
}
|
||||
}
|
||||
|
||||
void CheckHelper::CheckValue(
|
||||
const Symbol &symbol, const DerivedTypeSpec *derived) { // C863 - C865
|
||||
if (IsProcedure(symbol)) {
|
||||
@ -2870,12 +2842,12 @@ void CheckHelper::CheckProcedureAssemblyName(const Symbol &symbol) {
|
||||
parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
|
||||
const Symbol &symbol, bool isError) {
|
||||
parser::Messages msgs;
|
||||
if (examinedByWhyNotInteroperableDerivedType_.find(symbol) !=
|
||||
examinedByWhyNotInteroperableDerivedType_.end()) {
|
||||
if (examinedByWhyNotInteroperable_.find(symbol) !=
|
||||
examinedByWhyNotInteroperable_.end()) {
|
||||
return msgs;
|
||||
}
|
||||
isError |= symbol.attrs().test(Attr::BIND_C);
|
||||
examinedByWhyNotInteroperableDerivedType_.insert(symbol);
|
||||
examinedByWhyNotInteroperable_.insert(symbol);
|
||||
if (const auto *derived{symbol.detailsIf<DerivedTypeDetails>()}) {
|
||||
if (derived->sequence()) { // C1801
|
||||
msgs.Say(symbol.name(),
|
||||
@ -2971,7 +2943,7 @@ parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
|
||||
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);
|
||||
"A derived type with the BIND attribute should not be empty"_warn_en_US);
|
||||
}
|
||||
}
|
||||
}
|
||||
@ -2983,7 +2955,245 @@ parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
|
||||
}
|
||||
}
|
||||
if (msgs.AnyFatalError()) {
|
||||
examinedByWhyNotInteroperableDerivedType_.erase(symbol);
|
||||
examinedByWhyNotInteroperable_.erase(symbol);
|
||||
}
|
||||
return msgs;
|
||||
}
|
||||
|
||||
static UnorderedSymbolSet CollectEntryPointsWithDummy(const Symbol &dummy) {
|
||||
UnorderedSymbolSet entries;
|
||||
const Scope &subpScope{dummy.owner()};
|
||||
for (const auto &[_, ref] : subpScope.parent()) {
|
||||
const Symbol &x{*ref};
|
||||
if (const auto *subp{x.detailsIf<SubprogramDetails>()}) {
|
||||
if (x.scope() == &subpScope || subp->entryScope() == &dummy.owner()) {
|
||||
if (std::find(subp->dummyArgs().begin(), subp->dummyArgs().end(),
|
||||
&dummy) != subp->dummyArgs().end()) {
|
||||
entries.insert(x);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return entries;
|
||||
}
|
||||
|
||||
static bool AnyNonBindCEntry(const Symbol &dummy) {
|
||||
for (const Symbol &subp : CollectEntryPointsWithDummy(dummy)) {
|
||||
if (!subp.attrs().test(Attr::BIND_C)) {
|
||||
return true;
|
||||
}
|
||||
}
|
||||
return false;
|
||||
}
|
||||
|
||||
parser::Messages CheckHelper::WhyNotInteroperableObject(
|
||||
const Symbol &symbol, bool isError) {
|
||||
parser::Messages msgs;
|
||||
if (examinedByWhyNotInteroperable_.find(symbol) !=
|
||||
examinedByWhyNotInteroperable_.end()) {
|
||||
return msgs;
|
||||
}
|
||||
bool isExplicitBindC{symbol.attrs().test(Attr::BIND_C)};
|
||||
isError |= isExplicitBindC;
|
||||
examinedByWhyNotInteroperable_.insert(symbol);
|
||||
CHECK(symbol.has<ObjectEntityDetails>());
|
||||
if (isExplicitBindC && !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);
|
||||
}
|
||||
auto shape{evaluate::GetShape(foldingContext_, symbol)};
|
||||
if (shape) {
|
||||
if (evaluate::GetRank(*shape) == 0) { // 18.3.4
|
||||
if (IsAllocatableOrPointer(symbol) && !IsDummy(symbol)) {
|
||||
messages_.Say(symbol.name(),
|
||||
"A scalar interoperable variable may not be ALLOCATABLE or POINTER"_err_en_US);
|
||||
}
|
||||
} else if (auto extents{
|
||||
evaluate::AsConstantExtents(foldingContext_, *shape)}) {
|
||||
if (evaluate::GetSize(*extents) == 0) {
|
||||
msgs.Say(symbol.name(),
|
||||
"Interoperable array must have at least one element"_err_en_US);
|
||||
}
|
||||
} else if (!evaluate::IsExplicitShape(symbol) &&
|
||||
!IsAssumedSizeArray(symbol) &&
|
||||
!(IsDummy(symbol) && !symbol.attrs().test(Attr::VALUE))) {
|
||||
msgs.Say(symbol.name(),
|
||||
"BIND(C) array must have explicit shape or be assumed-size unless a dummy argument without the VALUE attribute"_err_en_US);
|
||||
}
|
||||
}
|
||||
if (const auto *type{symbol.GetType()}) {
|
||||
const auto *derived{type->AsDerived()};
|
||||
if (derived) {
|
||||
if (derived->typeSymbol().attrs().test(Attr::BIND_C)) {
|
||||
} else if (isError) {
|
||||
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-BIND(C) type"_en_US);
|
||||
}
|
||||
context_.SetError(symbol);
|
||||
} else if (auto bad{WhyNotInteroperableDerivedType(
|
||||
derived->typeSymbol(), /*isError=*/false)};
|
||||
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)}) {
|
||||
msg->Attach(
|
||||
derived->typeSymbol().name(), "Non-interoperable type"_en_US);
|
||||
bad.AttachTo(*msg, parser::Severity::None);
|
||||
}
|
||||
} else {
|
||||
if (auto *msg{messages_.Say(symbol.name(),
|
||||
"The derived type of an interoperable object should be BIND(C)"_warn_en_US)}) {
|
||||
msg->Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);
|
||||
}
|
||||
}
|
||||
}
|
||||
if (type->IsAssumedType()) { // ok
|
||||
} else if (IsAssumedLengthCharacter(symbol)) {
|
||||
if (AnyNonBindCEntry(symbol)) {
|
||||
msgs.Say(symbol.name(),
|
||||
"An assumed-length dummy argument must not appear in a non-BIND(C) entry in a subprogram with an entry that must be interoperable"_err_en_US);
|
||||
}
|
||||
} else if (IsAllocatableOrPointer(symbol) &&
|
||||
type->category() == DeclTypeSpec::Character &&
|
||||
type->characterTypeSpec().length().isDeferred()) {
|
||||
// ok; F'2023 18.3.7 p2(6)
|
||||
} else if (derived ||
|
||||
IsInteroperableIntrinsicType(*type, context_.languageFeatures())) {
|
||||
// F'2023 18.3.7 p2(4,5)
|
||||
} else if (type->category() == DeclTypeSpec::Logical) {
|
||||
if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool) &&
|
||||
!InModuleFile()) {
|
||||
if (IsDummy(symbol)) {
|
||||
msgs.Say(symbol.name(),
|
||||
"A BIND(C) LOGICAL dummy argument should have the interoperable KIND=C_BOOL"_port_en_US);
|
||||
} else {
|
||||
msgs.Say(symbol.name(),
|
||||
"A BIND(C) LOGICAL object should have the interoperable KIND=C_BOOL"_port_en_US);
|
||||
}
|
||||
}
|
||||
} else if (symbol.attrs().test(Attr::VALUE)) {
|
||||
msgs.Say(symbol.name(),
|
||||
"A BIND(C) VALUE dummy argument must have an interoperable type"_err_en_US);
|
||||
} else {
|
||||
msgs.Say(symbol.name(),
|
||||
"A BIND(C) object must have an interoperable type"_err_en_US);
|
||||
}
|
||||
}
|
||||
if (IsOptional(symbol) && !symbol.attrs().test(Attr::VALUE)) {
|
||||
msgs.Say(symbol.name(),
|
||||
"An interoperable procedure with an OPTIONAL dummy argument might not be portable"_port_en_US);
|
||||
}
|
||||
if (symbol.attrs().test(Attr::VALUE)) {
|
||||
if (AnyNonBindCEntry(symbol)) {
|
||||
msgs.Say(symbol.name(),
|
||||
"A VALUE dummy argument must not appear in a non-BIND(C) entry of a subprogram with an entry that must be interoperable"_err_en_US);
|
||||
}
|
||||
}
|
||||
if (IsDescriptor(symbol) && IsPointer(symbol) &&
|
||||
symbol.attrs().test(Attr::CONTIGUOUS)) {
|
||||
msgs.Say(symbol.name(),
|
||||
"An interoperable pointer must not be CONTIGUOUS"_err_en_US);
|
||||
}
|
||||
if (msgs.AnyFatalError()) {
|
||||
examinedByWhyNotInteroperable_.erase(symbol);
|
||||
}
|
||||
return msgs;
|
||||
}
|
||||
|
||||
parser::Messages CheckHelper::WhyNotInteroperableFunctionResult(
|
||||
const Symbol &symbol) {
|
||||
parser::Messages msgs;
|
||||
if (IsPointer(symbol) || IsAllocatable(symbol)) {
|
||||
msgs.Say(symbol.name(),
|
||||
"Interoperable function result may not have ALLOCATABLE or POINTER attribute"_err_en_US);
|
||||
}
|
||||
if (const DeclTypeSpec * type{symbol.GetType()};
|
||||
type && type->category() == DeclTypeSpec::Character) {
|
||||
bool isConstOne{false}; // 18.3.1(1)
|
||||
if (const auto &len{type->characterTypeSpec().length().GetExplicit()}) {
|
||||
if (auto constLen{evaluate::ToInt64(*len)}) {
|
||||
isConstOne = constLen == 1;
|
||||
}
|
||||
}
|
||||
if (!isConstOne) {
|
||||
msgs.Say(symbol.name(),
|
||||
"Interoperable character function result must have length one"_err_en_US);
|
||||
}
|
||||
}
|
||||
if (symbol.Rank() > 0) {
|
||||
msgs.Say(symbol.name(),
|
||||
"Interoperable function result must be scalar"_err_en_US);
|
||||
}
|
||||
if (symbol.Corank()) {
|
||||
msgs.Say(symbol.name(),
|
||||
"Interoperable function result may not be a coarray"_err_en_US);
|
||||
}
|
||||
return msgs;
|
||||
}
|
||||
|
||||
parser::Messages CheckHelper::WhyNotInteroperableProcedure(
|
||||
const Symbol &symbol, bool isError) {
|
||||
parser::Messages msgs;
|
||||
if (examinedByWhyNotInteroperable_.find(symbol) !=
|
||||
examinedByWhyNotInteroperable_.end()) {
|
||||
return msgs;
|
||||
}
|
||||
isError |= symbol.attrs().test(Attr::BIND_C);
|
||||
examinedByWhyNotInteroperable_.insert(symbol);
|
||||
if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
|
||||
if (isError) {
|
||||
if (!proc->procInterface() ||
|
||||
!proc->procInterface()->attrs().test(Attr::BIND_C)) {
|
||||
msgs.Say(symbol.name(),
|
||||
"An interface name with the BIND attribute must appear if the BIND attribute appears in a procedure declaration"_err_en_US);
|
||||
}
|
||||
} else if (!proc->procInterface()) {
|
||||
msgs.Say(symbol.name(),
|
||||
"An interoperable procedure should have an interface"_port_en_US);
|
||||
} else if (!proc->procInterface()->attrs().test(Attr::BIND_C)) {
|
||||
auto bad{WhyNotInteroperableProcedure(
|
||||
*proc->procInterface(), /*isError=*/false)};
|
||||
if (bad.AnyFatalError()) {
|
||||
bad.AttachTo(msgs.Say(symbol.name(),
|
||||
"An interoperable procedure must have an interoperable interface"_err_en_US));
|
||||
} else {
|
||||
msgs.Say(symbol.name(),
|
||||
"An interoperable procedure should have an interface with the BIND attribute"_warn_en_US);
|
||||
}
|
||||
}
|
||||
} else if (const auto *subp{symbol.detailsIf<SubprogramDetails>()}) {
|
||||
for (const Symbol *dummy : subp->dummyArgs()) {
|
||||
if (dummy) {
|
||||
parser::Messages dummyMsgs;
|
||||
if (dummy->has<ProcEntityDetails>() ||
|
||||
dummy->has<SubprogramDetails>()) {
|
||||
dummyMsgs = WhyNotInteroperableProcedure(*dummy, /*isError=*/false);
|
||||
if (dummyMsgs.empty() && !dummy->attrs().test(Attr::BIND_C)) {
|
||||
dummyMsgs.Say(dummy->name(),
|
||||
"A dummy procedure of an interoperable procedure should be BIND(C)"_warn_en_US);
|
||||
}
|
||||
} else if (dummy->has<ObjectEntityDetails>()) {
|
||||
dummyMsgs = WhyNotInteroperableObject(*dummy, /*isError=*/false);
|
||||
} else {
|
||||
CheckBindC(*dummy);
|
||||
}
|
||||
msgs.Annex(std::move(dummyMsgs));
|
||||
} else {
|
||||
msgs.Say(symbol.name(),
|
||||
"A subprogram interface with the BIND attribute may not have an alternate return argument"_err_en_US);
|
||||
}
|
||||
}
|
||||
if (subp->isFunction()) {
|
||||
if (subp->result().has<ObjectEntityDetails>()) {
|
||||
msgs.Annex(WhyNotInteroperableFunctionResult(subp->result()));
|
||||
} else {
|
||||
msgs.Say(subp->result().name(),
|
||||
"The result of an interoperable function must be a data object"_err_en_US);
|
||||
}
|
||||
}
|
||||
}
|
||||
if (msgs.AnyFatalError()) {
|
||||
examinedByWhyNotInteroperable_.erase(symbol);
|
||||
}
|
||||
return msgs;
|
||||
}
|
||||
@ -2998,6 +3208,7 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
|
||||
// symbol must be interoperable (e.g., dummy argument of interoperable
|
||||
// procedure interface) but is not itself BIND(C).
|
||||
}
|
||||
parser::Messages whyNot;
|
||||
if (const std::string * bindName{symbol.GetBindName()};
|
||||
bindName) { // has a binding name
|
||||
if (!bindName->empty()) {
|
||||
@ -3032,143 +3243,24 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
|
||||
}
|
||||
}
|
||||
if (symbol.has<ObjectEntityDetails>()) {
|
||||
if (isExplicitBindC && !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);
|
||||
}
|
||||
auto shape{evaluate::GetShape(foldingContext_, symbol)};
|
||||
if (shape) {
|
||||
if (evaluate::GetRank(*shape) == 0) { // 18.3.4
|
||||
if (isExplicitBindC && IsAllocatableOrPointer(symbol)) {
|
||||
messages_.Say(symbol.name(),
|
||||
"A scalar interoperable variable may not be ALLOCATABLE or POINTER"_err_en_US);
|
||||
context_.SetError(symbol);
|
||||
}
|
||||
} else { // 18.3.5
|
||||
if (auto extents{
|
||||
evaluate::AsConstantExtents(foldingContext_, *shape)}) {
|
||||
if (evaluate::GetSize(*extents) == 0) {
|
||||
SayWithDeclaration(symbol, symbol.name(),
|
||||
"Interoperable array must have at least one element"_err_en_US);
|
||||
context_.SetError(symbol);
|
||||
}
|
||||
} else if ((isExplicitBindC || symbol.attrs().test(Attr::VALUE)) &&
|
||||
!evaluate::IsExplicitShape(symbol) && !IsAssumedSizeArray(symbol)) {
|
||||
SayWithDeclaration(symbol, symbol.name(),
|
||||
"BIND(C) array must have explicit shape or be assumed-size unless a dummy argument without the VALUE attribute"_err_en_US);
|
||||
context_.SetError(symbol);
|
||||
}
|
||||
}
|
||||
}
|
||||
if (const auto *type{symbol.GetType()}) {
|
||||
const auto *derived{type->AsDerived()};
|
||||
if (derived) {
|
||||
if (derived->typeSymbol().attrs().test(Attr::BIND_C)) {
|
||||
} else if (isExplicitBindC) {
|
||||
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-BIND(C) type"_en_US);
|
||||
}
|
||||
context_.SetError(symbol);
|
||||
} else if (auto bad{WhyNotInteroperableDerivedType(
|
||||
derived->typeSymbol(), /*isError=*/false)};
|
||||
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)}) {
|
||||
msg->Attach(
|
||||
derived->typeSymbol().name(), "Non-interoperable type"_en_US);
|
||||
bad.AttachTo(*msg, parser::Severity::None);
|
||||
}
|
||||
context_.SetError(symbol);
|
||||
} else if (context_.ShouldWarn(
|
||||
common::LanguageFeature::NonBindCInteroperability) &&
|
||||
!InModuleFile()) {
|
||||
if (auto *msg{messages_.Say(symbol.name(),
|
||||
"The derived type of an interoperable object should be BIND(C)"_warn_en_US)}) {
|
||||
msg->Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);
|
||||
}
|
||||
}
|
||||
}
|
||||
if (type->IsAssumedType() || IsAssumedLengthCharacter(symbol)) {
|
||||
// ok
|
||||
} else if (IsAllocatableOrPointer(symbol) &&
|
||||
type->category() == DeclTypeSpec::Character &&
|
||||
type->characterTypeSpec().length().isDeferred()) {
|
||||
// ok; F'2023 18.3.7 p2(6)
|
||||
} else if (derived ||
|
||||
IsInteroperableIntrinsicType(*type, context_.languageFeatures())) {
|
||||
// F'2023 18.3.7 p2(4,5)
|
||||
} else if (type->category() == DeclTypeSpec::Logical) {
|
||||
if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {
|
||||
if (IsDummy(symbol)) {
|
||||
WarnIfNotInModuleFile(symbol.name(),
|
||||
"A BIND(C) LOGICAL dummy argument should have the interoperable KIND=C_BOOL"_port_en_US);
|
||||
} else {
|
||||
WarnIfNotInModuleFile(symbol.name(),
|
||||
"A BIND(C) LOGICAL object should have the interoperable KIND=C_BOOL"_port_en_US);
|
||||
}
|
||||
}
|
||||
} else if (symbol.attrs().test(Attr::VALUE)) {
|
||||
messages_.Say(symbol.name(),
|
||||
"A BIND(C) VALUE dummy argument must have an interoperable type"_err_en_US);
|
||||
context_.SetError(symbol);
|
||||
} else {
|
||||
messages_.Say(symbol.name(),
|
||||
"A BIND(C) object must have an interoperable type"_err_en_US);
|
||||
context_.SetError(symbol);
|
||||
}
|
||||
}
|
||||
if (IsOptional(symbol) && !symbol.attrs().test(Attr::VALUE)) {
|
||||
if (context_.ShouldWarn(common::UsageWarning::Portability)) {
|
||||
WarnIfNotInModuleFile(symbol.name(),
|
||||
"An interoperable procedure with an OPTIONAL dummy argument might not be portable"_port_en_US);
|
||||
}
|
||||
}
|
||||
if (IsDescriptor(symbol) && IsPointer(symbol) &&
|
||||
symbol.attrs().test(Attr::CONTIGUOUS)) {
|
||||
messages_.Say(symbol.name(),
|
||||
"An interoperable pointer must not be CONTIGUOUS"_err_en_US);
|
||||
}
|
||||
} else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
|
||||
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()) {
|
||||
if (dummy) {
|
||||
CheckBindC(*dummy);
|
||||
} else {
|
||||
messages_.Say(symbol.name(),
|
||||
"A subprogram interface with the BIND attribute may not have an alternate return argument"_err_en_US);
|
||||
context_.SetError(symbol);
|
||||
}
|
||||
}
|
||||
whyNot = WhyNotInteroperableObject(symbol, /*isError=*/isExplicitBindC);
|
||||
} else if (symbol.has<ProcEntityDetails>() ||
|
||||
symbol.has<SubprogramDetails>()) {
|
||||
whyNot = WhyNotInteroperableProcedure(symbol, /*isError=*/isExplicitBindC);
|
||||
} else if (symbol.has<DerivedTypeDetails>()) {
|
||||
if (auto msgs{WhyNotInteroperableDerivedType(symbol, /*isError=*/false)};
|
||||
!msgs.empty()) {
|
||||
bool anyFatal{msgs.AnyFatalError()};
|
||||
if (msgs.AnyFatalError() ||
|
||||
(!InModuleFile() &&
|
||||
context_.ShouldWarn(
|
||||
common::LanguageFeature::NonBindCInteroperability))) {
|
||||
context_.messages().Annex(std::move(msgs));
|
||||
}
|
||||
if (anyFatal) {
|
||||
context_.SetError(symbol);
|
||||
}
|
||||
whyNot =
|
||||
WhyNotInteroperableDerivedType(symbol, /*isError=*/isExplicitBindC);
|
||||
}
|
||||
if (!whyNot.empty()) {
|
||||
bool anyFatal{whyNot.AnyFatalError()};
|
||||
if (anyFatal ||
|
||||
(!InModuleFile() &&
|
||||
context_.ShouldWarn(
|
||||
common::LanguageFeature::NonBindCInteroperability))) {
|
||||
context_.messages().Annex(std::move(whyNot));
|
||||
}
|
||||
if (anyFatal) {
|
||||
context_.SetError(symbol);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
@ -21,13 +21,13 @@ module m
|
||||
procedure(proc1), bind(c) :: pc1 ! no error
|
||||
procedure(proc3), bind(c) :: pc4 ! no error
|
||||
|
||||
!ERROR: An interface name with BIND attribute must be specified if the BIND attribute is specified in a procedure declaration statement
|
||||
!ERROR: An interface name with the BIND attribute must appear if the BIND attribute appears in a procedure declaration
|
||||
procedure(proc2), bind(c) :: pc2
|
||||
|
||||
!WARNING: An interface name with BIND attribute should be specified if the BIND attribute is specified in a procedure declaration statement
|
||||
!ERROR: An interface name with the BIND attribute must appear if the BIND attribute appears in a procedure declaration
|
||||
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
|
||||
!ERROR: An interface name with the BIND attribute must appear if the BIND attribute appears in a procedure declaration
|
||||
procedure(), bind(c) :: pc5
|
||||
|
||||
end
|
||||
|
||||
@ -2,33 +2,33 @@
|
||||
! Check for C1553 and 18.3.4(1)
|
||||
|
||||
function func1() result(res) bind(c)
|
||||
! ERROR: BIND(C) function result cannot have ALLOCATABLE or POINTER attribute
|
||||
! ERROR: Interoperable function result may not have ALLOCATABLE or POINTER attribute
|
||||
integer, pointer :: res
|
||||
end
|
||||
|
||||
function func2() result(res) bind(c)
|
||||
! ERROR: BIND(C) function result cannot have ALLOCATABLE or POINTER attribute
|
||||
! ERROR: Interoperable function result may not have ALLOCATABLE or POINTER attribute
|
||||
integer, allocatable :: res
|
||||
end
|
||||
|
||||
function func3() result(res) bind(c)
|
||||
! ERROR: BIND(C) function result must be scalar
|
||||
!ERROR: Interoperable function result must be scalar
|
||||
integer :: res(2)
|
||||
end
|
||||
|
||||
function func4() result(res) bind(c)
|
||||
! ERROR: BIND(C) character function result must have length one
|
||||
! ERROR: Interoperable character function result must have length one
|
||||
character(*) :: res
|
||||
end
|
||||
|
||||
function func5(n) result(res) bind(c)
|
||||
integer :: n
|
||||
! ERROR: BIND(C) character function result must have length one
|
||||
! ERROR: Interoperable character function result must have length one
|
||||
character(n) :: res
|
||||
end
|
||||
|
||||
function func6() result(res) bind(c)
|
||||
! ERROR: BIND(C) character function result must have length one
|
||||
! ERROR: Interoperable character function result must have length one
|
||||
character(2) :: res
|
||||
end
|
||||
|
||||
@ -38,12 +38,12 @@ function func7() result(res) bind(c)
|
||||
end
|
||||
|
||||
function func8() result(res) bind(c)
|
||||
! ERROR: BIND(C) function result cannot have ALLOCATABLE or POINTER attribute
|
||||
! ERROR: BIND(C) character function result must have length one
|
||||
! ERROR: Interoperable function result may not have ALLOCATABLE or POINTER attribute
|
||||
! ERROR: Interoperable character function result must have length one
|
||||
character(:), pointer :: res
|
||||
end
|
||||
|
||||
function func9() result(res) bind(c)
|
||||
! ERROR: BIND(C) function result cannot be a coarray
|
||||
! ERROR: Interoperable function result may not be a coarray
|
||||
integer :: res[10, *]
|
||||
end
|
||||
|
||||
@ -1,5 +1,70 @@
|
||||
! RUN: %python %S/test_errors.py %s %flang_fc1
|
||||
!ERROR: A dummy procedure to an interoperable procedure must also be interoperable
|
||||
subroutine subr(e) bind(c)
|
||||
!RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic -Werror
|
||||
|
||||
!PORTABILITY: An interoperable procedure should have an interface
|
||||
subroutine subr1(e) bind(c)
|
||||
external e
|
||||
end
|
||||
|
||||
subroutine subr2(p) bind(c)
|
||||
!PORTABILITY: An interoperable procedure should have an interface
|
||||
procedure() :: p
|
||||
end
|
||||
|
||||
subroutine subr3(p) bind(c)
|
||||
!PORTABILITY: An interoperable procedure should have an interface
|
||||
procedure(real) :: p
|
||||
end
|
||||
|
||||
subroutine subr4(p) bind(c)
|
||||
interface
|
||||
!PORTABILITY: A dummy procedure of an interoperable procedure should be BIND(C)
|
||||
subroutine p(n)
|
||||
integer, intent(in) :: n
|
||||
end
|
||||
end interface
|
||||
end
|
||||
|
||||
subroutine subr5(p) bind(c)
|
||||
interface
|
||||
subroutine p(c)
|
||||
!ERROR: An assumed-length dummy argument must not appear in a non-BIND(C) entry in a subprogram with an entry that must be interoperable
|
||||
character(*), intent(in) :: c
|
||||
end
|
||||
end interface
|
||||
end
|
||||
|
||||
subroutine subr6(p) bind(c)
|
||||
interface
|
||||
function p()
|
||||
!ERROR: Interoperable function result must be scalar
|
||||
real p(1)
|
||||
end
|
||||
end interface
|
||||
end
|
||||
|
||||
subroutine subr7(p) bind(c)
|
||||
interface
|
||||
!ERROR: Interoperable character function result must have length one
|
||||
character(*) function p()
|
||||
end
|
||||
end interface
|
||||
end
|
||||
|
||||
subroutine subr8(p) bind(c)
|
||||
interface
|
||||
subroutine p(n)
|
||||
!ERROR: A VALUE dummy argument must not appear in a non-BIND(C) entry of a subprogram with an entry that must be interoperable
|
||||
integer, intent(in), value :: n
|
||||
end
|
||||
end interface
|
||||
end
|
||||
|
||||
subroutine subr9(p) bind(c)
|
||||
!ERROR: An interface name with the BIND attribute must appear if the BIND attribute appears in a procedure declaration
|
||||
procedure(q), bind(c), pointer :: p
|
||||
interface
|
||||
function q()
|
||||
real q(1)
|
||||
end
|
||||
end interface
|
||||
end
|
||||
|
||||
@ -29,6 +29,7 @@ module m
|
||||
real, external, external :: externFunc
|
||||
!WARNING: Attribute 'INTRINSIC' cannot be used more than once
|
||||
!ERROR: 'cos' may not have both the BIND(C) and INTRINSIC attributes
|
||||
!ERROR: An interface name with the BIND attribute must appear if the BIND attribute appears in a procedure declaration
|
||||
real, intrinsic, bind(c), intrinsic :: cos
|
||||
!WARNING: Attribute 'BIND(C)' cannot be used more than once
|
||||
integer, bind(c), volatile, bind(c) :: bindVar
|
||||
|
||||
@ -19,7 +19,7 @@ module m
|
||||
!WARNING: Attribute 'PRIVATE' cannot be used more than once
|
||||
procedure(procFunc), private, pointer, private :: proc2
|
||||
!WARNING: Attribute 'BIND(C)' cannot be used more than once
|
||||
!ERROR: An interface name with BIND attribute must be specified if the BIND attribute is specified in a procedure declaration statement
|
||||
!ERROR: An interface name with the BIND attribute must appear if the BIND attribute appears in a procedure declaration
|
||||
procedure(procFunc), bind(c), pointer, bind(c) :: proc3
|
||||
!WARNING: Attribute 'PROTECTED' cannot be used more than once
|
||||
procedure(procFunc), protected, pointer, protected :: proc4
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user