diff --git a/flang/lib/Semantics/check-deallocate.h b/flang/lib/Semantics/check-deallocate.h --- a/flang/lib/Semantics/check-deallocate.h +++ b/flang/lib/Semantics/check-deallocate.h @@ -22,6 +22,7 @@ void Leave(const parser::DeallocateStmt &); private: + bool CheckPolymorphism(parser::CharBlock, const Symbol &); SemanticsContext &context_; }; } // namespace Fortran::semantics 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 "flang/Evaluate/type.h" #include "flang/Parser/message.h" #include "flang/Parser/parse-tree.h" #include "flang/Semantics/expression.h" @@ -30,7 +31,7 @@ symbol->GetUltimate())) { // C932 context_.Say(name.source, "name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US); - } else { + } else if (CheckPolymorphism(name.source, *symbol)) { context_.CheckIndexVarRedefine(name); } }, @@ -38,10 +39,14 @@ // Only perform structureComponent checks it was successfully // analyzed in expression analysis. if (GetExpr(context_, allocateObject)) { - if (!IsAllocatableOrPointer( - *structureComponent.component.symbol)) { // C932 - context_.Say(structureComponent.component.source, - "component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US); + if (const Symbol *symbol{structureComponent.component.symbol}) { + if (!IsAllocatableOrPointer(*symbol)) { // C932 + context_.Say(structureComponent.component.source, + "component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US); + } else { + CheckPolymorphism( + structureComponent.component.source, *symbol); + } } } }, @@ -71,4 +76,29 @@ deallocOpt.u); } } + +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/test/Semantics/deallocate07.f90 b/flang/test/Semantics/deallocate07.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/deallocate07.f90 @@ -0,0 +1,21 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 + +module m + type t1 + end type + type t2 + class(t2), allocatable :: pc + end type + 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 + deallocate(pp1) + !ERROR: 'pc' may not be deallocated in a pure procedure because it is polymorphic + deallocate(pp2%pc) + !ERROR: 'mp2' may not be deallocated in a pure procedure because its type has a polymorphic allocatable ultimate component 'pc' + deallocate(mp2) + end subroutine +end module