diff --git a/flang/lib/semantics/check-allocate.cc b/flang/lib/semantics/check-allocate.cc index a10a602766be..232617b4c9d8 100644 --- a/flang/lib/semantics/check-allocate.cc +++ b/flang/lib/semantics/check-allocate.cc @@ -48,24 +48,11 @@ public: allocateShapeSpecRank_{ShapeSpecRank(alloc)}, rank_{name_.symbol ? name_.symbol->Rank() : 0}, allocateCoarraySpecRank_{CoarraySpecRank(alloc)}, - corank_{name_.symbol ? name_.symbol->Corank() : 0} { - GatherAllocationBasicInfo(); - } + corank_{name_.symbol ? name_.symbol->Corank() : 0} {} bool RunChecks(SemanticsContext &context); private: - AllocateCheckerInfo &allocateInfo_; - const parser::AllocateObject &allocateObject_; - const parser::Name &name_; - const DeclTypeSpec *type_; - const int allocateShapeSpecRank_; - const int rank_; - const int allocateCoarraySpecRank_; - const int corank_; - bool hasDeferredTypeParameter_{false}; - bool isUnlimitedPolymorphic_{false}; - bool isAbstract_{false}; bool hasAllocateShapeSpecList() const { return allocateShapeSpecRank_ != 0; } bool hasAllocateCoarraySpec() const { return allocateCoarraySpecRank_ != 0; } bool RunCoarrayRelatedChecks(SemanticsContext &) const; @@ -88,21 +75,30 @@ private: } void GatherAllocationBasicInfo() { - if (type_) { - if (type_->category() == DeclTypeSpec::Category::Character) { - hasDeferredTypeParameter_ = - type_->characterTypeSpec().length().isDeferred(); - } else if (const DerivedTypeSpec * derivedTypeSpec{type_->AsDerived()}) { - for (const auto &pair : derivedTypeSpec->parameters()) { - hasDeferredTypeParameter_ |= pair.second.isDeferred(); - } - isAbstract_ = - derivedTypeSpec->typeSymbol().attrs().test(Attr::ABSTRACT); + if (type_->category() == DeclTypeSpec::Category::Character) { + hasDeferredTypeParameter_ = + type_->characterTypeSpec().length().isDeferred(); + } else if (const DerivedTypeSpec * derivedTypeSpec{type_->AsDerived()}) { + for (const auto &pair : derivedTypeSpec->parameters()) { + hasDeferredTypeParameter_ |= pair.second.isDeferred(); } - isUnlimitedPolymorphic_ = - type_->category() == DeclTypeSpec::Category::ClassStar; + isAbstract_ = derivedTypeSpec->typeSymbol().attrs().test(Attr::ABSTRACT); } + isUnlimitedPolymorphic_ = + type_->category() == DeclTypeSpec::Category::ClassStar; } + + AllocateCheckerInfo &allocateInfo_; + const parser::AllocateObject &allocateObject_; + const parser::Name &name_; + const DeclTypeSpec *type_; + const int allocateShapeSpecRank_; + const int rank_; + const int allocateCoarraySpecRank_; + const int corank_; + bool hasDeferredTypeParameter_{false}; + bool isUnlimitedPolymorphic_{false}; + bool isAbstract_{false}; }; static std::optional CheckAllocateOptions( @@ -408,6 +404,7 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) { if (type_ == nullptr) { return false; } + GatherAllocationBasicInfo(); if (!IsVariableName(*name_.symbol)) { // C932 pre-requisite context.Say(name_.source, "Name in ALLOCATE statement must be a variable name"_err_en_US); diff --git a/flang/test/semantics/allocate11.f90 b/flang/test/semantics/allocate11.f90 index 19bf99ebdc7b..6237059722f6 100644 --- a/flang/test/semantics/allocate11.f90 +++ b/flang/test/semantics/allocate11.f90 @@ -16,7 +16,7 @@ ! TODO: Function Pointer in allocate and derived types! -! Rules I should know when working wit coarrays and derived type: +! Rules I should know when working with coarrays and derived type: ! C736: If EXTENDS appears and the type being defined has a coarray ultimate ! component, its parent type shall have a coarray ultimate component. @@ -67,12 +67,13 @@ subroutine C937(var) class(*), allocatable :: var ! unlimited polymorphic is the ONLY way to get an allocatable/pointer 'var' that can be - ! allocated with a type-spec T that has coarray ultimate component. - ! Rational: + ! allocated with a type-spec T that has coarray ultimate component without + ! violating other rules than C937. + ! Rationale: ! C934 => var must be type compatible with T. ! => var type is T, a type P extended by T, or unlimited polymorphic ! C825 => var cannot be of type T. - ! C736 => all parent type P of T must have a coarray unlimited component + ! C736 => all parent types P of T must have a coarray ultimate component ! => var cannot be of type P (C825) ! => if var can be defined, it can only be unlimited polymorphic