summaryrefslogtreecommitdiff
path: root/flang/lib/Semantics
diff options
context:
space:
mode:
Diffstat (limited to 'flang/lib/Semantics')
-rw-r--r--flang/lib/Semantics/check-allocate.cpp2
-rw-r--r--flang/lib/Semantics/check-call.cpp217
-rw-r--r--flang/lib/Semantics/check-declarations.cpp58
-rw-r--r--flang/lib/Semantics/check-omp-atomic.cpp112
-rw-r--r--flang/lib/Semantics/check-omp-loop.cpp2
-rw-r--r--flang/lib/Semantics/check-omp-structure.cpp217
-rw-r--r--flang/lib/Semantics/check-omp-structure.h9
-rw-r--r--flang/lib/Semantics/check-select-rank.cpp2
-rw-r--r--flang/lib/Semantics/check-select-type.cpp2
-rw-r--r--flang/lib/Semantics/compute-offsets.cpp4
-rw-r--r--flang/lib/Semantics/expression.cpp17
-rw-r--r--flang/lib/Semantics/pointer-assignment.cpp2
-rw-r--r--flang/lib/Semantics/resolve-directives.cpp257
-rw-r--r--flang/lib/Semantics/resolve-names.cpp92
-rw-r--r--flang/lib/Semantics/rewrite-parse-tree.cpp10
-rw-r--r--flang/lib/Semantics/runtime-type-info.cpp16
-rw-r--r--flang/lib/Semantics/symbol.cpp18
-rw-r--r--flang/lib/Semantics/tools.cpp24
-rw-r--r--flang/lib/Semantics/unparse-with-symbols.cpp12
19 files changed, 748 insertions, 325 deletions
diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp
index 08053594c12e..823aa4e795e3 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -548,7 +548,7 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
}
}
// Shape related checks
- if (ultimate_ && evaluate::IsAssumedRank(*ultimate_)) {
+ if (ultimate_ && IsAssumedRank(*ultimate_)) {
context.Say(name_.source,
"An assumed-rank dummy argument may not appear in an ALLOCATE statement"_err_en_US);
return false;
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 83f59f0cac3d..f0078fda3600 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -67,7 +67,7 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
"Null pointer argument requires an explicit interface"_err_en_US);
} else if (auto named{evaluate::ExtractNamedEntity(*expr)}) {
const Symbol &symbol{named->GetLastSymbol()};
- if (evaluate::IsAssumedRank(symbol)) {
+ if (IsAssumedRank(symbol)) {
messages.Say(
"Assumed rank argument requires an explicit interface"_err_en_US);
}
@@ -131,7 +131,7 @@ static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
dummy.type.type().kind() == actualType.type().kind() &&
!dummy.attrs.test(
characteristics::DummyDataObject::Attr::DeducedFromActual)) {
- bool actualIsAssumedRank{evaluate::IsAssumedRank(actual)};
+ bool actualIsAssumedRank{IsAssumedRank(actual)};
if (actualIsAssumedRank &&
!dummy.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedRank)) {
@@ -140,7 +140,8 @@ static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
messages.Say(
"Assumed-rank character array may not be associated with a dummy argument that is not assumed-rank"_err_en_US);
} else {
- context.Warn(common::LanguageFeature::AssumedRankPassedToNonAssumedRank,
+ context.Warn(messages,
+ common::LanguageFeature::AssumedRankPassedToNonAssumedRank,
messages.at(),
"Assumed-rank character array should not be associated with a dummy argument that is not assumed-rank"_port_en_US);
}
@@ -187,9 +188,9 @@ static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
"Actual argument has fewer characters remaining in storage sequence (%jd) than %s (%jd)"_err_en_US,
static_cast<std::intmax_t>(actualChars), dummyName,
static_cast<std::intmax_t>(dummyChars));
- } else if (context.ShouldWarn(
- common::UsageWarning::ShortCharacterActual)) {
- messages.Say(common::UsageWarning::ShortCharacterActual,
+ } else {
+ context.Warn(messages,
+ common::UsageWarning::ShortCharacterActual,
"Actual argument has fewer characters remaining in storage sequence (%jd) than %s (%jd)"_warn_en_US,
static_cast<std::intmax_t>(actualChars), dummyName,
static_cast<std::intmax_t>(dummyChars));
@@ -207,9 +208,9 @@ static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
static_cast<std::intmax_t>(*actualSize * *actualLength),
dummyName,
static_cast<std::intmax_t>(*dummySize * *dummyLength));
- } else if (context.ShouldWarn(
- common::UsageWarning::ShortCharacterActual)) {
- messages.Say(common::UsageWarning::ShortCharacterActual,
+ } else {
+ context.Warn(messages,
+ common::UsageWarning::ShortCharacterActual,
"Actual argument array has fewer characters (%jd) than %s array (%jd)"_warn_en_US,
static_cast<std::intmax_t>(*actualSize * *actualLength),
dummyName,
@@ -229,17 +230,14 @@ static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
} else if (*actualLength < *dummyLength) {
CHECK(dummy.type.Rank() == 0);
bool isVariable{evaluate::IsVariable(actual)};
- if (context.ShouldWarn(
- common::UsageWarning::ShortCharacterActual)) {
- if (isVariable) {
- messages.Say(common::UsageWarning::ShortCharacterActual,
- "Actual argument variable length '%jd' is less than expected length '%jd'"_warn_en_US,
- *actualLength, *dummyLength);
- } else {
- messages.Say(common::UsageWarning::ShortCharacterActual,
- "Actual argument expression length '%jd' is less than expected length '%jd'"_warn_en_US,
- *actualLength, *dummyLength);
- }
+ if (isVariable) {
+ context.Warn(messages, common::UsageWarning::ShortCharacterActual,
+ "Actual argument variable length '%jd' is less than expected length '%jd'"_warn_en_US,
+ *actualLength, *dummyLength);
+ } else {
+ context.Warn(messages, common::UsageWarning::ShortCharacterActual,
+ "Actual argument expression length '%jd' is less than expected length '%jd'"_warn_en_US,
+ *actualLength, *dummyLength);
}
if (!isVariable) {
auto converted{
@@ -279,9 +277,8 @@ static void ConvertIntegerActual(evaluate::Expr<evaluate::SomeType> &actual,
messages.Say(
"Actual argument scalar expression of type INTEGER(%d) cannot be implicitly converted to smaller dummy argument type INTEGER(%d)"_err_en_US,
actualType.type().kind(), dummyType.type().kind());
- } else if (semanticsContext.ShouldWarn(common::LanguageFeature::
- ActualIntegerConvertedToSmallerKind)) {
- messages.Say(
+ } else {
+ semanticsContext.Warn(messages,
common::LanguageFeature::ActualIntegerConvertedToSmallerKind,
"Actual argument scalar expression of type INTEGER(%d) was converted to smaller dummy argument type INTEGER(%d)"_port_en_US,
actualType.type().kind(), dummyType.type().kind());
@@ -364,20 +361,16 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
if (const auto *constantChar{
evaluate::UnwrapConstantValue<evaluate::Ascii>(actual)};
constantChar && constantChar->wasHollerith() &&
- dummy.type.type().IsUnlimitedPolymorphic() &&
- context.ShouldWarn(common::LanguageFeature::HollerithPolymorphic)) {
- messages.Say(common::LanguageFeature::HollerithPolymorphic,
+ dummy.type.type().IsUnlimitedPolymorphic()) {
+ foldingContext.Warn(common::LanguageFeature::HollerithPolymorphic,
"passing Hollerith to unlimited polymorphic as if it were CHARACTER"_port_en_US);
}
} else if (dummyRank == 0 && allowActualArgumentConversions) {
// Extension: pass Hollerith literal to scalar as if it had been BOZ
if (auto converted{evaluate::HollerithToBOZ(
foldingContext, actual, dummy.type.type())}) {
- if (context.ShouldWarn(
- common::LanguageFeature::HollerithOrCharacterAsBOZ)) {
- messages.Say(common::LanguageFeature::HollerithOrCharacterAsBOZ,
- "passing Hollerith or character literal as if it were BOZ"_port_en_US);
- }
+ foldingContext.Warn(common::LanguageFeature::HollerithOrCharacterAsBOZ,
+ "passing Hollerith or character literal as if it were BOZ"_port_en_US);
actual = *converted;
actualType.type() = dummy.type.type();
typesCompatible = true;
@@ -387,7 +380,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
characteristics::TypeAndShape::Attr::AssumedRank)};
bool actualIsAssumedSize{actualType.attrs().test(
characteristics::TypeAndShape::Attr::AssumedSize)};
- bool actualIsAssumedRank{evaluate::IsAssumedRank(actual)};
+ bool actualIsAssumedRank{IsAssumedRank(actual)};
bool actualIsPointer{evaluate::IsObjectPointer(actual)};
bool actualIsAllocatable{evaluate::IsAllocatableDesignator(actual)};
bool actualMayBeAssumedSize{actualIsAssumedSize ||
@@ -411,7 +404,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
"%s actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization"_err_en_US,
actualDesc);
} else {
- context.Warn(common::UsageWarning::Portability, messages.at(),
+ foldingContext.Warn(common::UsageWarning::Portability, messages.at(),
"%s actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument"_port_en_US,
actualDesc);
}
@@ -671,9 +664,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
"Actual argument has fewer elements remaining in storage sequence (%jd) than %s array (%jd)"_err_en_US,
static_cast<std::intmax_t>(*actualElements), dummyName,
static_cast<std::intmax_t>(*dummySize));
- } else if (context.ShouldWarn(
- common::UsageWarning::ShortArrayActual)) {
- messages.Say(common::UsageWarning::ShortArrayActual,
+ } else {
+ context.Warn(common::UsageWarning::ShortArrayActual,
"Actual argument has fewer elements remaining in storage sequence (%jd) than %s array (%jd)"_warn_en_US,
static_cast<std::intmax_t>(*actualElements), dummyName,
static_cast<std::intmax_t>(*dummySize));
@@ -690,9 +682,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
"Actual argument array has fewer elements (%jd) than %s array (%jd)"_err_en_US,
static_cast<std::intmax_t>(*actualSize), dummyName,
static_cast<std::intmax_t>(*dummySize));
- } else if (context.ShouldWarn(
- common::UsageWarning::ShortArrayActual)) {
- messages.Say(common::UsageWarning::ShortArrayActual,
+ } else {
+ context.Warn(common::UsageWarning::ShortArrayActual,
"Actual argument array has fewer elements (%jd) than %s array (%jd)"_warn_en_US,
static_cast<std::intmax_t>(*actualSize), dummyName,
static_cast<std::intmax_t>(*dummySize));
@@ -779,24 +770,36 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
// Cases when temporaries might be needed but must not be permitted.
bool dummyIsAssumedShape{dummy.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedShape)};
- if ((actualIsAsynchronous || actualIsVolatile) &&
- (dummyIsAsynchronous || dummyIsVolatile) && !dummyIsValue) {
- if (actualCoarrayRef) { // C1538
- messages.Say(
- "Coindexed ASYNCHRONOUS or VOLATILE actual argument may not be associated with %s with ASYNCHRONOUS or VOLATILE attributes unless VALUE"_err_en_US,
- dummyName);
- }
- if ((actualRank > 0 || actualIsAssumedRank) && !actualIsContiguous) {
- if (dummyIsContiguous ||
- !(dummyIsAssumedShape || dummyIsAssumedRank ||
- (actualIsPointer && dummyIsPointer))) { // C1539 & C1540
+ if (!dummyIsValue && (dummyIsAsynchronous || dummyIsVolatile)) {
+ if (actualIsAsynchronous || actualIsVolatile) {
+ if (actualCoarrayRef) { // F'2023 C1547
messages.Say(
- "ASYNCHRONOUS or VOLATILE actual argument that is not simply contiguous may not be associated with a contiguous ASYNCHRONOUS or VOLATILE %s"_err_en_US,
+ "Coindexed ASYNCHRONOUS or VOLATILE actual argument may not be associated with %s with ASYNCHRONOUS or VOLATILE attributes unless VALUE"_err_en_US,
dummyName);
}
+ if ((actualRank > 0 || actualIsAssumedRank) && !actualIsContiguous) {
+ if (dummyIsContiguous ||
+ !(dummyIsAssumedShape || dummyIsAssumedRank ||
+ (actualIsPointer && dummyIsPointer))) { // F'2023 C1548 & C1549
+ messages.Say(
+ "ASYNCHRONOUS or VOLATILE actual argument that is not simply contiguous may not be associated with a contiguous ASYNCHRONOUS or VOLATILE %s"_err_en_US,
+ dummyName);
+ }
+ }
+ // The vector subscript case is handled by the definability check above.
+ // The copy-in/copy-out cases are handled by the previous checks.
+ // Nag, GFortran, and NVFortran all error on this case, even though it is
+ // ok, prossibly as an over-restriction of C1548.
+ } else if (!(dummyIsAssumedShape || dummyIsAssumedRank ||
+ (actualIsPointer && dummyIsPointer)) &&
+ evaluate::IsArraySection(actual) &&
+ !evaluate::HasVectorSubscript(actual)) {
+ context.Warn(common::UsageWarning::Portability, messages.at(),
+ "The array section '%s' should not be associated with %s with %s attribute, unless the dummy is assumed-shape or assumed-rank"_port_en_US,
+ actual.AsFortran(), dummyName,
+ dummyIsAsynchronous ? "ASYNCHRONOUS" : "VOLATILE");
}
}
-
// 15.5.2.6 -- dummy is ALLOCATABLE
bool dummyIsOptional{
dummy.attrs.test(characteristics::DummyDataObject::Attr::Optional)};
@@ -821,10 +824,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
messages.Say(
"A null pointer should not be associated with allocatable %s without INTENT(IN)"_warn_en_US,
dummyName);
- } else if (dummy.intent == common::Intent::In &&
- context.ShouldWarn(
- common::LanguageFeature::NullActualForAllocatable)) {
- messages.Say(common::LanguageFeature::NullActualForAllocatable,
+ } else if (dummy.intent == common::Intent::In) {
+ foldingContext.Warn(common::LanguageFeature::NullActualForAllocatable,
"Allocatable %s is associated with a null pointer"_port_en_US,
dummyName);
}
@@ -878,11 +879,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
checkTypeCompatibility = false;
if (dummyIsUnlimited && dummy.intent == common::Intent::In &&
context.IsEnabled(common::LanguageFeature::RelaxedIntentInChecking)) {
- if (context.ShouldWarn(
- common::LanguageFeature::RelaxedIntentInChecking)) {
- messages.Say(common::LanguageFeature::RelaxedIntentInChecking,
- "If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both should be so"_port_en_US);
- }
+ foldingContext.Warn(common::LanguageFeature::RelaxedIntentInChecking,
+ "If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both should be so"_port_en_US);
} else {
messages.Say(
"If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both must be so"_err_en_US);
@@ -890,21 +888,15 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
} else if (dummyIsPolymorphic != actualIsPolymorphic) {
if (dummyIsPolymorphic && dummy.intent == common::Intent::In &&
context.IsEnabled(common::LanguageFeature::RelaxedIntentInChecking)) {
- if (context.ShouldWarn(
- common::LanguageFeature::RelaxedIntentInChecking)) {
- messages.Say(common::LanguageFeature::RelaxedIntentInChecking,
- "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both should be so"_port_en_US);
- }
+ foldingContext.Warn(common::LanguageFeature::RelaxedIntentInChecking,
+ "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both should be so"_port_en_US);
} else if (actualIsPolymorphic &&
context.IsEnabled(common::LanguageFeature::
PolymorphicActualAllocatableOrPointerToMonomorphicDummy)) {
- if (context.ShouldWarn(common::LanguageFeature::
- PolymorphicActualAllocatableOrPointerToMonomorphicDummy)) {
- messages.Say(
- common::LanguageFeature::
- PolymorphicActualAllocatableOrPointerToMonomorphicDummy,
- "If a POINTER or ALLOCATABLE actual argument is polymorphic, the corresponding dummy argument should also be so"_port_en_US);
- }
+ foldingContext.Warn(
+ common::LanguageFeature::
+ PolymorphicActualAllocatableOrPointerToMonomorphicDummy,
+ "If a POINTER or ALLOCATABLE actual argument is polymorphic, the corresponding dummy argument should also be so"_port_en_US);
} else {
checkTypeCompatibility = false;
messages.Say(
@@ -916,11 +908,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
if (dummy.intent == common::Intent::In &&
context.IsEnabled(
common::LanguageFeature::RelaxedIntentInChecking)) {
- if (context.ShouldWarn(
- common::LanguageFeature::RelaxedIntentInChecking)) {
- messages.Say(common::LanguageFeature::RelaxedIntentInChecking,
- "POINTER or ALLOCATABLE dummy and actual arguments should have the same declared type and kind"_port_en_US);
- }
+ foldingContext.Warn(common::LanguageFeature::RelaxedIntentInChecking,
+ "POINTER or ALLOCATABLE dummy and actual arguments should have the same declared type and kind"_port_en_US);
} else {
messages.Say(
"POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind"_err_en_US);
@@ -991,13 +980,13 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
bool actualIsTemp{
!actualIsVariable || HasVectorSubscript(actual) || actualCoarrayRef};
if (actualIsTemp) {
- messages.Say(common::UsageWarning::NonTargetPassedToTarget,
+ foldingContext.Warn(common::UsageWarning::NonTargetPassedToTarget,
"Any pointer associated with TARGET %s during this call will not be associated with the value of '%s' afterwards"_warn_en_US,
dummyName, actual.AsFortran());
} else {
auto actualSymbolVector{GetSymbolVector(actual)};
if (!evaluate::GetLastTarget(actualSymbolVector)) {
- messages.Say(common::UsageWarning::NonTargetPassedToTarget,
+ foldingContext.Warn(common::UsageWarning::NonTargetPassedToTarget,
"Any pointer associated with TARGET %s during this call must not be used afterwards, as '%s' is not a target"_warn_en_US,
dummyName, actual.AsFortran());
}
@@ -1126,9 +1115,8 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
evaluate::SayWithDeclaration(messages, *argProcSymbol,
"Procedure binding '%s' passed as an actual argument"_err_en_US,
argProcSymbol->name());
- } else if (context.ShouldWarn(
- common::LanguageFeature::BindingAsProcedure)) {
- evaluate::SayWithDeclaration(messages, *argProcSymbol,
+ } else {
+ evaluate::WarnWithDeclaration(foldingContext, *argProcSymbol,
common::LanguageFeature::BindingAsProcedure,
"Procedure binding '%s' passed as an actual argument"_port_en_US,
argProcSymbol->name());
@@ -1180,15 +1168,14 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
messages.Say(
"Actual procedure argument for %s of a PURE procedure must have an explicit interface"_err_en_US,
dummyName);
- } else if (context.ShouldWarn(
- common::UsageWarning::ImplicitInterfaceActual)) {
- messages.Say(common::UsageWarning::ImplicitInterfaceActual,
+ } else {
+ foldingContext.Warn(
+ common::UsageWarning::ImplicitInterfaceActual,
"Actual procedure argument has an implicit interface which is not known to be compatible with %s which has an explicit interface"_warn_en_US,
dummyName);
}
- } else if (warning &&
- context.ShouldWarn(common::UsageWarning::ProcDummyArgShapes)) {
- messages.Say(common::UsageWarning::ProcDummyArgShapes,
+ } else if (warning) {
+ foldingContext.Warn(common::UsageWarning::ProcDummyArgShapes,
"Actual procedure argument has possible interface incompatibility with %s: %s"_warn_en_US,
dummyName, std::move(*warning));
}
@@ -1363,16 +1350,14 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
messages.Say(
"NULL() actual argument '%s' may not be associated with allocatable dummy argument %s that is INTENT(OUT) or INTENT(IN OUT)"_err_en_US,
expr->AsFortran(), dummyName);
- } else if (object.intent == common::Intent::Default &&
- context.ShouldWarn(common::UsageWarning::
- NullActualForDefaultIntentAllocatable)) {
- messages.Say(common::UsageWarning::
- NullActualForDefaultIntentAllocatable,
+ } else if (object.intent == common::Intent::Default) {
+ foldingContext.Warn(
+ common::UsageWarning::
+ NullActualForDefaultIntentAllocatable,
"NULL() actual argument '%s' should not be associated with allocatable dummy argument %s without INTENT(IN)"_warn_en_US,
expr->AsFortran(), dummyName);
- } else if (context.ShouldWarn(common::LanguageFeature::
- NullActualForAllocatable)) {
- messages.Say(
+ } else {
+ foldingContext.Warn(
common::LanguageFeature::NullActualForAllocatable,
"Allocatable %s is associated with %s"_port_en_US,
dummyName, expr->AsFortran());
@@ -1390,8 +1375,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
assumed.name(), dummyName);
} else if (object.type.attrs().test(characteristics::
TypeAndShape::Attr::AssumedRank) &&
- !IsAssumedShape(assumed) &&
- !evaluate::IsAssumedRank(assumed)) {
+ !IsAssumedShape(assumed) && !IsAssumedRank(assumed)) {
messages.Say( // C711
"Assumed-type '%s' must be either assumed shape or assumed rank to be associated with assumed rank %s"_err_en_US,
assumed.name(), dummyName);
@@ -1562,7 +1546,7 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
if (semanticsContext.ShouldWarn(common::UsageWarning::Portability)) {
if (!evaluate::ExtractDataRef(*pointerExpr) &&
!evaluate::IsProcedurePointer(*pointerExpr)) {
- messages.Say(common::UsageWarning::Portability,
+ foldingContext.Warn(common::UsageWarning::Portability,
pointerArg->sourceLocation(),
"POINTER= argument of ASSOCIATED() is required by some other compilers to be a pointer"_port_en_US);
} else if (scope && !evaluate::UnwrapProcedureRef(*pointerExpr)) {
@@ -1573,7 +1557,8 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
DefinabilityFlag::DoNotNoteDefinition},
*pointerExpr)}) {
if (whyNot->IsFatal()) {
- if (auto *msg{messages.Say(common::UsageWarning::Portability,
+ if (auto *msg{foldingContext.Warn(
+ common::UsageWarning::Portability,
pointerArg->sourceLocation(),
"POINTER= argument of ASSOCIATED() is required by some other compilers to be a valid left-hand side of a pointer assignment statement"_port_en_US)}) {
msg->Attach(std::move(
@@ -2000,8 +1985,9 @@ static void CheckReduce(
}
}
}
- const auto *result{
- procChars ? procChars->functionResult->GetTypeAndShape() : nullptr};
+ const auto *result{procChars && procChars->functionResult
+ ? procChars->functionResult->GetTypeAndShape()
+ : nullptr};
if (!procChars || !procChars->IsPure() ||
procChars->dummyArguments.size() != 2 || !procChars->functionResult) {
messages.Say(
@@ -2087,10 +2073,8 @@ static void CheckReduce(
// TRANSFER (16.9.193)
static void CheckTransferOperandType(SemanticsContext &context,
const evaluate::DynamicType &type, const char *which) {
- if (type.IsPolymorphic() &&
- context.ShouldWarn(common::UsageWarning::PolymorphicTransferArg)) {
- context.foldingContext().messages().Say(
- common::UsageWarning::PolymorphicTransferArg,
+ if (type.IsPolymorphic()) {
+ context.foldingContext().Warn(common::UsageWarning::PolymorphicTransferArg,
"%s of TRANSFER is polymorphic"_warn_en_US, which);
} else if (!type.IsUnlimitedPolymorphic() &&
type.category() == TypeCategory::Derived &&
@@ -2098,7 +2082,7 @@ static void CheckTransferOperandType(SemanticsContext &context,
DirectComponentIterator directs{type.GetDerivedTypeSpec()};
if (auto bad{std::find_if(directs.begin(), directs.end(), IsDescriptor)};
bad != directs.end()) {
- evaluate::SayWithDeclaration(context.foldingContext().messages(), *bad,
+ evaluate::WarnWithDeclaration(context.foldingContext(), *bad,
common::UsageWarning::PointerComponentTransferArg,
"%s of TRANSFER contains allocatable or pointer component %s"_warn_en_US,
which, bad.BuildResultDesignatorName());
@@ -2128,8 +2112,8 @@ static void CheckTransfer(evaluate::ActualArguments &arguments,
messages.Say(
"Element size of MOLD= array may not be zero when SOURCE= is not empty"_err_en_US);
}
- } else if (context.ShouldWarn(common::UsageWarning::VoidMold)) {
- messages.Say(common::UsageWarning::VoidMold,
+ } else {
+ foldingContext.Warn(common::UsageWarning::VoidMold,
"Element size of MOLD= array may not be zero unless SOURCE= is empty"_warn_en_US);
}
}
@@ -2145,7 +2129,7 @@ static void CheckTransfer(evaluate::ActualArguments &arguments,
} else if (context.ShouldWarn(
common::UsageWarning::TransferSizePresence) &&
IsAllocatableOrObjectPointer(whole)) {
- messages.Say(common::UsageWarning::TransferSizePresence,
+ foldingContext.Warn(common::UsageWarning::TransferSizePresence,
"SIZE= argument that is allocatable or pointer must be present at execution; parenthesize to silence this warning"_warn_en_US);
}
}
@@ -2368,13 +2352,10 @@ bool CheckArguments(const characteristics::Procedure &proc,
/*extentErrors=*/true, ignoreImplicitVsExplicit)};
if (!buffer.empty()) {
if (treatingExternalAsImplicit) {
- if (context.ShouldWarn(
- common::UsageWarning::KnownBadImplicitInterface)) {
- if (auto *msg{messages.Say(
- common::UsageWarning::KnownBadImplicitInterface,
- "If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) {
- buffer.AttachTo(*msg, parser::Severity::Because);
- }
+ if (auto *msg{foldingContext.Warn(
+ common::UsageWarning::KnownBadImplicitInterface,
+ "If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) {
+ buffer.AttachTo(*msg, parser::Severity::Because);
} else {
buffer.clear();
}
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index d769f221b198..84edcebc6497 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -130,21 +130,14 @@ private:
}
template <typename FeatureOrUsageWarning, typename... A>
parser::Message *Warn(FeatureOrUsageWarning warning, A &&...x) {
- if (!context_.ShouldWarn(warning) || InModuleFile()) {
- return nullptr;
- } else {
- return messages_.Say(warning, std::forward<A>(x)...);
- }
+ return messages_.Warn(InModuleFile(), context_.languageFeatures(), warning,
+ std::forward<A>(x)...);
}
template <typename FeatureOrUsageWarning, typename... A>
parser::Message *Warn(
FeatureOrUsageWarning warning, parser::CharBlock source, A &&...x) {
- if (!context_.ShouldWarn(warning) ||
- FindModuleFileContaining(context_.FindScope(source))) {
- return nullptr;
- } else {
- return messages_.Say(warning, source, std::forward<A>(x)...);
- }
+ return messages_.Warn(FindModuleFileContaining(context_.FindScope(source)),
+ context_.languageFeatures(), warning, source, std::forward<A>(x)...);
}
bool IsResultOkToDiffer(const FunctionResult &);
void CheckGlobalName(const Symbol &);
@@ -326,7 +319,7 @@ void CheckHelper::Check(const Symbol &symbol) {
!IsDummy(symbol)) {
if (context_.IsEnabled(
common::LanguageFeature::IgnoreIrrelevantAttributes)) {
- context_.Warn(common::LanguageFeature::IgnoreIrrelevantAttributes,
+ Warn(common::LanguageFeature::IgnoreIrrelevantAttributes,
"Only a dummy argument should have an INTENT, VALUE, or OPTIONAL attribute"_warn_en_US);
} else {
messages_.Say(
@@ -633,7 +626,7 @@ void CheckHelper::CheckValue(
"VALUE attribute may not apply to a type with a coarray ultimate component"_err_en_US);
}
}
- if (evaluate::IsAssumedRank(symbol)) {
+ if (IsAssumedRank(symbol)) {
messages_.Say(
"VALUE attribute may not apply to an assumed-rank array"_err_en_US);
}
@@ -743,7 +736,7 @@ void CheckHelper::CheckObjectEntity(
"Coarray '%s' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR"_err_en_US,
symbol.name());
}
- if (evaluate::IsAssumedRank(symbol)) {
+ if (IsAssumedRank(symbol)) {
messages_.Say("Coarray '%s' may not be an assumed-rank array"_err_en_US,
symbol.name());
}
@@ -889,7 +882,7 @@ void CheckHelper::CheckObjectEntity(
"!DIR$ IGNORE_TKR may not apply to an allocatable or pointer"_err_en_US);
}
} else if (ignoreTKR.test(common::IgnoreTKR::Rank)) {
- if (ignoreTKR.count() == 1 && evaluate::IsAssumedRank(symbol)) {
+ if (ignoreTKR.count() == 1 && IsAssumedRank(symbol)) {
Warn(common::UsageWarning::IgnoreTKRUsage,
"!DIR$ IGNORE_TKR(R) is not meaningful for an assumed-rank array"_warn_en_US);
} else if (inExplicitExternalInterface) {
@@ -1214,7 +1207,7 @@ void CheckHelper::CheckObjectEntity(
SayWithDeclaration(symbol,
"Deferred-shape entity of %s type is not supported"_err_en_US,
typeName);
- } else if (evaluate::IsAssumedRank(symbol)) {
+ } else if (IsAssumedRank(symbol)) {
SayWithDeclaration(symbol,
"Assumed rank entity of %s type is not supported"_err_en_US,
typeName);
@@ -2428,7 +2421,7 @@ void CheckHelper::CheckVolatile(const Symbol &symbol,
void CheckHelper::CheckContiguous(const Symbol &symbol) {
if (evaluate::IsVariable(symbol) &&
((IsPointer(symbol) && symbol.Rank() > 0) || IsAssumedShape(symbol) ||
- evaluate::IsAssumedRank(symbol))) {
+ IsAssumedRank(symbol))) {
} else {
parser::MessageFixedText msg{symbol.owner().IsDerivedType()
? "CONTIGUOUS component '%s' should be an array with the POINTER attribute"_port_en_US
@@ -2957,7 +2950,7 @@ static bool IsSubprogramDefinition(const Symbol &symbol) {
static bool IsExternalProcedureDefinition(const Symbol &symbol) {
return IsBlockData(symbol) ||
- (IsSubprogramDefinition(symbol) &&
+ ((IsSubprogramDefinition(symbol) || IsAlternateEntry(&symbol)) &&
(IsExternal(symbol) || symbol.GetBindName()));
}
@@ -3141,16 +3134,14 @@ parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
*dyType, &context_.languageFeatures())
.value_or(false)) {
if (type->category() == DeclTypeSpec::Logical) {
- if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {
- msgs.Say(common::UsageWarning::LogicalVsCBool, component.name(),
- "A LOGICAL component of an interoperable type should have the interoperable KIND=C_BOOL"_port_en_US);
- }
+ context().Warn(msgs, common::UsageWarning::LogicalVsCBool,
+ 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 && dyType &&
dyType->kind() == 1) {
- if (context_.ShouldWarn(common::UsageWarning::BindCCharLength)) {
- msgs.Say(common::UsageWarning::BindCCharLength, component.name(),
- "A CHARACTER component of an interoperable type should have length 1"_port_en_US);
- }
+ context().Warn(msgs, common::UsageWarning::BindCCharLength,
+ 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);
@@ -3165,10 +3156,9 @@ parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
}
}
if (derived->componentNames().empty()) { // F'2023 C1805
- if (context_.ShouldWarn(common::LanguageFeature::EmptyBindCDerivedType)) {
- msgs.Say(common::LanguageFeature::EmptyBindCDerivedType, symbol.name(),
- "A derived type with the BIND attribute should not be empty"_warn_en_US);
- }
+ context().Warn(msgs, common::LanguageFeature::EmptyBindCDerivedType,
+ symbol.name(),
+ "A derived type with the BIND attribute should not be empty"_warn_en_US);
}
}
if (msgs.AnyFatalError()) {
@@ -3218,7 +3208,7 @@ parser::Messages CheckHelper::WhyNotInteroperableObject(
if (derived && !derived->typeSymbol().attrs().test(Attr::BIND_C)) {
if (allowNonInteroperableType) { // portability warning only
evaluate::AttachDeclaration(
- context_.Warn(common::UsageWarning::Portability, symbol.name(),
+ 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(
@@ -3260,10 +3250,10 @@ parser::Messages CheckHelper::WhyNotInteroperableObject(
} else if (type->category() == DeclTypeSpec::Logical) {
if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {
if (IsDummy(symbol)) {
- msgs.Say(common::UsageWarning::LogicalVsCBool, symbol.name(),
+ Warn(common::UsageWarning::LogicalVsCBool, symbol.name(),
"A BIND(C) LOGICAL dummy argument should have the interoperable KIND=C_BOOL"_port_en_US);
} else {
- msgs.Say(common::UsageWarning::LogicalVsCBool, symbol.name(),
+ Warn(common::UsageWarning::LogicalVsCBool, symbol.name(),
"A BIND(C) LOGICAL object should have the interoperable KIND=C_BOOL"_port_en_US);
}
}
@@ -3459,7 +3449,7 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
bool CheckHelper::CheckDioDummyIsData(
const Symbol &subp, const Symbol *arg, std::size_t position) {
if (arg && arg->detailsIf<ObjectEntityDetails>()) {
- if (evaluate::IsAssumedRank(*arg)) {
+ if (IsAssumedRank(*arg)) {
messages_.Say(arg->name(),
"Dummy argument '%s' may not be assumed-rank"_err_en_US, arg->name());
return false;
diff --git a/flang/lib/Semantics/check-omp-atomic.cpp b/flang/lib/Semantics/check-omp-atomic.cpp
index 50e63d356be0..351af5c099ae 100644
--- a/flang/lib/Semantics/check-omp-atomic.cpp
+++ b/flang/lib/Semantics/check-omp-atomic.cpp
@@ -61,16 +61,46 @@ template <common::TypeCategory C, int K>
struct IsIntegral<evaluate::Type<C, K>> {
static constexpr bool value{//
C == common::TypeCategory::Integer ||
- C == common::TypeCategory::Unsigned ||
- C == common::TypeCategory::Logical};
+ C == common::TypeCategory::Unsigned};
};
template <typename T> constexpr bool is_integral_v{IsIntegral<T>::value};
+template <typename...> struct IsFloatingPoint {
+ static constexpr bool value{false};
+};
+
+template <common::TypeCategory C, int K>
+struct IsFloatingPoint<evaluate::Type<C, K>> {
+ static constexpr bool value{//
+ C == common::TypeCategory::Real || C == common::TypeCategory::Complex};
+};
+
+template <typename T>
+constexpr bool is_floating_point_v{IsFloatingPoint<T>::value};
+
+template <typename T>
+constexpr bool is_numeric_v{is_integral_v<T> || is_floating_point_v<T>};
+
+template <typename...> struct IsLogical {
+ static constexpr bool value{false};
+};
+
+template <common::TypeCategory C, int K>
+struct IsLogical<evaluate::Type<C, K>> {
+ static constexpr bool value{C == common::TypeCategory::Logical};
+};
+
+template <typename T> constexpr bool is_logical_v{IsLogical<T>::value};
+
template <typename T, typename Op0, typename Op1>
using ReassocOpBase = evaluate::match::AnyOfPattern< //
evaluate::match::Add<T, Op0, Op1>, //
- evaluate::match::Mul<T, Op0, Op1>>;
+ evaluate::match::Mul<T, Op0, Op1>, //
+ evaluate::match::LogicalOp<common::LogicalOperator::And, T, Op0, Op1>,
+ evaluate::match::LogicalOp<common::LogicalOperator::Or, T, Op0, Op1>,
+ evaluate::match::LogicalOp<common::LogicalOperator::Eqv, T, Op0, Op1>,
+ evaluate::match::LogicalOp<common::LogicalOperator::Neqv, T, Op0, Op1>>;
template <typename T, typename Op0, typename Op1>
struct ReassocOp : public ReassocOpBase<T, Op0, Op1> {
@@ -88,13 +118,14 @@ struct ReassocRewriter : public evaluate::rewrite::Identity {
using Id = evaluate::rewrite::Identity;
struct NonIntegralTag {};
- ReassocRewriter(const SomeExpr &atom) : atom_(atom) {}
+ ReassocRewriter(const SomeExpr &atom, const SemanticsContext &context)
+ : atom_(atom), context_(context) {}
// Try to find cases where the input expression is of the form
// (1) (a . b) . c, or
// (2) a . (b . c),
- // where . denotes an associative operation (currently + or *), and a, b, c
- // are some subexpresions.
+ // where . denotes an associative operation, and a, b, c are some
+ // subexpresions.
// If one of the operands in the nested operation is the atomic variable
// (with some possible type conversions applied to it), bring it to the
// top-level operation, and move the top-level operand into the nested
@@ -102,8 +133,13 @@ struct ReassocRewriter : public evaluate::rewrite::Identity {
// For example, assuming x is the atomic variable:
// (a + x) + b -> (a + b) + x, i.e. (conceptually) swap x and b.
template <typename T, typename U,
- typename = std::enable_if_t<is_integral_v<T>>>
+ typename = std::enable_if_t<is_numeric_v<T> || is_logical_v<T>>>
evaluate::Expr<T> operator()(evaluate::Expr<T> &&x, const U &u) {
+ if constexpr (is_floating_point_v<T>) {
+ if (!context_.langOptions().AssociativeMath) {
+ return Id::operator()(std::move(x), u);
+ }
+ }
// As per the above comment, there are 3 subexpressions involved in this
// transformation. A match::Expr<T> will match evaluate::Expr<U> when T is
// same as U, plus it will store a pointer (ref) to the matched expression.
@@ -111,8 +147,8 @@ struct ReassocRewriter : public evaluate::rewrite::Identity {
// some order) from the example above.
evaluate::match::Expr<T> sub[3];
auto inner{reassocOp<T>(sub[0], sub[1])};
- auto outer1{reassocOp<T>(inner, sub[2])}; // inner + something
- auto outer2{reassocOp<T>(sub[2], inner)}; // something + inner
+ auto outer1{reassocOp<T>(inner, sub[2])}; // inner . something
+ auto outer2{reassocOp<T>(sub[2], inner)}; // something . inner
#if !defined(__clang__) && !defined(_MSC_VER) && \
(__GNUC__ < 8 || (__GNUC__ == 8 && __GNUC_MINOR__ < 5))
// If GCC version < 8.5, use this definition. For the other definition
@@ -121,7 +157,8 @@ struct ReassocRewriter : public evaluate::rewrite::Identity {
// inside of the visitor function in common::visit.
// Since this works with clang, MSVC and at least GCC 8.5, I'm assuming
// that this is some kind of a GCC issue.
- using MatchTypes = std::tuple<evaluate::Add<T>, evaluate::Multiply<T>>;
+ using MatchTypes = std::tuple<evaluate::Add<T>, evaluate::Multiply<T>,
+ evaluate::LogicalOperation<T::kind>>;
#else
using MatchTypes = typename decltype(outer1)::MatchTypes;
#endif
@@ -145,23 +182,9 @@ struct ReassocRewriter : public evaluate::rewrite::Identity {
}
return common::visit(
[&](auto &&s) {
- using Expr = evaluate::Expr<T>;
- using TypeS = llvm::remove_cvref_t<decltype(s)>;
- // This visitor has to be semantically correct for all possible
- // types of s even though at runtime s will only be one of the
- // matched types.
- // Limit the construction to the operation types that we tried
- // to match (otherwise TypeS(op1, op2) would fail for non-binary
- // operations).
- if constexpr (common::HasMember<TypeS, MatchTypes>) {
- Expr atom{*sub[atomIdx].ref};
- Expr op1{*sub[(atomIdx + 1) % 3].ref};
- Expr op2{*sub[(atomIdx + 2) % 3].ref};
- return Expr(
- TypeS(atom, Expr(TypeS(std::move(op1), std::move(op2)))));
- } else {
- return Expr(TypeS(s));
- }
+ // Build the new expression from the matched components.
+ return Reconstruct<T, MatchTypes>(s, *sub[atomIdx].ref,
+ *sub[(atomIdx + 1) % 3].ref, *sub[(atomIdx + 2) % 3].ref);
},
evaluate::match::deparen(x).u);
}
@@ -169,18 +192,49 @@ struct ReassocRewriter : public evaluate::rewrite::Identity {
}
template <typename T, typename U,
- typename = std::enable_if_t<!is_integral_v<T>>>
+ typename = std::enable_if_t<!is_numeric_v<T> && !is_logical_v<T>>>
evaluate::Expr<T> operator()(
evaluate::Expr<T> &&x, const U &u, NonIntegralTag = {}) {
return Id::operator()(std::move(x), u);
}
private:
+ template <typename T, typename MatchTypes, typename S>
+ evaluate::Expr<T> Reconstruct(const S &op, evaluate::Expr<T> atom,
+ evaluate::Expr<T> op1, evaluate::Expr<T> op2) {
+ using TypeS = llvm::remove_cvref_t<decltype(op)>;
+ // This function has to be semantically correct for all possible types
+ // of S even though at runtime s will only be one of the matched types.
+ // Limit the construction to the operation types that we tried to match
+ // (otherwise TypeS(op1, op2) would fail for non-binary operations).
+ if constexpr (!common::HasMember<TypeS, MatchTypes>) {
+ return evaluate::Expr<T>(TypeS(op));
+ } else if constexpr (is_logical_v<T>) {
+ constexpr int K{T::kind};
+ if constexpr (std::is_same_v<TypeS, evaluate::LogicalOperation<K>>) {
+ // Logical operators take an extra argument in their constructor,
+ // so they need their own reconstruction code.
+ common::LogicalOperator opCode{op.logicalOperator};
+ return evaluate::Expr<T>(TypeS( //
+ opCode, std::move(atom),
+ evaluate::Expr<T>(TypeS( //
+ opCode, std::move(op1), std::move(op2)))));
+ }
+ } else {
+ // Generic reconstruction.
+ return evaluate::Expr<T>(TypeS( //
+ std::move(atom),
+ evaluate::Expr<T>(TypeS( //
+ std::move(op1), std::move(op2)))));
+ }
+ }
+
template <typename T> bool IsAtom(const evaluate::Expr<T> &x) const {
return IsSameOrConvertOf(evaluate::AsGenericExpr(AsRvalue(x)), atom_);
}
const SomeExpr &atom_;
+ const SemanticsContext &context_;
};
struct AnalyzedCondStmt {
@@ -809,7 +863,7 @@ OmpStructureChecker::CheckAtomicUpdateAssignment(
CheckStorageOverlap(atom, GetNonAtomArguments(atom, update.rhs), source);
return std::nullopt;
} else if (tryReassoc) {
- ReassocRewriter ra(atom);
+ ReassocRewriter ra(atom, context_);
SomeExpr raRhs{evaluate::rewrite::Mutator(ra)(update.rhs)};
std::tie(hasErrors, tryReassoc) = CheckAtomicUpdateAssignmentRhs(
diff --git a/flang/lib/Semantics/check-omp-loop.cpp b/flang/lib/Semantics/check-omp-loop.cpp
index 8dad1f5d605e..9384e039cf3f 100644
--- a/flang/lib/Semantics/check-omp-loop.cpp
+++ b/flang/lib/Semantics/check-omp-loop.cpp
@@ -196,7 +196,7 @@ void OmpStructureChecker::CheckSIMDNest(const parser::OpenMPConstruct &c) {
common::visit(
common::visitors{
// Allow `!$OMP ORDERED SIMD`
- [&](const parser::OpenMPBlockConstruct &c) {
+ [&](const parser::OmpBlockConstruct &c) {
const parser::OmpDirectiveSpecification &beginSpec{c.BeginDir()};
if (beginSpec.DirId() == llvm::omp::Directive::OMPD_ordered) {
for (const auto &clause : beginSpec.Clauses().v) {
diff --git a/flang/lib/Semantics/check-omp-structure.cpp b/flang/lib/Semantics/check-omp-structure.cpp
index 4a5e0b412874..d1654a3adcc9 100644
--- a/flang/lib/Semantics/check-omp-structure.cpp
+++ b/flang/lib/Semantics/check-omp-structure.cpp
@@ -143,6 +143,64 @@ private:
parser::CharBlock source_;
};
+// 'OmpWorkdistributeBlockChecker' is used to check the validity of the
+// assignment statements and the expressions enclosed in an OpenMP
+// WORKDISTRIBUTE construct
+class OmpWorkdistributeBlockChecker {
+public:
+ OmpWorkdistributeBlockChecker(
+ SemanticsContext &context, parser::CharBlock source)
+ : context_{context}, source_{source} {}
+
+ template <typename T> bool Pre(const T &) { return true; }
+ template <typename T> void Post(const T &) {}
+
+ bool Pre(const parser::AssignmentStmt &assignment) {
+ const auto &var{std::get<parser::Variable>(assignment.t)};
+ const auto &expr{std::get<parser::Expr>(assignment.t)};
+ const auto *lhs{GetExpr(context_, var)};
+ const auto *rhs{GetExpr(context_, expr)};
+ if (lhs && rhs) {
+ Tristate isDefined{semantics::IsDefinedAssignment(
+ lhs->GetType(), lhs->Rank(), rhs->GetType(), rhs->Rank())};
+ if (isDefined == Tristate::Yes) {
+ context_.Say(expr.source,
+ "Defined assignment statement is not allowed in a WORKDISTRIBUTE construct"_err_en_US);
+ }
+ }
+ return true;
+ }
+
+ bool Pre(const parser::Expr &expr) {
+ if (const auto *e{GetExpr(context_, expr)}) {
+ if (!e)
+ return false;
+ for (const Symbol &symbol : evaluate::CollectSymbols(*e)) {
+ const Symbol &root{GetAssociationRoot(symbol)};
+ if (IsFunction(root)) {
+ std::vector<std::string> attrs;
+ if (!IsElementalProcedure(root)) {
+ attrs.push_back("non-ELEMENTAL");
+ }
+ if (root.attrs().test(Attr::IMPURE)) {
+ attrs.push_back("IMPURE");
+ }
+ std::string attrsStr =
+ attrs.empty() ? "" : " " + llvm::join(attrs, ", ");
+ context_.Say(expr.source,
+ "User defined%s function '%s' is not allowed in a WORKDISTRIBUTE construct"_err_en_US,
+ attrsStr, root.name());
+ }
+ }
+ }
+ return false;
+ }
+
+private:
+ SemanticsContext &context_;
+ parser::CharBlock source_;
+};
+
// `OmpUnitedTaskDesignatorChecker` is used to check if the designator
// can appear within the TASK construct
class OmpUnitedTaskDesignatorChecker {
@@ -210,6 +268,41 @@ bool OmpStructureChecker::CheckAllowedClause(llvmOmpClause clause) {
return CheckAllowed(clause);
}
+void OmpStructureChecker::AnalyzeObject(const parser::OmpObject &object) {
+ if (std::holds_alternative<parser::Name>(object.u)) {
+ // Do not analyze common block names. The analyzer will flag an error
+ // on those.
+ return;
+ }
+ if (auto *symbol{GetObjectSymbol(object)}) {
+ // Eliminate certain kinds of symbols before running the analyzer to
+ // avoid confusing error messages. The analyzer assumes that the context
+ // of the object use is an expression, and some diagnostics are tailored
+ // to that.
+ if (symbol->has<DerivedTypeDetails>() || symbol->has<MiscDetails>()) {
+ // Type names, construct names, etc.
+ return;
+ }
+ if (auto *typeSpec{symbol->GetType()}) {
+ if (typeSpec->category() == DeclTypeSpec::Category::Character) {
+ // Don't pass character objects to the analyzer, it can emit somewhat
+ // cryptic errors (e.g. "'obj' is not an array"). Substrings are
+ // checked elsewhere in OmpStructureChecker.
+ return;
+ }
+ }
+ }
+ evaluate::ExpressionAnalyzer ea{context_};
+ auto restore{ea.AllowWholeAssumedSizeArray(true)};
+ common::visit([&](auto &&s) { ea.Analyze(s); }, object.u);
+}
+
+void OmpStructureChecker::AnalyzeObjects(const parser::OmpObjectList &objects) {
+ for (const parser::OmpObject &object : objects.v) {
+ AnalyzeObject(object);
+ }
+}
+
bool OmpStructureChecker::IsCloselyNestedRegion(const OmpDirectiveSet &set) {
// Definition of close nesting:
//
@@ -531,14 +624,6 @@ template <typename Checker> struct DirectiveSpellingVisitor {
checker_(GetDirName(x.t).source, Directive::OMPD_allocators);
return false;
}
- bool Pre(const parser::OmpAssumeDirective &x) {
- checker_(std::get<parser::Verbatim>(x.t).source, Directive::OMPD_assume);
- return false;
- }
- bool Pre(const parser::OmpEndAssumeDirective &x) {
- checker_(x.v.source, Directive::OMPD_assume);
- return false;
- }
bool Pre(const parser::OmpMetadirectiveDirective &x) {
checker_(
std::get<parser::Verbatim>(x.t).source, Directive::OMPD_metadirective);
@@ -729,7 +814,7 @@ void OmpStructureChecker::CheckTargetNest(const parser::OpenMPConstruct &c) {
parser::CharBlock source;
common::visit(
common::visitors{
- [&](const parser::OpenMPBlockConstruct &c) {
+ [&](const parser::OmpBlockConstruct &c) {
const parser::OmpDirectiveSpecification &beginSpec{c.BeginDir()};
source = beginSpec.DirName().source;
if (beginSpec.DirId() == llvm::omp::Directive::OMPD_target_data) {
@@ -779,12 +864,44 @@ void OmpStructureChecker::CheckTargetNest(const parser::OpenMPConstruct &c) {
}
}
-void OmpStructureChecker::Enter(const parser::OpenMPBlockConstruct &x) {
+void OmpStructureChecker::Enter(const parser::OmpBlockConstruct &x) {
const parser::OmpDirectiveSpecification &beginSpec{x.BeginDir()};
const std::optional<parser::OmpEndDirective> &endSpec{x.EndDir()};
const parser::Block &block{std::get<parser::Block>(x.t)};
PushContextAndClauseSets(beginSpec.DirName().source, beginSpec.DirId());
+
+ // Missing mandatory end block: this is checked in semantics because that
+ // makes it easier to control the error messages.
+ // The end block is mandatory when the construct is not applied to a strictly
+ // structured block (aka it is applied to a loosely structured block). In
+ // other words, the body doesn't contain exactly one parser::BlockConstruct.
+ auto isStrictlyStructuredBlock{[](const parser::Block &block) -> bool {
+ if (block.size() != 1) {
+ return false;
+ }
+ const parser::ExecutionPartConstruct &contents{block.front()};
+ auto *executableConstruct{
+ std::get_if<parser::ExecutableConstruct>(&contents.u)};
+ if (!executableConstruct) {
+ return false;
+ }
+ return std::holds_alternative<common::Indirection<parser::BlockConstruct>>(
+ executableConstruct->u);
+ }};
+ if (!endSpec && !isStrictlyStructuredBlock(block)) {
+ llvm::omp::Directive dirId{beginSpec.DirId()};
+ auto &msg{context_.Say(beginSpec.source,
+ "Expected OpenMP END %s directive"_err_en_US,
+ parser::ToUpperCaseLetters(getDirectiveName(dirId)))};
+ // ORDERED has two variants, so be explicit about which variant we think
+ // this is.
+ if (dirId == llvm::omp::Directive::OMPD_ordered) {
+ msg.Attach(
+ beginSpec.source, "The ORDERED directive is block-associated"_en_US);
+ }
+ }
+
if (llvm::omp::allTargetSet.test(GetContext().directive)) {
EnterDirectiveNest(TargetNest);
}
@@ -815,6 +932,12 @@ void OmpStructureChecker::Enter(const parser::OpenMPBlockConstruct &x) {
"TARGET construct with nested TEAMS region contains statements or "
"directives outside of the TEAMS construct"_err_en_US);
}
+ if (GetContext().directive == llvm::omp::Directive::OMPD_workdistribute &&
+ GetContextParent().directive != llvm::omp::Directive::OMPD_teams) {
+ context_.Say(x.BeginDir().DirName().source,
+ "%s region can only be strictly nested within TEAMS region"_err_en_US,
+ ContextDirectiveAsFortran());
+ }
}
CheckNoBranching(block, beginSpec.DirId(), beginSpec.source);
@@ -898,6 +1021,17 @@ void OmpStructureChecker::Enter(const parser::OpenMPBlockConstruct &x) {
HasInvalidWorksharingNesting(
beginSpec.source, llvm::omp::nestedWorkshareErrSet);
break;
+ case llvm::omp::OMPD_workdistribute:
+ if (!CurrentDirectiveIsNested()) {
+ context_.Say(beginSpec.source,
+ "A WORKDISTRIBUTE region must be nested inside TEAMS region only."_err_en_US);
+ }
+ CheckWorkdistributeBlockStmts(block, beginSpec.source);
+ break;
+ case llvm::omp::OMPD_teams_workdistribute:
+ case llvm::omp::OMPD_target_teams_workdistribute:
+ CheckWorkdistributeBlockStmts(block, beginSpec.source);
+ break;
case llvm::omp::Directive::OMPD_scope:
case llvm::omp::Directive::OMPD_single:
// TODO: This check needs to be extended while implementing nesting of
@@ -919,7 +1053,7 @@ void OmpStructureChecker::Enter(const parser::OpenMPBlockConstruct &x) {
}
void OmpStructureChecker::CheckMasterNesting(
- const parser::OpenMPBlockConstruct &x) {
+ const parser::OmpBlockConstruct &x) {
// A MASTER region may not be `closely nested` inside a worksharing, loop,
// task, taskloop, or atomic region.
// TODO: Expand the check to include `LOOP` construct as well when it is
@@ -948,7 +1082,7 @@ void OmpStructureChecker::Leave(const parser::OpenMPDeclarativeAssumes &) {
dirContext_.pop_back();
}
-void OmpStructureChecker::Leave(const parser::OpenMPBlockConstruct &) {
+void OmpStructureChecker::Leave(const parser::OmpBlockConstruct &) {
if (GetDirectiveNest(TargetBlockOnlyTeams)) {
ExitDirectiveNest(TargetBlockOnlyTeams);
}
@@ -1039,14 +1173,23 @@ void OmpStructureChecker::Leave(const parser::OmpBeginDirective &) {
void OmpStructureChecker::Enter(const parser::OpenMPSectionsConstruct &x) {
const auto &beginSectionsDir{
std::get<parser::OmpBeginSectionsDirective>(x.t)};
- const auto &endSectionsDir{std::get<parser::OmpEndSectionsDirective>(x.t)};
+ const auto &endSectionsDir{
+ std::get<std::optional<parser::OmpEndSectionsDirective>>(x.t)};
const auto &beginDir{
std::get<parser::OmpSectionsDirective>(beginSectionsDir.t)};
- const auto &endDir{std::get<parser::OmpSectionsDirective>(endSectionsDir.t)};
+ PushContextAndClauseSets(beginDir.source, beginDir.v);
+
+ if (!endSectionsDir) {
+ context_.Say(beginSectionsDir.source,
+ "Expected OpenMP END SECTIONS directive"_err_en_US);
+ // Following code assumes the option is present.
+ return;
+ }
+
+ const auto &endDir{std::get<parser::OmpSectionsDirective>(endSectionsDir->t)};
CheckMatching<parser::OmpSectionsDirective>(beginDir, endDir);
- PushContextAndClauseSets(beginDir.source, beginDir.v);
- AddEndDirectiveClauses(std::get<parser::OmpClauseList>(endSectionsDir.t));
+ AddEndDirectiveClauses(std::get<parser::OmpClauseList>(endSectionsDir->t));
const auto &sectionBlocks{std::get<std::list<parser::OpenMPConstruct>>(x.t)};
for (const parser::OpenMPConstruct &construct : sectionBlocks) {
@@ -2597,8 +2740,9 @@ void OmpStructureChecker::Leave(const parser::OmpClauseList &) {
void OmpStructureChecker::Enter(const parser::OmpClause &x) {
SetContextClause(x);
+ llvm::omp::Clause id{x.Id()};
// The visitors for these clauses do their own checks.
- switch (x.Id()) {
+ switch (id) {
case llvm::omp::Clause::OMPC_copyprivate:
case llvm::omp::Clause::OMPC_enter:
case llvm::omp::Clause::OMPC_lastprivate:
@@ -2612,7 +2756,7 @@ void OmpStructureChecker::Enter(const parser::OmpClause &x) {
// Named constants are OK to be used within 'shared' and 'firstprivate'
// clauses. The check for this happens a few lines below.
bool SharedOrFirstprivate = false;
- switch (x.Id()) {
+ switch (id) {
case llvm::omp::Clause::OMPC_shared:
case llvm::omp::Clause::OMPC_firstprivate:
SharedOrFirstprivate = true;
@@ -2622,6 +2766,7 @@ void OmpStructureChecker::Enter(const parser::OmpClause &x) {
}
if (const parser::OmpObjectList *objList{GetOmpObjectList(x)}) {
+ AnalyzeObjects(*objList);
SymbolSourceMap symbols;
GetSymbolsInObjectList(*objList, symbols);
for (const auto &[symbol, source] : symbols) {
@@ -2648,6 +2793,8 @@ CHECK_SIMPLE_CLAUSE(Final, OMPC_final)
CHECK_SIMPLE_CLAUSE(Flush, OMPC_flush)
CHECK_SIMPLE_CLAUSE(Full, OMPC_full)
CHECK_SIMPLE_CLAUSE(Grainsize, OMPC_grainsize)
+CHECK_SIMPLE_CLAUSE(GraphId, OMPC_graph_id)
+CHECK_SIMPLE_CLAUSE(GraphReset, OMPC_graph_reset)
CHECK_SIMPLE_CLAUSE(Holds, OMPC_holds)
CHECK_SIMPLE_CLAUSE(Inclusive, OMPC_inclusive)
CHECK_SIMPLE_CLAUSE(Initializer, OMPC_initializer)
@@ -3069,7 +3216,7 @@ void OmpStructureChecker::CheckReductionObjectTypes(
// r = 0; r = r + r2
// But it might be valid to use these with DECLARE REDUCTION.
// Assumed size is already caught elsewhere.
- bool cannotBeBuiltinReduction{evaluate::IsAssumedRank(*symbol)};
+ bool cannotBeBuiltinReduction{IsAssumedRank(*symbol)};
if (auto *type{symbol->GetType()}) {
const auto &scope{context_.FindScope(symbol->name())};
if (!IsReductionAllowedForType(
@@ -3352,9 +3499,14 @@ void OmpStructureChecker::Enter(const parser::OmpClause::Aligned &x) {
x.v, llvm::omp::OMPC_aligned, GetContext().clauseSource, context_)) {
auto &modifiers{OmpGetModifiers(x.v)};
if (auto *align{OmpGetUniqueModifier<parser::OmpAlignment>(modifiers)}) {
- if (const auto &v{GetIntValue(align->v)}; !v || *v <= 0) {
+ const auto &v{GetIntValue(align->v)};
+ if (!v || *v <= 0) {
context_.Say(OmpGetModifierSource(modifiers, align),
"The alignment value should be a constant positive integer"_err_en_US);
+ } else if (((*v) & (*v - 1)) != 0) {
+ context_.Warn(common::UsageWarning::OpenMPUsage,
+ OmpGetModifierSource(modifiers, align),
+ "Alignment is not a power of 2, Aligned clause will be ignored"_warn_en_US);
}
}
}
@@ -4463,7 +4615,7 @@ bool OmpStructureChecker::CheckTargetBlockOnlyTeams(
if (const auto *ompConstruct{
parser::Unwrap<parser::OpenMPConstruct>(*it)}) {
if (const auto *ompBlockConstruct{
- std::get_if<parser::OpenMPBlockConstruct>(&ompConstruct->u)}) {
+ std::get_if<parser::OmpBlockConstruct>(&ompConstruct->u)}) {
llvm::omp::Directive dirId{ompBlockConstruct->BeginDir().DirId()};
if (dirId == llvm::omp::Directive::OMPD_teams) {
nestedTeams = true;
@@ -4510,7 +4662,7 @@ void OmpStructureChecker::CheckWorkshareBlockStmts(
// 'Parallel' constructs
auto currentDir{llvm::omp::Directive::OMPD_unknown};
if (const auto *ompBlockConstruct{
- std::get_if<parser::OpenMPBlockConstruct>(&ompConstruct->u)}) {
+ std::get_if<parser::OmpBlockConstruct>(&ompConstruct->u)}) {
currentDir = ompBlockConstruct->BeginDir().DirId();
} else if (const auto *ompLoopConstruct{
std::get_if<parser::OpenMPLoopConstruct>(
@@ -4546,6 +4698,27 @@ void OmpStructureChecker::CheckWorkshareBlockStmts(
}
}
+void OmpStructureChecker::CheckWorkdistributeBlockStmts(
+ const parser::Block &block, parser::CharBlock source) {
+ unsigned version{context_.langOptions().OpenMPVersion};
+ unsigned since{60};
+ if (version < since)
+ context_.Say(source,
+ "WORKDISTRIBUTE construct is not allowed in %s, %s"_err_en_US,
+ ThisVersion(version), TryVersion(since));
+
+ OmpWorkdistributeBlockChecker ompWorkdistributeBlockChecker{context_, source};
+
+ for (auto it{block.begin()}; it != block.end(); ++it) {
+ if (parser::Unwrap<parser::AssignmentStmt>(*it)) {
+ parser::Walk(*it, ompWorkdistributeBlockChecker);
+ } else {
+ context_.Say(source,
+ "The structured block in a WORKDISTRIBUTE construct may consist of only SCALAR or ARRAY assignments"_err_en_US);
+ }
+ }
+}
+
void OmpStructureChecker::CheckIfContiguous(const parser::OmpObject &object) {
if (auto contig{IsContiguous(context_, object)}; contig && !*contig) {
const parser::Name *name{GetObjectName(object)};
diff --git a/flang/lib/Semantics/check-omp-structure.h b/flang/lib/Semantics/check-omp-structure.h
index fd77fed73acb..ce074f5f3f86 100644
--- a/flang/lib/Semantics/check-omp-structure.h
+++ b/flang/lib/Semantics/check-omp-structure.h
@@ -88,8 +88,8 @@ public:
void Leave(const parser::OpenMPAssumeConstruct &);
void Enter(const parser::OpenMPDeclarativeAssumes &);
void Leave(const parser::OpenMPDeclarativeAssumes &);
- void Enter(const parser::OpenMPBlockConstruct &);
- void Leave(const parser::OpenMPBlockConstruct &);
+ void Enter(const parser::OmpBlockConstruct &);
+ void Leave(const parser::OmpBlockConstruct &);
void Leave(const parser::OmpBeginDirective &);
void Enter(const parser::OmpEndDirective &);
void Leave(const parser::OmpEndDirective &);
@@ -167,6 +167,8 @@ private:
void CheckVariableListItem(const SymbolSourceMap &symbols);
void CheckDirectiveSpelling(
parser::CharBlock spelling, llvm::omp::Directive id);
+ void AnalyzeObject(const parser::OmpObject &object);
+ void AnalyzeObjects(const parser::OmpObjectList &objects);
void CheckMultipleOccurrence(semantics::UnorderedSymbolSet &listVars,
const std::list<parser::Name> &nameList, const parser::CharBlock &item,
const std::string &clauseName);
@@ -245,6 +247,7 @@ private:
llvmOmpClause clause, const parser::OmpObjectList &ompObjectList);
bool CheckTargetBlockOnlyTeams(const parser::Block &);
void CheckWorkshareBlockStmts(const parser::Block &, parser::CharBlock);
+ void CheckWorkdistributeBlockStmts(const parser::Block &, parser::CharBlock);
void CheckIteratorRange(const parser::OmpIteratorSpecifier &x);
void CheckIteratorModifier(const parser::OmpIterator &x);
@@ -312,7 +315,7 @@ private:
const parser::OmpReductionIdentifier &ident);
void CheckReductionModifier(const parser::OmpReductionModifier &);
void CheckLastprivateModifier(const parser::OmpLastprivateModifier &);
- void CheckMasterNesting(const parser::OpenMPBlockConstruct &x);
+ void CheckMasterNesting(const parser::OmpBlockConstruct &x);
void ChecksOnOrderedAsBlock();
void CheckBarrierNesting(const parser::OpenMPSimpleStandaloneConstruct &x);
void CheckScan(const parser::OpenMPSimpleStandaloneConstruct &x);
diff --git a/flang/lib/Semantics/check-select-rank.cpp b/flang/lib/Semantics/check-select-rank.cpp
index b227bbaaef4b..5dade2ca696c 100644
--- a/flang/lib/Semantics/check-select-rank.cpp
+++ b/flang/lib/Semantics/check-select-rank.cpp
@@ -32,7 +32,7 @@ void SelectRankConstructChecker::Leave(
const Symbol *saveSelSymbol{nullptr};
if (const auto selExpr{GetExprFromSelector(selectRankStmtSel)}) {
if (const Symbol * sel{evaluate::UnwrapWholeSymbolDataRef(*selExpr)}) {
- if (!evaluate::IsAssumedRank(*sel)) { // C1150
+ if (!semantics::IsAssumedRank(*sel)) { // C1150
context_.Say(parser::FindSourceLocation(selectRankStmtSel),
"Selector '%s' is not an assumed-rank array variable"_err_en_US,
sel->name().ToString());
diff --git a/flang/lib/Semantics/check-select-type.cpp b/flang/lib/Semantics/check-select-type.cpp
index 94d16a719277..b1b22c3e7c4a 100644
--- a/flang/lib/Semantics/check-select-type.cpp
+++ b/flang/lib/Semantics/check-select-type.cpp
@@ -252,7 +252,7 @@ void SelectTypeChecker::Enter(const parser::SelectTypeConstruct &construct) {
if (IsProcedure(*selector)) {
context_.Say(
selectTypeStmt.source, "Selector may not be a procedure"_err_en_US);
- } else if (evaluate::IsAssumedRank(*selector)) {
+ } else if (IsAssumedRank(*selector)) {
context_.Say(selectTypeStmt.source,
"Assumed-rank variable may only be used as actual argument"_err_en_US);
} else if (auto exprType{selector->GetType()}) {
diff --git a/flang/lib/Semantics/compute-offsets.cpp b/flang/lib/Semantics/compute-offsets.cpp
index 6d4fce2f00a6..1c48d33549a2 100644
--- a/flang/lib/Semantics/compute-offsets.cpp
+++ b/flang/lib/Semantics/compute-offsets.cpp
@@ -239,7 +239,9 @@ void ComputeOffsetsHelper::DoCommonBlock(Symbol &commonBlock) {
std::size_t minAlignment{0};
UnorderedSymbolSet previous;
for (auto object : details.objects()) {
- Symbol &symbol{*object};
+ // Allow for host association when the common block is
+ // OpenMP firstprivate.
+ Symbol &symbol{object->GetUltimate()};
auto errorSite{
commonBlock.name().empty() ? symbol.name() : commonBlock.name()};
if (std::size_t padding{DoSymbol(symbol.GetUltimate())}) {
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index d022378ce145..3f048ab6f7a4 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -2198,7 +2198,8 @@ MaybeExpr ExpressionAnalyzer::CheckStructureConstructor(
}
if (symbol) {
const semantics::Scope &innermost{context_.FindScope(exprSource)};
- if (auto msg{CheckAccessibleSymbol(innermost, *symbol)}) {
+ if (auto msg{CheckAccessibleSymbol(
+ innermost, *symbol, /*inStructureConstructor=*/true)}) {
Say(exprSource, std::move(*msg));
}
if (checkConflicts) {
@@ -3699,7 +3700,10 @@ static MaybeExpr NumericUnaryHelper(ExpressionAnalyzer &context,
analyzer.CheckForNullPointer();
analyzer.CheckForAssumedRank();
if (opr == NumericOperator::Add) {
- return analyzer.MoveExpr(0);
+ // +x -> (x), not a bare x, because the bounds of the argument must
+ // not be exposed to allocatable assignments or structure constructor
+ // components.
+ return Parenthesize(analyzer.MoveExpr(0));
} else {
return Negation(context.GetContextualMessages(), analyzer.MoveExpr(0));
}
@@ -3783,10 +3787,9 @@ MaybeExpr NumericBinaryHelper(
analyzer.CheckForNullPointer();
analyzer.CheckForAssumedRank();
analyzer.CheckConformance();
- constexpr bool canBeUnsigned{opr != NumericOperator::Power};
- return NumericOperation<OPR, canBeUnsigned>(
- context.GetContextualMessages(), analyzer.MoveExpr(0),
- analyzer.MoveExpr(1), context.GetDefaultKind(TypeCategory::Real));
+ return NumericOperation<OPR>(context.GetContextualMessages(),
+ analyzer.MoveExpr(0), analyzer.MoveExpr(1),
+ context.GetDefaultKind(TypeCategory::Real));
} else {
return analyzer.TryDefinedOp(AsFortran(opr),
"Operands of %s must be numeric; have %s and %s"_err_en_US);
@@ -4632,7 +4635,7 @@ bool ArgumentAnalyzer::CheckForNullPointer(const char *where) {
bool ArgumentAnalyzer::CheckForAssumedRank(const char *where) {
for (const std::optional<ActualArgument> &arg : actuals_) {
- if (arg && IsAssumedRank(arg->UnwrapExpr())) {
+ if (arg && semantics::IsAssumedRank(arg->UnwrapExpr())) {
context_.Say(source_,
"An assumed-rank dummy argument is not allowed %s"_err_en_US, where);
fatalErrors_ = true;
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index e767bf840957..5508ba837894 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -159,7 +159,7 @@ bool PointerAssignmentChecker::CheckLeftHandSide(const SomeExpr &lhs) {
msg->Attach(std::move(whyNot->set_severity(parser::Severity::Because)));
}
return false;
- } else if (evaluate::IsAssumedRank(lhs)) {
+ } else if (IsAssumedRank(lhs)) {
Say("The left-hand side of a pointer assignment must not be an assumed-rank dummy argument"_err_en_US);
return false;
} else if (evaluate::ExtractCoarrayRef(lhs)) { // F'2023 C1027
diff --git a/flang/lib/Semantics/resolve-directives.cpp b/flang/lib/Semantics/resolve-directives.cpp
index 96d95162beb7..1b7718d1314d 100644
--- a/flang/lib/Semantics/resolve-directives.cpp
+++ b/flang/lib/Semantics/resolve-directives.cpp
@@ -29,7 +29,6 @@
#include "llvm/Support/Debug.h"
#include <list>
#include <map>
-#include <sstream>
template <typename T>
static Fortran::semantics::Scope *GetScope(
@@ -61,6 +60,13 @@ protected:
parser::OmpDefaultmapClause::ImplicitBehavior>
defaultMap;
+ std::optional<Symbol::Flag> FindSymbolWithDSA(const Symbol &symbol) {
+ if (auto it{objectWithDSA.find(&symbol)}; it != objectWithDSA.end()) {
+ return it->second;
+ }
+ return std::nullopt;
+ }
+
bool withinConstruct{false};
std::int64_t associatedLoopLevel{0};
};
@@ -75,10 +81,19 @@ protected:
: std::make_optional<DirContext>(dirContext_.back());
}
void PushContext(const parser::CharBlock &source, T dir, Scope &scope) {
- dirContext_.emplace_back(source, dir, scope);
+ if constexpr (std::is_same_v<T, llvm::acc::Directive>) {
+ dirContext_.emplace_back(source, dir, scope);
+ if (std::size_t size{dirContext_.size()}; size > 1) {
+ std::size_t lastIndex{size - 1};
+ dirContext_[lastIndex].defaultDSA =
+ dirContext_[lastIndex - 1].defaultDSA;
+ }
+ } else {
+ dirContext_.emplace_back(source, dir, scope);
+ }
}
void PushContext(const parser::CharBlock &source, T dir) {
- dirContext_.emplace_back(source, dir, context_.FindScope(source));
+ PushContext(source, dir, context_.FindScope(source));
}
void PopContext() { dirContext_.pop_back(); }
void SetContextDirectiveSource(parser::CharBlock &dir) {
@@ -100,9 +115,21 @@ protected:
AddToContextObjectWithDSA(symbol, flag, GetContext());
}
bool IsObjectWithDSA(const Symbol &symbol) {
- auto it{GetContext().objectWithDSA.find(&symbol)};
- return it != GetContext().objectWithDSA.end();
+ return GetContext().FindSymbolWithDSA(symbol).has_value();
}
+ bool IsObjectWithVisibleDSA(const Symbol &symbol) {
+ for (std::size_t i{dirContext_.size()}; i != 0; i--) {
+ if (dirContext_[i - 1].FindSymbolWithDSA(symbol).has_value()) {
+ return true;
+ }
+ }
+ return false;
+ }
+
+ bool WithinConstruct() {
+ return !dirContext_.empty() && GetContext().withinConstruct;
+ }
+
void SetContextAssociatedLoopLevel(std::int64_t level) {
GetContext().associatedLoopLevel = level;
}
@@ -277,6 +304,12 @@ public:
return false;
}
+ bool Pre(const parser::AccClause::Reduction &x) {
+ const auto &objectList{std::get<parser::AccObjectList>(x.v.t)};
+ ResolveAccObjectList(objectList, Symbol::Flag::AccReduction);
+ return false;
+ }
+
void Post(const parser::Name &);
private:
@@ -384,8 +417,8 @@ public:
}
void Post(const parser::OmpMetadirectiveDirective &) { PopContext(); }
- bool Pre(const parser::OpenMPBlockConstruct &);
- void Post(const parser::OpenMPBlockConstruct &);
+ bool Pre(const parser::OmpBlockConstruct &);
+ void Post(const parser::OmpBlockConstruct &);
void Post(const parser::OmpBeginDirective &x) {
GetContext().withinConstruct = true;
@@ -531,6 +564,9 @@ public:
bool Pre(const parser::OpenMPDeclarativeAllocate &);
void Post(const parser::OpenMPDeclarativeAllocate &) { PopContext(); }
+ bool Pre(const parser::OpenMPAssumeConstruct &);
+ void Post(const parser::OpenMPAssumeConstruct &) { PopContext(); }
+
bool Pre(const parser::OpenMPAtomicConstruct &);
void Post(const parser::OpenMPAtomicConstruct &) { PopContext(); }
@@ -820,7 +856,23 @@ public:
const parser::OmpClause *GetAssociatedClause() { return associatedClause; }
private:
- std::int64_t GetAssociatedLoopLevelFromClauses(const parser::OmpClauseList &);
+ /// Given a vector of loop levels and a vector of corresponding clauses find
+ /// the largest loop level and set the associated loop level to the found
+ /// maximum. This is used for error handling to ensure that the number of
+ /// affected loops is not larger that the number of available loops.
+ std::int64_t SetAssociatedMaxClause(llvm::SmallVector<std::int64_t> &,
+ llvm::SmallVector<const parser::OmpClause *> &);
+ std::int64_t GetNumAffectedLoopsFromLoopConstruct(
+ const parser::OpenMPLoopConstruct &);
+ void CollectNumAffectedLoopsFromLoopConstruct(
+ const parser::OpenMPLoopConstruct &, llvm::SmallVector<std::int64_t> &,
+ llvm::SmallVector<const parser::OmpClause *> &);
+ void CollectNumAffectedLoopsFromInnerLoopContruct(
+ const parser::OpenMPLoopConstruct &, llvm::SmallVector<std::int64_t> &,
+ llvm::SmallVector<const parser::OmpClause *> &);
+ void CollectNumAffectedLoopsFromClauses(const parser::OmpClauseList &,
+ llvm::SmallVector<std::int64_t> &,
+ llvm::SmallVector<const parser::OmpClause *> &);
Symbol::Flags dataSharingAttributeFlags{Symbol::Flag::OmpShared,
Symbol::Flag::OmpPrivate, Symbol::Flag::OmpFirstPrivate,
@@ -1570,10 +1622,10 @@ void AccAttributeVisitor::Post(const parser::AccDefaultClause &x) {
// and adjust the symbol for each Name if necessary
void AccAttributeVisitor::Post(const parser::Name &name) {
auto *symbol{name.symbol};
- if (symbol && !dirContext_.empty() && GetContext().withinConstruct) {
+ if (symbol && WithinConstruct()) {
symbol = &symbol->GetUltimate();
if (!symbol->owner().IsDerivedType() && !symbol->has<ProcEntityDetails>() &&
- !symbol->has<SubprogramDetails>() && !IsObjectWithDSA(*symbol)) {
+ !symbol->has<SubprogramDetails>() && !IsObjectWithVisibleDSA(*symbol)) {
if (Symbol * found{currScope().FindSymbol(name.source)}) {
if (symbol != found) {
name.symbol = found; // adjust the symbol within region
@@ -1723,7 +1775,7 @@ static std::string ScopeSourcePos(const Fortran::semantics::Scope &scope);
#endif
-bool OmpAttributeVisitor::Pre(const parser::OpenMPBlockConstruct &x) {
+bool OmpAttributeVisitor::Pre(const parser::OmpBlockConstruct &x) {
const parser::OmpDirectiveSpecification &dirSpec{x.BeginDir()};
llvm::omp::Directive dirId{dirSpec.DirId()};
switch (dirId) {
@@ -1740,10 +1792,13 @@ bool OmpAttributeVisitor::Pre(const parser::OpenMPBlockConstruct &x) {
case llvm::omp::Directive::OMPD_task:
case llvm::omp::Directive::OMPD_taskgroup:
case llvm::omp::Directive::OMPD_teams:
+ case llvm::omp::Directive::OMPD_workdistribute:
case llvm::omp::Directive::OMPD_workshare:
case llvm::omp::Directive::OMPD_parallel_workshare:
case llvm::omp::Directive::OMPD_target_teams:
+ case llvm::omp::Directive::OMPD_target_teams_workdistribute:
case llvm::omp::Directive::OMPD_target_parallel:
+ case llvm::omp::Directive::OMPD_teams_workdistribute:
PushContext(dirSpec.source, dirId);
break;
default:
@@ -1759,7 +1814,7 @@ bool OmpAttributeVisitor::Pre(const parser::OpenMPBlockConstruct &x) {
return true;
}
-void OmpAttributeVisitor::Post(const parser::OpenMPBlockConstruct &x) {
+void OmpAttributeVisitor::Post(const parser::OmpBlockConstruct &x) {
const parser::OmpDirectiveSpecification &dirSpec{x.BeginDir()};
llvm::omp::Directive dirId{dirSpec.DirId()};
switch (dirId) {
@@ -1773,9 +1828,12 @@ void OmpAttributeVisitor::Post(const parser::OpenMPBlockConstruct &x) {
case llvm::omp::Directive::OMPD_target:
case llvm::omp::Directive::OMPD_task:
case llvm::omp::Directive::OMPD_teams:
+ case llvm::omp::Directive::OMPD_workdistribute:
case llvm::omp::Directive::OMPD_parallel_workshare:
case llvm::omp::Directive::OMPD_target_teams:
- case llvm::omp::Directive::OMPD_target_parallel: {
+ case llvm::omp::Directive::OMPD_target_parallel:
+ case llvm::omp::Directive::OMPD_target_teams_workdistribute:
+ case llvm::omp::Directive::OMPD_teams_workdistribute: {
bool hasPrivate;
for (const auto *allocName : allocateNames_) {
hasPrivate = false;
@@ -1826,7 +1884,6 @@ bool OmpAttributeVisitor::Pre(
bool OmpAttributeVisitor::Pre(const parser::OpenMPLoopConstruct &x) {
const auto &beginLoopDir{std::get<parser::OmpBeginLoopDirective>(x.t)};
const auto &beginDir{std::get<parser::OmpLoopDirective>(beginLoopDir.t)};
- const auto &clauseList{std::get<parser::OmpClauseList>(beginLoopDir.t)};
switch (beginDir.v) {
case llvm::omp::Directive::OMPD_distribute:
case llvm::omp::Directive::OMPD_distribute_parallel_do:
@@ -1877,7 +1934,7 @@ bool OmpAttributeVisitor::Pre(const parser::OpenMPLoopConstruct &x) {
beginDir.v == llvm::omp::Directive::OMPD_target_loop)
IssueNonConformanceWarning(beginDir.v, beginDir.source, 52);
ClearDataSharingAttributeObjects();
- SetContextAssociatedLoopLevel(GetAssociatedLoopLevelFromClauses(clauseList));
+ SetContextAssociatedLoopLevel(GetNumAffectedLoopsFromLoopConstruct(x));
if (beginDir.v == llvm::omp::Directive::OMPD_do) {
auto &optLoopCons = std::get<std::optional<parser::NestedConstruct>>(x.t);
@@ -1891,7 +1948,7 @@ bool OmpAttributeVisitor::Pre(const parser::OpenMPLoopConstruct &x) {
}
}
PrivatizeAssociatedLoopIndexAndCheckLoopLevel(x);
- ordCollapseLevel = GetAssociatedLoopLevelFromClauses(clauseList) + 1;
+ ordCollapseLevel = GetNumAffectedLoopsFromLoopConstruct(x) + 1;
return true;
}
@@ -1950,7 +2007,7 @@ void OmpAttributeVisitor::ResolveSeqLoopIndexInParallelOrTaskConstruct(
// till OpenMP-5.0 standard.
// In above both cases we skip the privatization of iteration variables.
bool OmpAttributeVisitor::Pre(const parser::DoConstruct &x) {
- if (!dirContext_.empty() && GetContext().withinConstruct) {
+ if (WithinConstruct()) {
llvm::SmallVector<const parser::Name *> ivs;
if (x.IsDoNormal()) {
const parser::Name *iv{GetLoopIndex(x)};
@@ -1979,44 +2036,111 @@ bool OmpAttributeVisitor::Pre(const parser::DoConstruct &x) {
return true;
}
-std::int64_t OmpAttributeVisitor::GetAssociatedLoopLevelFromClauses(
- const parser::OmpClauseList &x) {
- std::int64_t orderedLevel{0};
- std::int64_t collapseLevel{0};
+static bool isSizesClause(const parser::OmpClause *clause) {
+ return std::holds_alternative<parser::OmpClause::Sizes>(clause->u);
+}
+
+std::int64_t OmpAttributeVisitor::SetAssociatedMaxClause(
+ llvm::SmallVector<std::int64_t> &levels,
+ llvm::SmallVector<const parser::OmpClause *> &clauses) {
+
+ // Find the tile level to ensure that the COLLAPSE clause value
+ // does not exeed the number of tiled loops.
+ std::int64_t tileLevel = 0;
+ for (auto [level, clause] : llvm::zip_equal(levels, clauses))
+ if (isSizesClause(clause))
+ tileLevel = level;
+
+ std::int64_t maxLevel = 1;
+ const parser::OmpClause *maxClause = nullptr;
+ for (auto [level, clause] : llvm::zip_equal(levels, clauses)) {
+ if (tileLevel > 0 && tileLevel < level) {
+ context_.Say(clause->source,
+ "The value of the parameter in the COLLAPSE clause must"
+ " not be larger than the number of the number of tiled loops"
+ " because collapse currently is limited to independent loop"
+ " iterations."_err_en_US);
+ return 1;
+ }
+
+ if (level > maxLevel) {
+ maxLevel = level;
+ maxClause = clause;
+ }
+ }
+ if (maxClause)
+ SetAssociatedClause(maxClause);
+ return maxLevel;
+}
+
+std::int64_t OmpAttributeVisitor::GetNumAffectedLoopsFromLoopConstruct(
+ const parser::OpenMPLoopConstruct &x) {
+ llvm::SmallVector<std::int64_t> levels;
+ llvm::SmallVector<const parser::OmpClause *> clauses;
+
+ CollectNumAffectedLoopsFromLoopConstruct(x, levels, clauses);
+ return SetAssociatedMaxClause(levels, clauses);
+}
+
+void OmpAttributeVisitor::CollectNumAffectedLoopsFromLoopConstruct(
+ const parser::OpenMPLoopConstruct &x,
+ llvm::SmallVector<std::int64_t> &levels,
+ llvm::SmallVector<const parser::OmpClause *> &clauses) {
+ const auto &beginLoopDir{std::get<parser::OmpBeginLoopDirective>(x.t)};
+ const auto &clauseList{std::get<parser::OmpClauseList>(beginLoopDir.t)};
+
+ CollectNumAffectedLoopsFromClauses(clauseList, levels, clauses);
+ CollectNumAffectedLoopsFromInnerLoopContruct(x, levels, clauses);
+}
+
+void OmpAttributeVisitor::CollectNumAffectedLoopsFromInnerLoopContruct(
+ const parser::OpenMPLoopConstruct &x,
+ llvm::SmallVector<std::int64_t> &levels,
+ llvm::SmallVector<const parser::OmpClause *> &clauses) {
- const parser::OmpClause *ordClause{nullptr};
- const parser::OmpClause *collClause{nullptr};
+ const auto &nestedOptional =
+ std::get<std::optional<parser::NestedConstruct>>(x.t);
+ assert(nestedOptional.has_value() &&
+ "Expected a DoConstruct or OpenMPLoopConstruct");
+ const auto *innerConstruct =
+ std::get_if<common::Indirection<parser::OpenMPLoopConstruct>>(
+ &(nestedOptional.value()));
+ if (innerConstruct) {
+ CollectNumAffectedLoopsFromLoopConstruct(
+ innerConstruct->value(), levels, clauses);
+ }
+}
+
+void OmpAttributeVisitor::CollectNumAffectedLoopsFromClauses(
+ const parser::OmpClauseList &x, llvm::SmallVector<std::int64_t> &levels,
+ llvm::SmallVector<const parser::OmpClause *> &clauses) {
for (const auto &clause : x.v) {
- if (const auto *orderedClause{
+ if (const auto oclause{
std::get_if<parser::OmpClause::Ordered>(&clause.u)}) {
- if (const auto v{EvaluateInt64(context_, orderedClause->v)}) {
- orderedLevel = *v;
+ std::int64_t level = 0;
+ if (const auto v{EvaluateInt64(context_, oclause->v)}) {
+ level = *v;
}
- ordClause = &clause;
+ levels.push_back(level);
+ clauses.push_back(&clause);
}
- if (const auto *collapseClause{
+
+ if (const auto cclause{
std::get_if<parser::OmpClause::Collapse>(&clause.u)}) {
- if (const auto v{EvaluateInt64(context_, collapseClause->v)}) {
- collapseLevel = *v;
+ std::int64_t level = 0;
+ if (const auto v{EvaluateInt64(context_, cclause->v)}) {
+ level = *v;
}
- collClause = &clause;
+ levels.push_back(level);
+ clauses.push_back(&clause);
}
- }
- if (orderedLevel && (!collapseLevel || orderedLevel >= collapseLevel)) {
- SetAssociatedClause(ordClause);
- return orderedLevel;
- } else if (!orderedLevel && collapseLevel) {
- SetAssociatedClause(collClause);
- return collapseLevel;
- } else {
- SetAssociatedClause(nullptr);
+ if (const auto tclause{std::get_if<parser::OmpClause::Sizes>(&clause.u)}) {
+ levels.push_back(tclause->v.size());
+ clauses.push_back(&clause);
+ }
}
- // orderedLevel < collapseLevel is an error handled in structural
- // checks
-
- return 1; // default is outermost loop
}
// 2.15.1.1 Data-sharing Attribute Rules - Predetermined
@@ -2048,10 +2172,21 @@ void OmpAttributeVisitor::PrivatizeAssociatedLoopIndexAndCheckLoopLevel(
const parser::OmpClause *clause{GetAssociatedClause()};
bool hasCollapseClause{
clause ? (clause->Id() == llvm::omp::OMPC_collapse) : false};
+ const parser::OpenMPLoopConstruct *innerMostLoop = &x;
+ const parser::NestedConstruct *innerMostNest = nullptr;
+ while (auto &optLoopCons{
+ std::get<std::optional<parser::NestedConstruct>>(innerMostLoop->t)}) {
+ innerMostNest = &(optLoopCons.value());
+ if (const auto *innerLoop{
+ std::get_if<common::Indirection<parser::OpenMPLoopConstruct>>(
+ innerMostNest)}) {
+ innerMostLoop = &(innerLoop->value());
+ } else
+ break;
+ }
- auto &optLoopCons = std::get<std::optional<parser::NestedConstruct>>(x.t);
- if (optLoopCons.has_value()) {
- if (const auto &outer{std::get_if<parser::DoConstruct>(&*optLoopCons)}) {
+ if (innerMostNest) {
+ if (const auto &outer{std::get_if<parser::DoConstruct>(innerMostNest)}) {
for (const parser::DoConstruct *loop{&*outer}; loop && level > 0;
--level) {
if (loop->IsDoConcurrent()) {
@@ -2087,7 +2222,7 @@ void OmpAttributeVisitor::PrivatizeAssociatedLoopIndexAndCheckLoopLevel(
CheckAssocLoopLevel(level, GetAssociatedClause());
} else if (const auto &loop{std::get_if<
common::Indirection<parser::OpenMPLoopConstruct>>(
- &*optLoopCons)}) {
+ innerMostNest)}) {
auto &beginDirective =
std::get<parser::OmpBeginLoopDirective>(loop->value().t);
auto &beginLoopDirective =
@@ -2214,6 +2349,11 @@ bool OmpAttributeVisitor::Pre(const parser::OpenMPDeclarativeAllocate &x) {
return false;
}
+bool OmpAttributeVisitor::Pre(const parser::OpenMPAssumeConstruct &x) {
+ PushContext(x.source, llvm::omp::Directive::OMPD_assume);
+ return true;
+}
+
bool OmpAttributeVisitor::Pre(const parser::OpenMPAtomicConstruct &x) {
PushContext(x.source, llvm::omp::Directive::OMPD_atomic);
return true;
@@ -2455,7 +2595,7 @@ static bool IsTargetCaptureImplicitlyFirstprivatizeable(const Symbol &symbol,
// investigate the flags we can intermix with.
if (!(dsa & (dataSharingAttributeFlags | dataMappingAttributeFlags))
.none() ||
- !checkSym.flags().none() || semantics::IsAssumedShape(checkSym) ||
+ !checkSym.flags().none() || IsAssumedShape(checkSym) ||
semantics::IsAllocatableOrPointer(checkSym)) {
return false;
}
@@ -2476,14 +2616,15 @@ static bool IsTargetCaptureImplicitlyFirstprivatizeable(const Symbol &symbol,
return false;
};
- if (checkSymbol(symbol)) {
- const auto *hostAssoc{symbol.detailsIf<HostAssocDetails>()};
- if (hostAssoc) {
- return checkSymbol(hostAssoc->symbol());
- }
- return true;
- }
- return false;
+ return common::visit(
+ common::visitors{
+ [&](const UseDetails &x) -> bool { return checkSymbol(x.symbol()); },
+ [&](const HostAssocDetails &x) -> bool {
+ return checkSymbol(x.symbol());
+ },
+ [&](const auto &) -> bool { return checkSymbol(symbol); },
+ },
+ symbol.details());
}
void OmpAttributeVisitor::CreateImplicitSymbols(const Symbol *symbol) {
@@ -2671,7 +2812,7 @@ void OmpAttributeVisitor::CreateImplicitSymbols(const Symbol *symbol) {
void OmpAttributeVisitor::Post(const parser::Name &name) {
auto *symbol{name.symbol};
- if (symbol && !dirContext_.empty() && GetContext().withinConstruct) {
+ if (symbol && WithinConstruct()) {
if (IsPrivatizable(symbol) && !IsObjectWithDSA(*symbol)) {
// TODO: create a separate function to go through the rules for
// predetermined, explicitly determined, and implicitly
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 5808b4b3cc4f..077bee930675 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -488,6 +488,10 @@ public:
// Result symbol
Symbol *resultSymbol{nullptr};
bool inFunctionStmt{false}; // true between Pre/Post of FunctionStmt
+ // Functions with previous implicitly-typed references get those types
+ // checked against their later definitions.
+ const DeclTypeSpec *previousImplicitType{nullptr};
+ SourceName previousName;
};
// Completes the definition of the top function's result.
@@ -642,12 +646,18 @@ public:
}
if (symbol->CanReplaceDetails(details)) {
// update the existing symbol
- CheckDuplicatedAttrs(name, *symbol, attrs);
- SetExplicitAttrs(*symbol, attrs);
if constexpr (std::is_same_v<SubprogramDetails, D>) {
// Dummy argument defined by explicit interface?
details.set_isDummy(IsDummy(*symbol));
+ if (symbol->has<ProcEntityDetails>()) {
+ // Bare "EXTERNAL" dummy replaced with explicit INTERFACE
+ context().Warn(common::LanguageFeature::RedundantAttribute, name,
+ "Dummy argument '%s' was declared earlier as EXTERNAL"_warn_en_US,
+ name);
+ }
}
+ CheckDuplicatedAttrs(name, *symbol, attrs);
+ SetExplicitAttrs(*symbol, attrs);
symbol->set_details(std::move(details));
return *symbol;
} else if constexpr (std::is_same_v<UnknownDetails, D>) {
@@ -943,7 +953,7 @@ private:
// Edits an existing symbol created for earlier calls to a subprogram or ENTRY
// so that it can be replaced by a later definition.
bool HandlePreviousCalls(const parser::Name &, Symbol &, Symbol::Flag);
- void CheckExtantProc(const parser::Name &, Symbol::Flag);
+ const Symbol *CheckExtantProc(const parser::Name &, Symbol::Flag);
// Create a subprogram symbol in the current scope and push a new scope.
Symbol &PushSubprogramScope(const parser::Name &, Symbol::Flag,
const parser::LanguageBindingSpec * = nullptr,
@@ -1466,7 +1476,7 @@ class OmpVisitor : public virtual DeclarationVisitor {
public:
void AddOmpSourceRange(const parser::CharBlock &);
- static bool NeedsScope(const parser::OpenMPBlockConstruct &);
+ static bool NeedsScope(const parser::OmpBlockConstruct &);
static bool NeedsScope(const parser::OmpClause &);
bool Pre(const parser::OmpMetadirectiveDirective &x) { //
@@ -1483,8 +1493,8 @@ public:
AddOmpSourceRange(x.source);
return true;
}
- bool Pre(const parser::OpenMPBlockConstruct &);
- void Post(const parser::OpenMPBlockConstruct &);
+ bool Pre(const parser::OmpBlockConstruct &);
+ void Post(const parser::OmpBlockConstruct &);
bool Pre(const parser::OmpBeginDirective &x) {
AddOmpSourceRange(x.source);
// Manually resolve names in CRITICAL directives. This is because these
@@ -1729,7 +1739,7 @@ private:
const parser::OmpMetadirectiveDirective *metaDirective_{nullptr};
};
-bool OmpVisitor::NeedsScope(const parser::OpenMPBlockConstruct &x) {
+bool OmpVisitor::NeedsScope(const parser::OmpBlockConstruct &x) {
switch (x.BeginDir().DirId()) {
case llvm::omp::Directive::OMPD_master:
case llvm::omp::Directive::OMPD_ordered:
@@ -1750,14 +1760,14 @@ void OmpVisitor::AddOmpSourceRange(const parser::CharBlock &source) {
currScope().AddSourceRange(source);
}
-bool OmpVisitor::Pre(const parser::OpenMPBlockConstruct &x) {
+bool OmpVisitor::Pre(const parser::OmpBlockConstruct &x) {
if (NeedsScope(x)) {
PushScope(Scope::Kind::OtherConstruct, nullptr);
}
return true;
}
-void OmpVisitor::Post(const parser::OpenMPBlockConstruct &x) {
+void OmpVisitor::Post(const parser::OmpBlockConstruct &x) {
if (NeedsScope(x)) {
PopScope();
}
@@ -2691,11 +2701,24 @@ void ArraySpecVisitor::PostAttrSpec() {
FuncResultStack::~FuncResultStack() { CHECK(stack_.empty()); }
+// True when either type is absent, or if they are both present and are
+// equivalent for interface compatibility purposes.
+static bool TypesMismatchIfNonNull(
+ const DeclTypeSpec *type1, const DeclTypeSpec *type2) {
+ if (auto t1{evaluate::DynamicType::From(type1)}) {
+ if (auto t2{evaluate::DynamicType::From(type2)}) {
+ return !t1->IsEquivalentTo(*t2);
+ }
+ }
+ return false;
+}
+
void FuncResultStack::CompleteFunctionResultType() {
// If the function has a type in the prefix, process it now.
FuncInfo *info{Top()};
- if (info && &info->scope == &scopeHandler_.currScope()) {
- if (info->parsedType && info->resultSymbol) {
+ if (info && &info->scope == &scopeHandler_.currScope() &&
+ info->resultSymbol) {
+ if (info->parsedType) {
scopeHandler_.messageHandler().set_currStmtSource(info->source);
if (const auto *type{
scopeHandler_.ProcessTypeSpec(*info->parsedType, true)}) {
@@ -2712,6 +2735,16 @@ void FuncResultStack::CompleteFunctionResultType() {
}
info->parsedType = nullptr;
}
+ if (TypesMismatchIfNonNull(
+ info->resultSymbol->GetType(), info->previousImplicitType)) {
+ scopeHandler_
+ .Say(info->resultSymbol->name(),
+ "Function '%s' has a result type that differs from the implicit type it obtained in a previous reference"_err_en_US,
+ info->previousName)
+ .Attach(info->previousName,
+ "Previous reference implicitly typed as %s\n"_en_US,
+ info->previousImplicitType->AsFortran());
+ }
}
}
@@ -4761,9 +4794,7 @@ void SubprogramVisitor::Post(const parser::FunctionStmt &stmt) {
if (info.resultName && !distinctResultName) {
context().Warn(common::UsageWarning::HomonymousResult,
info.resultName->source,
- "The function name should not appear in RESULT; references to '%s' "
- "inside the function will be considered as references to the "
- "result only"_warn_en_US,
+ "The function name should not appear in RESULT; references to '%s' inside the function will be considered as references to the result only"_warn_en_US,
name.source);
// RESULT name was ignored above, the only side effect from doing so will be
// the inability to make recursive calls. The related parser::Name is still
@@ -5074,8 +5105,7 @@ bool SubprogramVisitor::BeginSubprogram(const parser::Name &name,
if (hasModulePrefix && !currScope().IsModule() &&
!currScope().IsSubmodule()) { // C1547
Say(name,
- "'%s' is a MODULE procedure which must be declared within a "
- "MODULE or SUBMODULE"_err_en_US);
+ "'%s' is a MODULE procedure which must be declared within a MODULE or SUBMODULE"_err_en_US);
// Don't return here because it can be useful to have the scope set for
// other semantic checks run before we print the errors
isValid = false;
@@ -5196,9 +5226,10 @@ bool SubprogramVisitor::HandlePreviousCalls(
}
}
-void SubprogramVisitor::CheckExtantProc(
+const Symbol *SubprogramVisitor::CheckExtantProc(
const parser::Name &name, Symbol::Flag subpFlag) {
- if (auto *prev{FindSymbol(name)}) {
+ Symbol *prev{FindSymbol(name)};
+ if (prev) {
if (IsDummy(*prev)) {
} else if (auto *entity{prev->detailsIf<EntityDetails>()};
IsPointer(*prev) && entity && !entity->type()) {
@@ -5210,12 +5241,15 @@ void SubprogramVisitor::CheckExtantProc(
SayAlreadyDeclared(name, *prev);
}
}
+ return prev;
}
Symbol &SubprogramVisitor::PushSubprogramScope(const parser::Name &name,
Symbol::Flag subpFlag, const parser::LanguageBindingSpec *bindingSpec,
bool hasModulePrefix) {
Symbol *symbol{GetSpecificFromGeneric(name)};
+ const DeclTypeSpec *previousImplicitType{nullptr};
+ SourceName previousName;
if (!symbol) {
if (bindingSpec && currScope().IsGlobal() &&
std::get<std::optional<parser::ScalarDefaultCharConstantExpr>>(
@@ -5228,14 +5262,25 @@ Symbol &SubprogramVisitor::PushSubprogramScope(const parser::Name &name,
&MakeSymbol(context().GetTempName(currScope()), Attrs{},
MiscDetails{MiscDetails::Kind::ScopeName}));
}
- CheckExtantProc(name, subpFlag);
+ if (const Symbol *previous{CheckExtantProc(name, subpFlag)}) {
+ if (previous->test(Symbol::Flag::Function) &&
+ previous->test(Symbol::Flag::Implicit)) {
+ // Function was implicitly typed in previous compilation unit.
+ previousImplicitType = previous->GetType();
+ previousName = previous->name();
+ }
+ }
symbol = &MakeSymbol(name, SubprogramDetails{});
}
symbol->ReplaceName(name.source);
symbol->set(subpFlag);
PushScope(Scope::Kind::Subprogram, symbol);
if (subpFlag == Symbol::Flag::Function) {
- funcResultStack().Push(currScope(), name.source);
+ auto &funcResultTop{funcResultStack().Push(currScope(), name.source)};
+ funcResultTop.previousImplicitType = previousImplicitType;
+ ;
+ funcResultTop.previousName = previousName;
+ ;
}
if (inInterfaceBlock()) {
auto &details{symbol->get<SubprogramDetails>()};
@@ -7913,7 +7958,7 @@ void ConstructVisitor::Post(const parser::AssociateStmt &x) {
if (ExtractCoarrayRef(expr)) { // C1103
Say("Selector must not be a coindexed object"_err_en_US);
}
- if (evaluate::IsAssumedRank(expr)) {
+ if (IsAssumedRank(expr)) {
Say("Selector must not be assumed-rank"_err_en_US);
}
SetTypeFromAssociation(*symbol);
@@ -8669,11 +8714,6 @@ const parser::Name *DeclarationVisitor::ResolveDataRef(
x.u);
}
-static bool TypesMismatchIfNonNull(
- const DeclTypeSpec *type1, const DeclTypeSpec *type2) {
- return type1 && type2 && *type1 != *type2;
-}
-
// If implicit types are allowed, ensure name is in the symbol table.
// Otherwise, report an error if it hasn't been declared.
const parser::Name *DeclarationVisitor::ResolveName(const parser::Name &name) {
diff --git a/flang/lib/Semantics/rewrite-parse-tree.cpp b/flang/lib/Semantics/rewrite-parse-tree.cpp
index b3019762ead1..eae22dc257fa 100644
--- a/flang/lib/Semantics/rewrite-parse-tree.cpp
+++ b/flang/lib/Semantics/rewrite-parse-tree.cpp
@@ -80,9 +80,9 @@ public:
bool Pre(parser::EndSubroutineStmt &) { return false; }
bool Pre(parser::EndTypeStmt &) { return false; }
- bool Pre(parser::OpenMPBlockConstruct &);
+ bool Pre(parser::OmpBlockConstruct &);
bool Pre(parser::OpenMPLoopConstruct &);
- void Post(parser::OpenMPBlockConstruct &);
+ void Post(parser::OmpBlockConstruct &);
void Post(parser::OpenMPLoopConstruct &);
private:
@@ -187,7 +187,7 @@ void RewriteMutator::OpenMPSimdOnly(
continue;
}
}
- } else if (auto *ompBlock{std::get_if<parser::OpenMPBlockConstruct>(
+ } else if (auto *ompBlock{std::get_if<parser::OmpBlockConstruct>(
&omp->value().u)}) {
it = replaceInlineBlock(std::get<parser::Block>(ompBlock->t), it);
continue;
@@ -368,7 +368,7 @@ bool RewriteMutator::Pre(parser::Block &block) {
void RewriteMutator::Post(parser::Block &block) { this->Pre(block); }
-bool RewriteMutator::Pre(parser::OpenMPBlockConstruct &block) {
+bool RewriteMutator::Pre(parser::OmpBlockConstruct &block) {
if (context_.langOptions().OpenMPSimd) {
auto &innerBlock = std::get<parser::Block>(block.t);
OpenMPSimdOnly(innerBlock);
@@ -376,7 +376,7 @@ bool RewriteMutator::Pre(parser::OpenMPBlockConstruct &block) {
return true;
}
-void RewriteMutator::Post(parser::OpenMPBlockConstruct &block) {
+void RewriteMutator::Post(parser::OmpBlockConstruct &block) {
this->Pre(block);
}
diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp
index 5916a07df774..b8c3db872396 100644
--- a/flang/lib/Semantics/runtime-type-info.cpp
+++ b/flang/lib/Semantics/runtime-type-info.cpp
@@ -771,6 +771,8 @@ evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
auto &foldingContext{context_.foldingContext()};
auto typeAndShape{evaluate::characteristics::TypeAndShape::Characterize(
symbol, foldingContext)};
+ bool isDevice{object.cudaDataAttr() &&
+ *object.cudaDataAttr() == common::CUDADataAttr::Device};
CHECK(typeAndShape.has_value());
auto dyType{typeAndShape->type()};
int rank{typeAndShape->Rank()};
@@ -883,9 +885,19 @@ evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
// Default component initialization
bool hasDataInit{false};
if (IsAllocatable(symbol)) {
- AddValue(values, componentSchema_, "genre"s, GetEnumValue("allocatable"));
+ if (isDevice) {
+ AddValue(values, componentSchema_, "genre"s,
+ GetEnumValue("allocatabledevice"));
+ } else {
+ AddValue(values, componentSchema_, "genre"s, GetEnumValue("allocatable"));
+ }
} else if (IsPointer(symbol)) {
- AddValue(values, componentSchema_, "genre"s, GetEnumValue("pointer"));
+ if (isDevice) {
+ AddValue(
+ values, componentSchema_, "genre"s, GetEnumValue("pointerdevice"));
+ } else {
+ AddValue(values, componentSchema_, "genre"s, GetEnumValue("pointer"));
+ }
hasDataInit = InitializeDataPointer(
values, symbol, object, scope, dtScope, distinctName);
} else if (IsAutomatic(symbol)) {
diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp
index 2259cfcf23ec..ea7eeac80a2d 100644
--- a/flang/lib/Semantics/symbol.cpp
+++ b/flang/lib/Semantics/symbol.cpp
@@ -330,8 +330,14 @@ bool Symbol::CanReplaceDetails(const Details &details) const {
common::visitors{
[](const UseErrorDetails &) { return true; },
[&](const ObjectEntityDetails &) { return has<EntityDetails>(); },
- [&](const ProcEntityDetails &) { return has<EntityDetails>(); },
+ [&](const ProcEntityDetails &x) { return has<EntityDetails>(); },
[&](const SubprogramDetails &) {
+ if (const auto *oldProc{detailsIf<ProcEntityDetails>()}) {
+ // Can replace bare "EXTERNAL dummy" with explicit INTERFACE
+ return oldProc->isDummy() && !oldProc->procInterface() &&
+ attrs().test(Attr::EXTERNAL) && !test(Flag::Function) &&
+ !test(Flag::Subroutine);
+ }
return has<SubprogramNameDetails>() || has<EntityDetails>();
},
[&](const DerivedTypeDetails &) {
@@ -339,14 +345,12 @@ bool Symbol::CanReplaceDetails(const Details &details) const {
return derived && derived->isForwardReferenced();
},
[&](const UseDetails &x) {
- const auto *use{this->detailsIf<UseDetails>()};
+ const auto *use{detailsIf<UseDetails>()};
return use && use->symbol() == x.symbol();
},
- [&](const HostAssocDetails &) {
- return this->has<HostAssocDetails>();
- },
+ [&](const HostAssocDetails &) { return has<HostAssocDetails>(); },
[&](const UserReductionDetails &) {
- return this->has<UserReductionDetails>();
+ return has<UserReductionDetails>();
},
[](const auto &) { return false; },
},
@@ -611,7 +615,7 @@ llvm::raw_ostream &operator<<(llvm::raw_ostream &os, const Details &details) {
sep = ',';
}
},
- [](const HostAssocDetails &) {},
+ [&os](const HostAssocDetails &x) { os << " => " << x.symbol(); },
[&](const ProcBindingDetails &x) {
os << " => " << x.symbol().name();
DumpOptional(os, "passName", x.passName());
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 913bf08cd0d9..28829d3eda30 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -705,7 +705,7 @@ SymbolVector FinalsForDerivedTypeInstantiation(const DerivedTypeSpec &spec) {
const Symbol *IsFinalizable(const Symbol &symbol,
std::set<const DerivedTypeSpec *> *inProgress, bool withImpureFinalizer) {
- if (IsPointer(symbol) || evaluate::IsAssumedRank(symbol)) {
+ if (IsPointer(symbol) || IsAssumedRank(symbol)) {
return nullptr;
}
if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
@@ -741,7 +741,7 @@ const Symbol *IsFinalizable(const DerivedTypeSpec &derived,
if (const SubprogramDetails *
subp{symbol->detailsIf<SubprogramDetails>()}) {
if (const auto &args{subp->dummyArgs()}; !args.empty() &&
- args.at(0) && !evaluate::IsAssumedRank(*args.at(0)) &&
+ args.at(0) && !IsAssumedRank(*args.at(0)) &&
args.at(0)->Rank() != *rank) {
continue; // not a finalizer for this rank
}
@@ -790,7 +790,7 @@ const Symbol *HasImpureFinal(const Symbol &original, std::optional<int> rank) {
if (symbol.has<ObjectEntityDetails>()) {
if (const DeclTypeSpec * symType{symbol.GetType()}) {
if (const DerivedTypeSpec * derived{symType->AsDerived()}) {
- if (evaluate::IsAssumedRank(symbol)) {
+ if (IsAssumedRank(symbol)) {
// finalizable assumed-rank not allowed (C839)
return nullptr;
} else {
@@ -1170,7 +1170,7 @@ bool IsAccessible(const Symbol &original, const Scope &scope) {
}
std::optional<parser::MessageFormattedText> CheckAccessibleSymbol(
- const Scope &scope, const Symbol &symbol) {
+ const Scope &scope, const Symbol &symbol, bool inStructureConstructor) {
if (IsAccessible(symbol, scope)) {
return std::nullopt;
} else if (FindModuleFileContaining(scope)) {
@@ -1179,10 +1179,20 @@ std::optional<parser::MessageFormattedText> CheckAccessibleSymbol(
// whose structure constructors reference private components.
return std::nullopt;
} else {
+ const Scope &module{DEREF(FindModuleContaining(symbol.owner()))};
+ // Subtlety: Sometimes we want to be able to convert a generated
+ // module file back into Fortran, perhaps to convert it into a
+ // hermetic module file. Don't emit a fatal error for things like
+ // "__builtin_c_ptr(__address=0)" that came from expansions of
+ // "cptr_null()"; specifically, just warn about structure constructor
+ // component names from intrinsic modules when in a module.
+ parser::MessageFixedText text{FindModuleContaining(scope) &&
+ module.parent().IsIntrinsicModules() &&
+ inStructureConstructor && symbol.owner().IsDerivedType()
+ ? "PRIVATE name '%s' is accessible only within module '%s'"_warn_en_US
+ : "PRIVATE name '%s' is accessible only within module '%s'"_err_en_US};
return parser::MessageFormattedText{
- "PRIVATE name '%s' is accessible only within module '%s'"_err_en_US,
- symbol.name(),
- DEREF(FindModuleContaining(symbol.owner())).GetName().value()};
+ std::move(text), symbol.name(), module.GetName().value()};
}
}
diff --git a/flang/lib/Semantics/unparse-with-symbols.cpp b/flang/lib/Semantics/unparse-with-symbols.cpp
index b19948113106..ec5b3ffadf30 100644
--- a/flang/lib/Semantics/unparse-with-symbols.cpp
+++ b/flang/lib/Semantics/unparse-with-symbols.cpp
@@ -37,6 +37,8 @@ public:
template <typename T> void Post(const parser::Statement<T> &) {
currStmt_ = std::nullopt;
}
+ void Post(const parser::Name &name);
+
bool Pre(const parser::AccClause &clause) {
currStmt_ = clause.source;
return true;
@@ -57,7 +59,6 @@ public:
return true;
}
void Post(const parser::OpenMPThreadprivate &) { currStmt_ = std::nullopt; }
- void Post(const parser::Name &name);
bool Pre(const parser::OpenMPDeclareMapperConstruct &x) {
currStmt_ = x.source;
@@ -67,6 +68,14 @@ public:
currStmt_ = std::nullopt;
}
+ bool Pre(const parser::OpenMPDeclareReductionConstruct &x) {
+ currStmt_ = x.source;
+ return true;
+ }
+ void Post(const parser::OpenMPDeclareReductionConstruct &) {
+ currStmt_ = std::nullopt;
+ }
+
bool Pre(const parser::OpenMPDeclareTargetConstruct &x) {
currStmt_ = x.source;
return true;
@@ -120,6 +129,7 @@ void SymbolDumpVisitor::Indent(llvm::raw_ostream &out, int indent) const {
void SymbolDumpVisitor::Post(const parser::Name &name) {
if (const auto *symbol{name.symbol}) {
if (!symbol->has<MiscDetails>()) {
+ CHECK(currStmt_.has_value());
symbols_.emplace(currStmt_.value().begin(), symbol);
}
}
generated by cgit v1.2.3 (git 2.25.1) at 2026-06-01 11:48:34 +0000