[flang-commits] [flang] e9a8ab0 - [flang] Use definability tests for better PURE constraint checking
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Mon Apr 3 07:00:23 PDT 2023
Author: Peter Klausler
Date: 2023-04-03T07:00:07-07:00
New Revision: e9a8ab004cc9aae3c45f8b3708176e584b5c23a2
URL: https://github.com/llvm/llvm-project/commit/e9a8ab004cc9aae3c45f8b3708176e584b5c23a2
DIFF: https://github.com/llvm/llvm-project/commit/e9a8ab004cc9aae3c45f8b3708176e584b5c23a2.diff
LOG: [flang] Use definability tests for better PURE constraint checking
Many semantic checks for constraints related to PURE subprograms
can be implemented in terms of Semantics' "definable.h" utilities,
slightly expanded. Replace some particular PURE constraint
checks with calls to WhyNotDefinable(), except for cases that
had better specific error messages, and start checking some
missing constraints with DEALLOCATE statements and local
variable declarations.
Differential Revision: https://reviews.llvm.org/D147389
Added:
flang/test/Semantics/declarations05.f90
Modified:
flang/include/flang/Semantics/tools.h
flang/lib/Evaluate/tools.cpp
flang/lib/Semantics/check-deallocate.cpp
flang/lib/Semantics/check-deallocate.h
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/check-do-forall.cpp
flang/lib/Semantics/definable.cpp
flang/lib/Semantics/tools.cpp
flang/module/__fortran_type_info.f90
flang/test/Semantics/call10.f90
flang/test/Semantics/deallocate07.f90
flang/test/Semantics/doconcurrent08.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index ce78282940629..a7a01a0dd7e30 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -123,6 +123,7 @@ bool IsDestructible(const Symbol &, const Symbol *derivedType = nullptr);
bool HasIntrinsicTypeName(const Symbol &);
bool IsSeparateModuleProcedureInterface(const Symbol *);
bool HasAlternateReturns(const Symbol &);
+bool IsAutomaticallyDestroyed(const Symbol &);
// Return an ultimate component of type that matches predicate, or nullptr.
const Symbol *FindUltimateComponent(const DerivedTypeSpec &type,
@@ -167,11 +168,14 @@ inline bool IsImpliedDoIndex(const Symbol &symbol) {
return symbol.owner().kind() == Scope::Kind::ImpliedDos;
}
SymbolVector FinalsForDerivedTypeInstantiation(const DerivedTypeSpec &);
-bool IsFinalizable(
- const Symbol &, std::set<const DerivedTypeSpec *> * = nullptr);
-bool IsFinalizable(
- const DerivedTypeSpec &, std::set<const DerivedTypeSpec *> * = nullptr);
-bool HasImpureFinal(const DerivedTypeSpec &);
+// Returns a non-null pointer to a FINAL procedure, if any.
+const Symbol *IsFinalizable(const Symbol &,
+ std::set<const DerivedTypeSpec *> * = nullptr,
+ bool withImpureFinalizer = false);
+const Symbol *IsFinalizable(const DerivedTypeSpec &,
+ std::set<const DerivedTypeSpec *> * = nullptr,
+ bool withImpureFinalizer = false, std::optional<int> rank = std::nullopt);
+const Symbol *HasImpureFinal(const Symbol &);
bool IsInBlankCommon(const Symbol &);
inline bool IsAssumedSizeArray(const Symbol &symbol) {
const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
@@ -565,8 +569,6 @@ DirectComponentIterator::const_iterator FindAllocatableOrPointerDirectComponent(
const DerivedTypeSpec &);
UltimateComponentIterator::const_iterator
FindPolymorphicAllocatableUltimateComponent(const DerivedTypeSpec &);
-UltimateComponentIterator::const_iterator
-FindPolymorphicAllocatableNonCoarrayUltimateComponent(const DerivedTypeSpec &);
// The LabelEnforce class (given a set of labels) provides an error message if
// there is a branch to a label which is not in the given set.
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 3f62c2c7e4ef9..27aa700e07256 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1454,8 +1454,6 @@ bool IsSaved(const Symbol &original) {
// 8.5.16p4
// In main programs, implied SAVE matters only for pointer
// initialization targets and coarrays.
- // BLOCK DATA entities must all be in COMMON,
- // which was checked above.
return true;
} else if (scopeKind == Scope::Kind::MainProgram &&
(features.IsEnabled(common::LanguageFeature::SaveMainProgram) ||
diff --git a/flang/lib/Semantics/check-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp
index db089776b77a6..085dbbf67d2c0 100644
--- a/flang/lib/Semantics/check-deallocate.cpp
+++ b/flang/lib/Semantics/check-deallocate.cpp
@@ -37,11 +37,21 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
{DefinabilityFlag::PointerDefinition,
DefinabilityFlag::AcceptAllocatable},
*symbol)}) {
+ // Catch problems with non-definability of the
+ // pointer/allocatable
context_
.Say(name.source,
"Name in DEALLOCATE statement is not definable"_err_en_US)
.Attach(std::move(*whyNot));
- } else if (CheckPolymorphism(name.source, *symbol)) {
+ } else if (auto whyNot{WhyNotDefinable(name.source,
+ context_.FindScope(name.source),
+ DefinabilityFlags{}, *symbol)}) {
+ // Catch problems with non-definability of the dynamic object
+ context_
+ .Say(name.source,
+ "Object in DEALLOCATE statement is not deallocatable"_err_en_US)
+ .Attach(std::move(*whyNot));
+ } else {
context_.CheckIndexVarRedefine(name);
}
},
@@ -63,8 +73,13 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
.Say(source,
"Name in DEALLOCATE statement is not definable"_err_en_US)
.Attach(std::move(*whyNot));
- } else {
- CheckPolymorphism(source, *symbol);
+ } else if (auto whyNot{WhyNotDefinable(source,
+ context_.FindScope(source),
+ DefinabilityFlags{}, *expr)}) {
+ context_
+ .Say(source,
+ "Object in DEALLOCATE statement is not deallocatable"_err_en_US)
+ .Attach(std::move(*whyNot));
}
}
}
@@ -96,28 +111,4 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
}
}
-bool DeallocateChecker::CheckPolymorphism(
- parser::CharBlock source, const Symbol &symbol) {
- if (FindPureProcedureContaining(context_.FindScope(source))) {
- if (auto type{evaluate::DynamicType::From(symbol)}) {
- if (type->IsPolymorphic()) {
- context_.Say(source,
- "'%s' may not be deallocated in a pure procedure because it is polymorphic"_err_en_US,
- source);
- return false;
- }
- if (!type->IsUnlimitedPolymorphic() &&
- type->category() == TypeCategory::Derived) {
- if (auto iter{FindPolymorphicAllocatableUltimateComponent(
- type->GetDerivedTypeSpec())}) {
- context_.Say(source,
- "'%s' may not be deallocated in a pure procedure because its type has a polymorphic allocatable ultimate component '%s'"_err_en_US,
- source, iter->name());
- return false;
- }
- }
- }
- }
- return true;
-}
} // namespace Fortran::semantics
diff --git a/flang/lib/Semantics/check-deallocate.h b/flang/lib/Semantics/check-deallocate.h
index cff75f7d5d8d3..6aafb87a74793 100644
--- a/flang/lib/Semantics/check-deallocate.h
+++ b/flang/lib/Semantics/check-deallocate.h
@@ -22,7 +22,6 @@ class DeallocateChecker : public virtual BaseChecker {
void Leave(const parser::DeallocateStmt &);
private:
- bool CheckPolymorphism(parser::CharBlock, const Symbol &);
SemanticsContext &context_;
};
} // namespace Fortran::semantics
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 8091c1daddfaf..c8c899b670a2c 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -9,6 +9,7 @@
// Static declaration checking
#include "check-declarations.h"
+#include "definable.h"
#include "pointer-assignment.h"
#include "flang/Evaluate/check-expression.h"
#include "flang/Evaluate/fold.h"
@@ -312,19 +313,6 @@ void CheckHelper::Check(const Symbol &symbol) {
"A pure subprogram may not have a variable with the SAVE attribute"_err_en_US);
}
}
- if (!IsDummy(symbol) && !IsFunctionResult(symbol)) {
- if (IsPolymorphicAllocatable(symbol)) {
- SayWithDeclaration(symbol,
- "Deallocation of polymorphic object '%s' is not permitted in a pure subprogram"_err_en_US,
- symbol.name());
- } else if (derived) {
- if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) {
- SayWithDeclaration(*bad,
- "Deallocation of polymorphic object '%s%s' is not permitted in a pure subprogram"_err_en_US,
- symbol.name(), bad.BuildResultDesignatorName());
- }
- }
- }
}
if (symbol.attrs().test(Attr::VOLATILE) &&
(IsDummy(symbol) || !InInterface())) {
@@ -359,15 +347,17 @@ void CheckHelper::Check(const Symbol &symbol) {
Check(*type, canHaveAssumedParameter);
}
if (InPure() && InFunction() && IsFunctionResult(symbol)) {
- if (derived && HasImpureFinal(*derived)) { // C1584
- messages_.Say(
- "Result of pure function may not have an impure FINAL subroutine"_err_en_US);
- }
if (type->IsPolymorphic() && IsAllocatable(symbol)) { // C1585
messages_.Say(
"Result of pure function may not be both polymorphic and ALLOCATABLE"_err_en_US);
}
if (derived) {
+ // These cases would be caught be the general validation of local
+ // variables in a pure context, but these messages are more specific.
+ if (HasImpureFinal(symbol)) { // C1584
+ messages_.Say(
+ "Result of pure function may not have an impure FINAL subroutine"_err_en_US);
+ }
if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) {
SayWithDeclaration(*bad,
"Result of pure function may not have polymorphic ALLOCATABLE ultimate component '%s'"_err_en_US,
@@ -656,6 +646,9 @@ void CheckHelper::CheckObjectEntity(
}
if (details.isDummy()) {
if (IsIntentOut(symbol)) {
+ // Some of these errors would also be caught by the general check
+ // for definability of automatically deallocated local variables,
+ // but these messages are more specific.
if (FindUltimateComponent(symbol, [](const Symbol &x) {
return evaluate::IsCoarray(x) && IsAllocatable(x);
})) { // C846
@@ -701,7 +694,7 @@ void CheckHelper::CheckObjectEntity(
messages_.Say(
"An INTENT(OUT) dummy argument of a pure subroutine may not have a polymorphic ultimate component"_err_en_US);
}
- if (HasImpureFinal(*derived)) { // C1587
+ if (HasImpureFinal(symbol)) { // C1587
messages_.Say(
"An INTENT(OUT) dummy argument of a pure subroutine may not have an impure FINAL subroutine"_err_en_US);
}
@@ -789,6 +782,21 @@ void CheckHelper::CheckObjectEntity(
"ALLOCATABLE or POINTER attribute"_err_en_US,
symbol.name());
}
+ if (derived && InPure() && !InInterface() &&
+ IsAutomaticallyDestroyed(symbol) &&
+ !IsIntentOut(symbol) /*has better messages*/ &&
+ !IsFunctionResult(symbol) /*ditto*/) {
+ // Check automatically deallocated local variables for possible
+ // problems with finalization in PURE.
+ if (auto whyNot{
+ WhyNotDefinable(symbol.name(), symbol.owner(), {}, symbol)}) {
+ if (auto *msg{messages_.Say(
+ "'%s' may not be a local variable in a pure subprogram"_err_en_US,
+ symbol.name())}) {
+ msg->Attach(std::move(*whyNot));
+ }
+ }
+ }
}
void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
@@ -1735,7 +1743,9 @@ bool CheckHelper::CheckConflicting(const Symbol &symbol, Attr a1, Attr a2) {
void CheckHelper::WarnMissingFinal(const Symbol &symbol) {
const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
- if (!object || IsPointer(symbol)) {
+ if (!object ||
+ (!IsAutomaticallyDestroyed(symbol) &&
+ symbol.owner().kind() != Scope::Kind::DerivedType)) {
return;
}
const DeclTypeSpec *type{object->type()};
diff --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp
index cf2a2c26d9c51..b90bfd3ff5c6c 100644
--- a/flang/lib/Semantics/check-do-forall.cpp
+++ b/flang/lib/Semantics/check-do-forall.cpp
@@ -115,19 +115,6 @@ class DoConcurrentBodyEnforce {
// invocation of an IMPURE final subroutine. (C1139)
//
- // Only to be called for symbols with ObjectEntityDetails
- static bool HasImpureFinal(const Symbol &original) {
- const Symbol &symbol{ResolveAssociations(original)};
- if (symbol.has<ObjectEntityDetails>()) {
- if (const DeclTypeSpec * symType{symbol.GetType()}) {
- if (const DerivedTypeSpec * derived{symType->AsDerived()}) {
- return semantics::HasImpureFinal(*derived);
- }
- }
- }
- return false;
- }
-
// Predicate for deallocations caused by block exit and direct deallocation
static bool DeallocateAll(const Symbol &) { return true; }
@@ -166,11 +153,11 @@ class DoConcurrentBodyEnforce {
return false;
}
- void SayDeallocateWithImpureFinal(const Symbol &entity, const char *reason) {
+ void SayDeallocateWithImpureFinal(
+ const Symbol &entity, const char *reason, const Symbol &impure) {
context_.SayWithDecl(entity, currentStatementSourcePosition_,
- "Deallocation of an entity with an IMPURE FINAL procedure"
- " caused by %s not allowed in DO CONCURRENT"_err_en_US,
- reason);
+ "Deallocation of an entity with an IMPURE FINAL procedure '%s' caused by %s not allowed in DO CONCURRENT"_err_en_US,
+ impure.name(), reason);
}
void SayDeallocateOfPolymorph(
@@ -199,8 +186,8 @@ class DoConcurrentBodyEnforce {
MightDeallocatePolymorphic(entity, DeallocateAll)) {
SayDeallocateOfPolymorph(endBlockStmt.source, entity, reason);
}
- if (HasImpureFinal(entity)) {
- SayDeallocateWithImpureFinal(entity, reason);
+ if (const Symbol * impure{HasImpureFinal(entity)}) {
+ SayDeallocateWithImpureFinal(entity, reason, *impure);
}
}
}
@@ -215,8 +202,8 @@ class DoConcurrentBodyEnforce {
if (MightDeallocatePolymorphic(*entity, DeallocateNonCoarray)) {
SayDeallocateOfPolymorph(variable.GetSource(), *entity, reason);
}
- if (HasImpureFinal(*entity)) {
- SayDeallocateWithImpureFinal(*entity, reason);
+ if (const Symbol * impure{HasImpureFinal(*entity)}) {
+ SayDeallocateWithImpureFinal(*entity, reason, *impure);
}
}
if (const auto *assignment{GetAssignment(stmt)}) {
@@ -248,8 +235,8 @@ class DoConcurrentBodyEnforce {
SayDeallocateOfPolymorph(
currentStatementSourcePosition_, entity, reason);
}
- if (HasImpureFinal(entity)) {
- SayDeallocateWithImpureFinal(entity, reason);
+ if (const Symbol * impure{HasImpureFinal(entity)}) {
+ SayDeallocateWithImpureFinal(entity, reason, *impure);
}
}
}
diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp
index 613a62cc4986b..675becd32c266 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -156,19 +156,27 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
"'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US,
original);
}
- if (!flags.test(DefinabilityFlag::PolymorphicOkInPure) &&
- FindPureProcedureContaining(scope)) {
+ if (FindPureProcedureContaining(scope)) {
if (auto dyType{evaluate::DynamicType::From(ultimate)}) {
- if (dyType->IsPolymorphic()) { // C1596
+ if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
+ if (dyType->IsPolymorphic()) { // C1596
+ return BlameSymbol(at,
+ "'%s' is polymorphic in a pure subprogram"_because_en_US,
+ original);
+ }
+ }
+ if (const Symbol * impure{HasImpureFinal(ultimate)}) {
return BlameSymbol(at,
- "'%s' is polymorphic in a pure subprogram"_because_en_US, original);
+ "'%s' has an impure FINAL procedure '%s'"_because_en_US, original,
+ impure->name());
}
if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(dyType)}) {
- if (auto bad{FindPolymorphicAllocatableNonCoarrayUltimateComponent(
- *derived)}) {
- return BlameSymbol(at,
- "'%s' has polymorphic non-coarray component '%s' in a pure subprogram"_because_en_US,
- original, bad.BuildResultDesignatorName());
+ if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
+ if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) {
+ return BlameSymbol(at,
+ "'%s' has polymorphic component '%s' in a pure subprogram"_because_en_US,
+ original, bad.BuildResultDesignatorName());
+ }
}
}
}
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 2304812a4d051..8c9ad672831fb 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -729,52 +729,101 @@ SymbolVector FinalsForDerivedTypeInstantiation(const DerivedTypeSpec &spec) {
return result;
}
-bool IsFinalizable(
- const Symbol &symbol, std::set<const DerivedTypeSpec *> *inProgress) {
- if (IsPointer(symbol)) {
- return false;
+const Symbol *IsFinalizable(const Symbol &symbol,
+ std::set<const DerivedTypeSpec *> *inProgress, bool withImpureFinalizer) {
+ if (IsPointer(symbol) || evaluate::IsAssumedRank(symbol)) {
+ return nullptr;
}
if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
if (object->isDummy() && !IsIntentOut(symbol)) {
- return false;
+ return nullptr;
}
const DeclTypeSpec *type{object->type()};
- const DerivedTypeSpec *typeSpec{type ? type->AsDerived() : nullptr};
- return typeSpec && IsFinalizable(*typeSpec, inProgress);
+ if (const DerivedTypeSpec * typeSpec{type ? type->AsDerived() : nullptr}) {
+ return IsFinalizable(
+ *typeSpec, inProgress, withImpureFinalizer, symbol.Rank());
+ }
}
- return false;
+ return nullptr;
}
-bool IsFinalizable(const DerivedTypeSpec &derived,
- std::set<const DerivedTypeSpec *> *inProgress) {
- if (!FinalsForDerivedTypeInstantiation(derived).empty()) {
- return true;
+const Symbol *IsFinalizable(const DerivedTypeSpec &derived,
+ std::set<const DerivedTypeSpec *> *inProgress, bool withImpureFinalizer,
+ std::optional<int> rank) {
+ const Symbol *elemental{nullptr};
+ for (auto ref : FinalsForDerivedTypeInstantiation(derived)) {
+ const Symbol *symbol{&ref->GetUltimate()};
+ if (const auto *binding{symbol->detailsIf<ProcBindingDetails>()}) {
+ symbol = &binding->symbol();
+ }
+ if (const auto *proc{symbol->detailsIf<ProcEntityDetails>()}) {
+ symbol = proc->procInterface();
+ }
+ if (!symbol) {
+ } else if (IsElementalProcedure(*symbol)) {
+ elemental = symbol;
+ } else {
+ if (rank) {
+ 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)->Rank() != *rank) {
+ continue; // not a finalizer for this rank
+ }
+ }
+ }
+ if (!withImpureFinalizer || !IsPureProcedure(*symbol)) {
+ return symbol;
+ }
+ // Found non-elemental pure finalizer of matching rank, but still
+ // need to check components for an impure finalizer.
+ elemental = nullptr;
+ break;
+ }
}
+ if (elemental && (!withImpureFinalizer || !IsPureProcedure(*elemental))) {
+ return elemental;
+ }
+ // Check components (including ancestors)
std::set<const DerivedTypeSpec *> basis;
if (inProgress) {
if (inProgress->find(&derived) != inProgress->end()) {
- return false; // don't loop on recursive type
+ return nullptr; // don't loop on recursive type
}
} else {
inProgress = &basis;
}
auto iterator{inProgress->insert(&derived).first};
- PotentialComponentIterator components{derived};
- bool result{bool{std::find_if(
- components.begin(), components.end(), [=](const Symbol &component) {
- return IsFinalizable(component, inProgress);
- })}};
+ const Symbol *result{nullptr};
+ for (const Symbol &component : PotentialComponentIterator{derived}) {
+ result = IsFinalizable(component, inProgress, withImpureFinalizer);
+ if (result) {
+ break;
+ }
+ }
inProgress->erase(iterator);
return result;
}
-bool HasImpureFinal(const DerivedTypeSpec &derived) {
- for (auto ref : FinalsForDerivedTypeInstantiation(derived)) {
- if (!IsPureProcedure(*ref)) {
- return true;
+static const Symbol *HasImpureFinal(
+ const DerivedTypeSpec &derived, std::optional<int> rank) {
+ return IsFinalizable(derived, nullptr, /*withImpureFinalizer=*/true, rank);
+}
+
+const Symbol *HasImpureFinal(const Symbol &original) {
+ const Symbol &symbol{ResolveAssociations(original)};
+ if (symbol.has<ObjectEntityDetails>()) {
+ if (const DeclTypeSpec * symType{symbol.GetType()}) {
+ if (const DerivedTypeSpec * derived{symType->AsDerived()}) {
+ // finalizable assumed-rank not allowed (C839)
+ return evaluate::IsAssumedRank(symbol)
+ ? nullptr
+ : HasImpureFinal(*derived, symbol.Rank());
+ }
}
}
- return false;
+ return nullptr;
}
bool IsAssumedLengthCharacter(const Symbol &symbol) {
@@ -1298,15 +1347,6 @@ FindPolymorphicAllocatableUltimateComponent(const DerivedTypeSpec &derived) {
ultimates.begin(), ultimates.end(), IsPolymorphicAllocatable);
}
-UltimateComponentIterator::const_iterator
-FindPolymorphicAllocatableNonCoarrayUltimateComponent(
- const DerivedTypeSpec &derived) {
- UltimateComponentIterator ultimates{derived};
- return std::find_if(ultimates.begin(), ultimates.end(), [](const Symbol &x) {
- return IsPolymorphicAllocatable(x) && !evaluate::IsCoarray(x);
- });
-}
-
const Symbol *FindUltimateComponent(const DerivedTypeSpec &derived,
const std::function<bool(const Symbol &)> &predicate) {
UltimateComponentIterator ultimates{derived};
@@ -1450,6 +1490,14 @@ bool HasAlternateReturns(const Symbol &subprogram) {
return false;
}
+bool IsAutomaticallyDestroyed(const Symbol &symbol) {
+ return symbol.has<ObjectEntityDetails>() &&
+ (symbol.owner().kind() == Scope::Kind::Subprogram ||
+ symbol.owner().kind() == Scope::Kind::BlockConstruct) &&
+ (!IsDummy(symbol) || IsIntentOut(symbol)) && !IsPointer(symbol) &&
+ !IsSaved(symbol) && !FindCommonBlockContaining(symbol);
+}
+
const std::optional<parser::Name> &MaybeGetNodeName(
const ConstructNode &construct) {
return common::visit(
diff --git a/flang/module/__fortran_type_info.f90 b/flang/module/__fortran_type_info.f90
index b33d210bee5ae..7371cee465843 100644
--- a/flang/module/__fortran_type_info.f90
+++ b/flang/module/__fortran_type_info.f90
@@ -44,7 +44,7 @@
integer(1) :: hasParent
integer(1) :: noInitializationNeeded ! 1 if no component w/ init
integer(1) :: noDestructionNeeded ! 1 if no component w/ dealloc/final
- integer(1) :: noFinalizationNeeded ! 1 if nothing finalizaable
+ integer(1) :: noFinalizationNeeded ! 1 if nothing finalizeable
integer(1) :: __padding0(4)
end type
diff --git a/flang/test/Semantics/call10.f90 b/flang/test/Semantics/call10.f90
index f46753a7b69a9..2a840e111e2ab 100644
--- a/flang/test/Semantics/call10.f90
+++ b/flang/test/Semantics/call10.f90
@@ -157,11 +157,12 @@ pure subroutine s10 ! C1595
end subroutine
pure subroutine s11(to) ! C1596
! Implicit deallocation at the end of the subroutine
- !ERROR: Deallocation of polymorphic object 'auto%a' is not permitted in a pure subprogram
+ !ERROR: 'auto' may not be a local variable in a pure subprogram
+ !BECAUSE: 'auto' has polymorphic component '%a' in a pure subprogram
type(polyAlloc) :: auto
type(polyAlloc), intent(in out) :: to
!ERROR: Left-hand side of assignment is not definable
- !BECAUSE: 'to' has polymorphic non-coarray component '%a' in a pure subprogram
+ !BECAUSE: 'to' has polymorphic component '%a' in a pure subprogram
to = auto
end subroutine
pure subroutine s12
diff --git a/flang/test/Semantics/deallocate07.f90 b/flang/test/Semantics/deallocate07.f90
index 2a3d036ec0b66..154c680f47c82 100644
--- a/flang/test/Semantics/deallocate07.f90
+++ b/flang/test/Semantics/deallocate07.f90
@@ -6,16 +6,27 @@ module m
type t2
class(t2), allocatable :: pc
end type
+ class(t1), pointer :: mp1
+ type(t2) :: mv1
contains
pure subroutine subr(pp1, pp2, mp2)
class(t1), intent(in out), pointer :: pp1
class(t2), intent(in out) :: pp2
type(t2), pointer :: mp2
- !ERROR: 'pp1' may not be deallocated in a pure procedure because it is polymorphic
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: 'mp1' may not be defined in pure subprogram 'subr' because it is host-associated
+ deallocate(mp1)
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: 'mv1' may not be defined in pure subprogram 'subr' because it is host-associated
+ deallocate(mv1%pc)
+ !ERROR: Object in DEALLOCATE statement is not deallocatable
+ !BECAUSE: 'pp1' is polymorphic in a pure subprogram
deallocate(pp1)
- !ERROR: 'pc' may not be deallocated in a pure procedure because it is polymorphic
+ !ERROR: Object in DEALLOCATE statement is not deallocatable
+ !BECAUSE: 'pc' is polymorphic in a pure subprogram
deallocate(pp2%pc)
- !ERROR: 'mp2' may not be deallocated in a pure procedure because its type has a polymorphic allocatable ultimate component 'pc'
+ !ERROR: Object in DEALLOCATE statement is not deallocatable
+ !BECAUSE: 'mp2' has polymorphic component '%pc' in a pure subprogram
deallocate(mp2)
end subroutine
end module
diff --git a/flang/test/Semantics/declarations05.f90 b/flang/test/Semantics/declarations05.f90
new file mode 100644
index 0000000000000..5144f0b91ab9d
--- /dev/null
+++ b/flang/test/Semantics/declarations05.f90
@@ -0,0 +1,42 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Other checks for declarations in PURE procedures
+module m
+ type t0
+ end type
+ type t1
+ contains
+ final :: final
+ end type
+ type t2
+ type(t1), allocatable :: c
+ end type
+ type t3
+ class(t1), allocatable :: c
+ end type
+ type t4
+ class(t0), allocatable :: c
+ end type
+ contains
+ impure subroutine final(x)
+ type(t1) x
+ end
+ pure subroutine test
+ !ERROR: 'x0' may not be a local variable in a pure subprogram
+ !BECAUSE: 'x0' is polymorphic in a pure subprogram
+ class(t0), allocatable :: x0
+ !ERROR: 'x1' may not be a local variable in a pure subprogram
+ !BECAUSE: 'x1' has an impure FINAL procedure 'final'
+ type(t1) x1
+ !WARNING: 'x1a' of derived type 't1' does not have a FINAL subroutine for its rank (1)
+ type(t1), allocatable :: x1a(:)
+ !ERROR: 'x2' may not be a local variable in a pure subprogram
+ !BECAUSE: 'x2' has an impure FINAL procedure 'final'
+ type(t2) x2
+ !ERROR: 'x3' may not be a local variable in a pure subprogram
+ !BECAUSE: 'x3' has an impure FINAL procedure 'final'
+ type(t3) x3
+ !ERROR: 'x4' may not be a local variable in a pure subprogram
+ !BECAUSE: 'x4' has polymorphic component '%c' in a pure subprogram
+ type(t4) x4
+ end
+end
diff --git a/flang/test/Semantics/doconcurrent08.f90 b/flang/test/Semantics/doconcurrent08.f90
index e56b980dbf442..41cd71e233d0d 100644
--- a/flang/test/Semantics/doconcurrent08.f90
+++ b/flang/test/Semantics/doconcurrent08.f90
@@ -247,7 +247,7 @@ subroutine s4()
! Error to invoke an IMPURE FINAL procedure in a DO CONCURRENT
do concurrent (i = 1:10)
- !ERROR: Deallocation of an entity with an IMPURE FINAL procedure caused by a DEALLOCATE statement not allowed in DO CONCURRENT
+ !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by a DEALLOCATE statement not allowed in DO CONCURRENT
if (i .eq. 1) deallocate(ifVar)
end do
@@ -256,18 +256,18 @@ subroutine s4()
block
type(impureFinal), allocatable :: ifVar
allocate(ifVar)
- ! Error here because exiting this scope causes the finalization of
- !ifvar which causes the invocation of an IMPURE FINAL procedure
- !ERROR: Deallocation of an entity with an IMPURE FINAL procedure caused by block exit not allowed in DO CONCURRENT
+ ! Error here because exiting this scope causes the finalization of
+ ! ifvar which causes the invocation of an IMPURE FINAL procedure
+ !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by block exit not allowed in DO CONCURRENT
end block
end if
end do
do concurrent (i = 1:10)
if (i .eq. 1) then
- ! Error here because the assignment statement causes the finalization
+ ! Error here because the assignment statement causes the finalization
! of ifvar which causes the invocation of an IMPURE FINAL procedure
-!ERROR: Deallocation of an entity with an IMPURE FINAL procedure caused by assignment not allowed in DO CONCURRENT
+ !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by assignment not allowed in DO CONCURRENT
ifvar = ifvar1
end if
end do
More information about the flang-commits
mailing list