diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp --- a/flang/lib/Semantics/check-allocate.cpp +++ b/flang/lib/Semantics/check-allocate.cpp @@ -8,6 +8,7 @@ #include "check-allocate.h" #include "assignment.h" +#include "definable.h" #include "flang/Evaluate/fold.h" #include "flang/Evaluate/type.h" #include "flang/Parser/parse-tree.h" @@ -532,6 +533,19 @@ return false; } context.CheckIndexVarRedefine(name_); + if (allocateObject_.typedExpr && allocateObject_.typedExpr->v) { + if (auto whyNot{ + WhyNotDefinable(name_.source, context.FindScope(name_.source), + {DefinabilityFlag::PointerDefinition, + DefinabilityFlag::AcceptAllocatable}, + *allocateObject_.typedExpr->v)}) { + context + .Say(name_.source, + "Name in ALLOCATE statement is not definable"_err_en_US) + .Attach(std::move(*whyNot)); + return false; + } + } return RunCoarrayRelatedChecks(context); } diff --git a/flang/lib/Semantics/check-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp --- a/flang/lib/Semantics/check-deallocate.cpp +++ b/flang/lib/Semantics/check-deallocate.cpp @@ -7,6 +7,7 @@ //===----------------------------------------------------------------------===// #include "check-deallocate.h" +#include "definable.h" #include "flang/Evaluate/type.h" #include "flang/Parser/message.h" #include "flang/Parser/parse-tree.h" @@ -26,26 +27,44 @@ // already reported an error } else if (!IsVariableName(*symbol)) { context_.Say(name.source, - "name in DEALLOCATE statement must be a variable name"_err_en_US); + "Name in DEALLOCATE statement must be a variable name"_err_en_US); } else if (!IsAllocatableOrPointer( symbol->GetUltimate())) { // C932 context_.Say(name.source, - "name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US); + "Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US); + } else if (auto whyNot{WhyNotDefinable(name.source, + context_.FindScope(name.source), + {DefinabilityFlag::PointerDefinition, + DefinabilityFlag::AcceptAllocatable}, + *symbol)}) { + context_ + .Say(name.source, + "Name in DEALLOCATE statement is not definable"_err_en_US) + .Attach(std::move(*whyNot)); } else if (CheckPolymorphism(name.source, *symbol)) { context_.CheckIndexVarRedefine(name); } }, [&](const parser::StructureComponent &structureComponent) { - // Only perform structureComponent checks it was successfully - // analyzed in expression analysis. - if (GetExpr(context_, allocateObject)) { + // Only perform structureComponent checks if it was successfully + // analyzed by expression analysis. + if (const auto *expr{GetExpr(context_, allocateObject)}) { if (const Symbol *symbol{structureComponent.component.symbol}) { + auto source{structureComponent.component.source}; if (!IsAllocatableOrPointer(*symbol)) { // C932 - context_.Say(structureComponent.component.source, - "component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US); + context_.Say(source, + "Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US); + } else if (auto whyNot{WhyNotDefinable(source, + context_.FindScope(source), + {DefinabilityFlag::PointerDefinition, + DefinabilityFlag::AcceptAllocatable}, + *expr)}) { + context_ + .Say(source, + "Name in DEALLOCATE statement is not definable"_err_en_US) + .Attach(std::move(*whyNot)); } else { - CheckPolymorphism( - structureComponent.component.source, *symbol); + CheckPolymorphism(source, *symbol); } } } diff --git a/flang/lib/Semantics/definable.h b/flang/lib/Semantics/definable.h --- a/flang/lib/Semantics/definable.h +++ b/flang/lib/Semantics/definable.h @@ -28,6 +28,7 @@ ENUM_CLASS(DefinabilityFlag, VectorSubscriptIsOk, // a vector subscript may appear (i.e., assignment) PointerDefinition, // a pointer is being defined, not its target + AcceptAllocatable, // treat allocatable as if it were a pointer PolymorphicOkInPure) // don't check for polymorphic type in pure subprogram using DefinabilityFlags = diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp --- a/flang/lib/Semantics/definable.cpp +++ b/flang/lib/Semantics/definable.cpp @@ -70,12 +70,13 @@ // ptr1%ptr2 = ... -> ptr2 // ptr1%ptr2%nonptr = ... -> ptr2 // nonptr1%nonptr2 = ... -> nonptr1 -static const Symbol &GetRelevantSymbol( - const evaluate::DataRef &dataRef, bool isPointerDefinition) { +static const Symbol &GetRelevantSymbol(const evaluate::DataRef &dataRef, + bool isPointerDefinition, bool acceptAllocatable) { if (isPointerDefinition) { if (const auto *component{std::get_if(&dataRef.u)}) { - if (IsPointer(component->GetLastSymbol())) { - return GetRelevantSymbol(component->base(), false); + if (IsPointer(component->GetLastSymbol()) || + (acceptAllocatable && IsAllocatable(component->GetLastSymbol()))) { + return GetRelevantSymbol(component->base(), false, false); } } } @@ -91,6 +92,7 @@ const Scope &scope, DefinabilityFlags flags, const Symbol &original) { const Symbol &ultimate{original.GetUltimate()}; bool isPointerDefinition{flags.test(DefinabilityFlag::PointerDefinition)}; + bool acceptAllocatable{flags.test(DefinabilityFlag::AcceptAllocatable)}; bool isTargetDefinition{!isPointerDefinition && IsPointer(ultimate)}; if (const auto *association{ultimate.detailsIf()}) { if (association->rank().has_value()) { @@ -103,8 +105,8 @@ "Construct association '%s' has a vector subscript"_en_US, original); } else if (auto dataRef{evaluate::ExtractDataRef( *association->expr(), true, true)}) { - return WhyNotDefinableBase( - at, scope, flags, GetRelevantSymbol(*dataRef, isPointerDefinition)); + return WhyNotDefinableBase(at, scope, flags, + GetRelevantSymbol(*dataRef, isPointerDefinition, acceptAllocatable)); } } if (isTargetDefinition) { @@ -139,7 +141,12 @@ const Scope &scope, DefinabilityFlags flags, const Symbol &original) { const Symbol &ultimate{original.GetUltimate()}; if (flags.test(DefinabilityFlag::PointerDefinition)) { - if (!IsPointer(ultimate)) { + if (flags.test(DefinabilityFlag::AcceptAllocatable)) { + if (!IsAllocatableOrPointer(ultimate)) { + return BlameSymbol( + at, "'%s' is neither a pointer nor an allocatable"_en_US, original); + } + } else if (!IsPointer(ultimate)) { return BlameSymbol(at, "'%s' is not a pointer"_en_US, original); } return std::nullopt; // pointer assignment - skip following checks @@ -173,8 +180,9 @@ static std::optional WhyNotDefinable(parser::CharBlock at, const Scope &scope, DefinabilityFlags flags, const evaluate::DataRef &dataRef) { - const Symbol &base{GetRelevantSymbol( - dataRef, flags.test(DefinabilityFlag::PointerDefinition))}; + const Symbol &base{GetRelevantSymbol(dataRef, + flags.test(DefinabilityFlag::PointerDefinition), + flags.test(DefinabilityFlag::AcceptAllocatable))}; if (auto whyNot{WhyNotDefinableBase(at, scope, flags, base)}) { return whyNot; } else { @@ -187,7 +195,7 @@ const Scope &scope, DefinabilityFlags flags, const evaluate::Component &component) { const evaluate::DataRef &dataRef{component.base()}; - const Symbol &base{GetRelevantSymbol(dataRef, false)}; + const Symbol &base{GetRelevantSymbol(dataRef, false, false)}; DefinabilityFlags baseFlags{flags}; baseFlags.reset(DefinabilityFlag::PointerDefinition); return WhyNotDefinableBase(at, scope, baseFlags, base); diff --git a/flang/test/Semantics/allocate13.f90 b/flang/test/Semantics/allocate13.f90 --- a/flang/test/Semantics/allocate13.f90 +++ b/flang/test/Semantics/allocate13.f90 @@ -171,3 +171,23 @@ allocate(team[*], SOURCE=teamsrc) allocate(lock[*], SOURCE=locksrc) end subroutine + +module prot + real, pointer, protected :: pp + real, allocatable, protected :: pa +end module +subroutine prottest + use prot + !ERROR: Name in ALLOCATE statement is not definable + !BECAUSE: 'pp' is protected in this scope + allocate(pp) + !ERROR: Name in ALLOCATE statement is not definable + !BECAUSE: 'pa' is protected in this scope + allocate(pa) + !ERROR: Name in DEALLOCATE statement is not definable + !BECAUSE: 'pp' is protected in this scope + deallocate(pp) + !ERROR: Name in DEALLOCATE statement is not definable + !BECAUSE: 'pa' is protected in this scope + deallocate(pa) +end subroutine diff --git a/flang/test/Semantics/deallocate05.f90 b/flang/test/Semantics/deallocate05.f90 --- a/flang/test/Semantics/deallocate05.f90 +++ b/flang/test/Semantics/deallocate05.f90 @@ -32,27 +32,27 @@ Allocate(x(3)) -!ERROR: component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute +!ERROR: Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute Deallocate(x(2)%p) -!ERROR: name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute +!ERROR: Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute Deallocate(pi) -!ERROR: component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute -!ERROR: name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute +!ERROR: Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute +!ERROR: Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute Deallocate(x(2)%p, pi) -!ERROR: name in DEALLOCATE statement must be a variable name +!ERROR: Name in DEALLOCATE statement must be a variable name Deallocate(prp) -!ERROR: name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute -!ERROR: name in DEALLOCATE statement must be a variable name +!ERROR: Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute +!ERROR: Name in DEALLOCATE statement must be a variable name Deallocate(pi, prp) -!ERROR: name in DEALLOCATE statement must be a variable name +!ERROR: Name in DEALLOCATE statement must be a variable name Deallocate(maxvalue) -!ERROR: component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute +!ERROR: Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute Deallocate(x%p) !ERROR: STAT may not be duplicated in a DEALLOCATE statement diff --git a/flang/test/Semantics/deallocate06.f90 b/flang/test/Semantics/deallocate06.f90 --- a/flang/test/Semantics/deallocate06.f90 +++ b/flang/test/Semantics/deallocate06.f90 @@ -19,7 +19,7 @@ deallocate(b) deallocate(c) deallocate(d) - !ERROR: name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute + !ERROR: Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute deallocate(e) end subroutine end diff --git a/flang/test/Semantics/dosemantics12.f90 b/flang/test/Semantics/dosemantics12.f90 --- a/flang/test/Semantics/dosemantics12.f90 +++ b/flang/test/Semantics/dosemantics12.f90 @@ -369,7 +369,7 @@ ! fails because you can only deallocate a variable that's allocatable. do concurrent (ivar = 1:10) print *, "hello" -!ERROR: name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute +!ERROR: Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute deallocate(ivar) end do @@ -429,7 +429,7 @@ jvar = intentOutFunc(ivar) end do - ! Error for passing a DO variable to an INTENT(OUT) dummy, more complex + ! Error for passing a DO variable to an INTENT(OUT) dummy, more complex ! expression do ivar = 1, 10 !ERROR: Cannot redefine DO variable 'ivar'