diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h index 716c4a9726942..0a9e7ce87be38 100644 --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -1189,7 +1189,10 @@ bool IsFunction(const Symbol &); bool IsFunction(const Scope &); bool IsProcedure(const Symbol &); bool IsProcedure(const Scope &); +bool IsProcedurePointer(const Symbol *); bool IsProcedurePointer(const Symbol &); +bool IsObjectPointer(const Symbol *); +bool IsAllocatableOrObjectPointer(const Symbol *); bool IsAutomatic(const Symbol &); bool IsSaved(const Symbol &); // saved implicitly or explicitly bool IsDummy(const Symbol &); diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h index 98ea0adc82932..1ba489fe21a72 100644 --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -237,7 +237,8 @@ class EntityDetails : public WithBindName { llvm::raw_ostream &, const EntityDetails &); }; -// Symbol is associated with a name or expression in a SELECT TYPE or ASSOCIATE. +// Symbol is associated with a name or expression in an ASSOCIATE, +// SELECT TYPE, or SELECT RANK construct. class AssocEntityDetails : public EntityDetails { public: AssocEntityDetails() {} @@ -252,7 +253,7 @@ class AssocEntityDetails : public EntityDetails { private: MaybeExpr expr_; - std::optional rank_; + std::optional rank_; // for SELECT RANK }; llvm::raw_ostream &operator<<(llvm::raw_ostream &, const AssocEntityDetails &); diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h index 27303b8fb3838..02d1a40a03c95 100644 --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -143,6 +143,7 @@ inline bool IsPointer(const Symbol &symbol) { inline bool IsAllocatable(const Symbol &symbol) { return symbol.attrs().test(Attr::ALLOCATABLE); } +// IsAllocatableOrObjectPointer() may be the better choice inline bool IsAllocatableOrPointer(const Symbol &symbol) { return IsPointer(symbol) || IsAllocatable(symbol); } diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index 0f3404999962f..45c54b37dd1d5 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -2221,7 +2221,7 @@ std::optional IntrinsicInterface::Match( if (dummy[*dimArg].optionality == Optionality::required) { if (const Symbol *whole{ UnwrapWholeSymbolOrComponentDataRef(actualForDummy[*dimArg])}) { - if (IsOptional(*whole) || IsAllocatableOrPointer(*whole)) { + if (IsOptional(*whole) || IsAllocatableOrObjectPointer(whole)) { if (rank == Rank::scalarIfDim || arrayRank.value_or(-1) == 1) { messages.Say( "The actual argument for DIM= is optional, pointer, or allocatable, and it is assumed to be present and equal to 1 at execution time"_port_en_US); diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp index 0daf03707515d..86777ac44745e 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -1158,7 +1158,8 @@ std::optional> DataConstantConversionExtension( bool IsAllocatableOrPointerObject( const Expr &expr, FoldingContext &context) { const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)}; - return (sym && semantics::IsAllocatableOrPointer(sym->GetUltimate())) || + return (sym && + semantics::IsAllocatableOrObjectPointer(&sym->GetUltimate())) || evaluate::IsObjectPointer(expr, context); } @@ -1388,17 +1389,39 @@ bool IsProcedure(const Scope &scope) { return symbol && IsProcedure(*symbol); } +bool IsProcedurePointer(const Symbol &original) { + const Symbol &symbol{GetAssociationRoot(original)}; + return IsPointer(symbol) && IsProcedure(symbol); +} + +bool IsProcedurePointer(const Symbol *symbol) { + return symbol && IsProcedurePointer(*symbol); +} + +bool IsObjectPointer(const Symbol *original) { + if (original) { + const Symbol &symbol{GetAssociationRoot(*original)}; + return IsPointer(symbol) && !IsProcedure(symbol); + } else { + return false; + } +} + +bool IsAllocatableOrObjectPointer(const Symbol *original) { + if (original) { + const Symbol &symbol{GetAssociationRoot(*original)}; + return IsAllocatable(symbol) || (IsPointer(symbol) && !IsProcedure(symbol)); + } else { + return false; + } +} + const Symbol *FindCommonBlockContaining(const Symbol &original) { const Symbol &root{GetAssociationRoot(original)}; const auto *details{root.detailsIf()}; return details ? details->commonBlock() : nullptr; } -bool IsProcedurePointer(const Symbol &original) { - const Symbol &symbol{GetAssociationRoot(original)}; - return IsPointer(symbol) && IsProcedure(symbol); -} - // 3.11 automatic data object bool IsAutomatic(const Symbol &original) { const Symbol &symbol{original.GetUltimate()}; @@ -1516,14 +1539,14 @@ bool IsAssumedShape(const Symbol &symbol) { const Symbol &ultimate{ResolveAssociations(symbol)}; const auto *object{ultimate.detailsIf()}; return object && object->CanBeAssumedShape() && - !semantics::IsAllocatableOrPointer(ultimate); + !semantics::IsAllocatableOrObjectPointer(&ultimate); } bool IsDeferredShape(const Symbol &symbol) { const Symbol &ultimate{ResolveAssociations(symbol)}; const auto *object{ultimate.detailsIf()}; return object && object->CanBeDeferredShape() && - semantics::IsAllocatableOrPointer(ultimate); + semantics::IsAllocatableOrObjectPointer(&ultimate); } bool IsFunctionResult(const Symbol &original) { diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp index bf66d2402eb9b..68f04875665ea 100644 --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -581,7 +581,7 @@ class FirConverter : public Fortran::lower::AbstractConverter { llvm::ArrayRef typeParams) -> mlir::Value { mlir::Value allocVal = builder->allocateLocal( loc, - Fortran::semantics::IsAllocatableOrPointer(hsym.GetUltimate()) + Fortran::semantics::IsAllocatableOrObjectPointer(&hsym.GetUltimate()) ? hSymType : symType, mangleName(sym), toStringRef(sym.GetUltimate().name()), diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp index ba2d4b6455715..7305215c39b9a 100644 --- a/flang/lib/Lower/ConvertExprToHLFIR.cpp +++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp @@ -129,7 +129,7 @@ class HlfirDesignatorBuilder { // shape is deferred and should not be loaded now to preserve // pointer/allocatable aspects. if (componentSym.Rank() == 0 || - Fortran::semantics::IsAllocatableOrPointer(componentSym)) + Fortran::semantics::IsAllocatableOrObjectPointer(&componentSym)) return mlir::Value{}; fir::FirOpBuilder &builder = getBuilder(); @@ -488,8 +488,8 @@ class HlfirDesignatorBuilder { // array ref designates the target (this is done in "visit"). Other // components need special care to deal with the array%array_comp(indices) // case. - if (Fortran::semantics::IsAllocatableOrPointer( - component->GetLastSymbol())) + if (Fortran::semantics::IsAllocatableOrObjectPointer( + &component->GetLastSymbol())) baseType = visit(*component, partInfo); else baseType = hlfir::getFortranElementOrSequenceType( @@ -734,7 +734,7 @@ class HlfirDesignatorBuilder { if (charTy.hasConstantLen()) partInfo.typeParams.push_back( builder.createIntegerConstant(loc, idxTy, charTy.getLen())); - else if (!Fortran::semantics::IsAllocatableOrPointer(componentSym)) + else if (!Fortran::semantics::IsAllocatableOrObjectPointer(&componentSym)) TODO(loc, "compute character length of automatic character component " "in a PDT"); // Otherwise, the length of the component is deferred and will only diff --git a/flang/lib/Lower/IO.cpp b/flang/lib/Lower/IO.cpp index a35b7a991b857..ac1fe7f68a9a6 100644 --- a/flang/lib/Lower/IO.cpp +++ b/flang/lib/Lower/IO.cpp @@ -498,7 +498,7 @@ getNamelistGroup(Fortran::lower::AbstractConverter &converter, // A global pointer or allocatable variable has a descriptor for typical // accesses. Variables in multiple namelist groups may already have one. // Create descriptors for other cases. - if (!IsAllocatableOrPointer(s)) { + if (!IsAllocatableOrObjectPointer(&s)) { std::string mangleName = Fortran::lower::mangle::globalNamelistDescriptorName(s); if (builder.getNamedGlobal(mangleName)) diff --git a/flang/lib/Lower/Mangler.cpp b/flang/lib/Lower/Mangler.cpp index dc0e0a09e6d0e..4ea6238eded00 100644 --- a/flang/lib/Lower/Mangler.cpp +++ b/flang/lib/Lower/Mangler.cpp @@ -277,5 +277,5 @@ std::string Fortran::lower::mangle::mangleArrayLiteral( std::string Fortran::lower::mangle::globalNamelistDescriptorName( const Fortran::semantics::Symbol &sym) { std::string name = mangleName(sym); - return IsAllocatableOrPointer(sym) ? name : name + ".desc"s; + return IsAllocatableOrObjectPointer(&sym) ? name : name + ".desc"s; } diff --git a/flang/lib/Lower/OpenMP.cpp b/flang/lib/Lower/OpenMP.cpp index 273dc688d8a4b..6decb0276636f 100644 --- a/flang/lib/Lower/OpenMP.cpp +++ b/flang/lib/Lower/OpenMP.cpp @@ -1553,7 +1553,8 @@ bool ClauseProcessor::processCopyin() const { checkAndCopyHostAssociateVar(&*mem, &insPt); break; } - if (Fortran::semantics::IsAllocatableOrPointer(sym->GetUltimate())) + if (Fortran::semantics::IsAllocatableOrObjectPointer( + &sym->GetUltimate())) TODO(converter.getCurrentLocation(), "pointer or allocatable variables in Copyin clause"); assert(sym->has() && @@ -1815,7 +1816,7 @@ static fir::GlobalOp globalInitialization( firOpBuilder.createGlobal(currentLocation, ty, globalName, linkage); // Create default initialization for non-character scalar. - if (Fortran::semantics::IsAllocatableOrPointer(sym)) { + if (Fortran::semantics::IsAllocatableOrObjectPointer(&sym)) { mlir::Type baseAddrType = ty.dyn_cast().getEleTy(); Fortran::lower::createGlobalInitialization( firOpBuilder, global, [&](fir::FirOpBuilder &b) { diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp index d4039b3177c59..12d795290d927 100644 --- a/flang/lib/Semantics/check-allocate.cpp +++ b/flang/lib/Semantics/check-allocate.cpp @@ -39,14 +39,14 @@ class AllocationCheckerHelper { public: AllocationCheckerHelper( const parser::Allocation &alloc, AllocateCheckerInfo &info) - : allocateInfo_{info}, allocateObject_{std::get( - alloc.t)}, + : allocateInfo_{info}, + allocateObject_{std::get(alloc.t)}, name_{parser::GetLastName(allocateObject_)}, - symbol_{name_.symbol ? &name_.symbol->GetUltimate() : nullptr}, + original_{name_.symbol ? &name_.symbol->GetUltimate() : nullptr}, + symbol_{original_ ? &ResolveAssociations(*original_) : nullptr}, type_{symbol_ ? symbol_->GetType() : nullptr}, - allocateShapeSpecRank_{ShapeSpecRank(alloc)}, rank_{symbol_ - ? symbol_->Rank() - : 0}, + allocateShapeSpecRank_{ShapeSpecRank(alloc)}, + rank_{original_ ? original_->Rank() : 0}, allocateCoarraySpecRank_{CoarraySpecRank(alloc)}, corank_{symbol_ ? symbol_->Corank() : 0} {} @@ -91,7 +91,8 @@ class AllocationCheckerHelper { AllocateCheckerInfo &allocateInfo_; const parser::AllocateObject &allocateObject_; const parser::Name &name_; - const Symbol *symbol_{nullptr}; + const Symbol *original_{nullptr}; // no USE or host association + const Symbol *symbol_{nullptr}; // no USE, host, or construct association const DeclTypeSpec *type_{nullptr}; const int allocateShapeSpecRank_; const int rank_{0}; @@ -558,17 +559,17 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) { } } } else { - // first part of C942 + // explicit shape-spec-list if (allocateShapeSpecRank_ != rank_) { context .Say(name_.source, "The number of shape specifications, when they appear, must match the rank of allocatable object"_err_en_US) - .Attach(symbol_->name(), "Declared here with rank %d"_en_US, rank_); + .Attach( + original_->name(), "Declared here with rank %d"_en_US, rank_); return false; } } - } else { - // C940 + } else { // allocating a scalar object if (hasAllocateShapeSpecList()) { context.Say(name_.source, "Shape specifications must not appear when allocatable object is scalar"_err_en_US); diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index 0469a72bcc731..c48c382218dc9 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -1430,7 +1430,7 @@ static void CheckTransfer(evaluate::ActualArguments &arguments, whole->name()); } else if (context.ShouldWarn( common::UsageWarning::TransferSizePresence) && - IsAllocatableOrPointer(*whole)) { + IsAllocatableOrObjectPointer(whole)) { messages.Say( "SIZE= argument that is allocatable or pointer must be present at execution; parenthesize to silence this warning"_warn_en_US); } diff --git a/flang/lib/Semantics/check-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp index e3aad077ed0db..798c580265609 100644 --- a/flang/lib/Semantics/check-deallocate.cpp +++ b/flang/lib/Semantics/check-deallocate.cpp @@ -19,20 +19,18 @@ namespace Fortran::semantics { void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) { for (const parser::AllocateObject &allocateObject : std::get>(deallocateStmt.t)) { - parser::CharBlock source; - const Symbol *symbol{nullptr}; common::visit( common::visitors{ [&](const parser::Name &name) { - source = name.source; - symbol = name.symbol; + const Symbol *symbol{ + name.symbol ? &name.symbol->GetUltimate() : nullptr}; + ; if (context_.HasError(symbol)) { // already reported an error } else if (!IsVariableName(*symbol)) { context_.Say(name.source, "Name in DEALLOCATE statement must be a variable name"_err_en_US); - } else if (!IsAllocatableOrPointer( - symbol->GetUltimate())) { // C932 + } else if (!IsAllocatableOrObjectPointer(symbol)) { // C936 context_.Say(name.source, "Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US); } else if (auto whyNot{WhyNotDefinable(name.source, @@ -61,30 +59,32 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) { [&](const parser::StructureComponent &structureComponent) { // Only perform structureComponent checks if it was successfully // analyzed by expression analysis. - source = structureComponent.component.source; - symbol = structureComponent.component.symbol; + auto source{structureComponent.component.source}; if (const auto *expr{GetExpr(context_, allocateObject)}) { - if (symbol) { - if (!IsAllocatableOrPointer(*symbol)) { // C932 - 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 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)); - } + if (const Symbol * + symbol{structureComponent.component.symbol + ? &structureComponent.component.symbol + ->GetUltimate() + : nullptr}; + !IsAllocatableOrObjectPointer(symbol)) { // F'2023 C936 + 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 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)); } } }, diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp index 6ff9b2250f922..62efd8b49d385 100644 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -731,7 +731,7 @@ void CheckHelper::CheckObjectEntity( "!DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure"_err_en_US); } if (IsPassedViaDescriptor(symbol)) { - if (IsAllocatableOrPointer(symbol)) { + if (IsAllocatableOrObjectPointer(&symbol)) { if (inExplicitInterface) { WarnIfNotInModuleFile( "!DIR$ IGNORE_TKR should not apply to an allocatable or pointer"_warn_en_US); diff --git a/flang/lib/Semantics/check-omp-structure.cpp b/flang/lib/Semantics/check-omp-structure.cpp index 5523dc939696a..ffd577aa20375 100644 --- a/flang/lib/Semantics/check-omp-structure.cpp +++ b/flang/lib/Semantics/check-omp-structure.cpp @@ -203,8 +203,8 @@ void OmpStructureChecker::CheckMultListItems() { "ALIGNED clause"_err_en_US, name->ToString()); } else if (!(IsBuiltinCPtr(*(name->symbol)) || - IsAllocatableOrPointer( - (name->symbol->GetUltimate())))) { + IsAllocatableOrObjectPointer( + &name->symbol->GetUltimate()))) { context_.Say(itr->second->source, "'%s' in ALIGNED clause must be of type C_PTR, POINTER or " "ALLOCATABLE"_err_en_US, diff --git a/flang/lib/Semantics/check-select-rank.cpp b/flang/lib/Semantics/check-select-rank.cpp index ab8a1f3fb7788..424f9b45d64cd 100644 --- a/flang/lib/Semantics/check-select-rank.cpp +++ b/flang/lib/Semantics/check-select-rank.cpp @@ -86,7 +86,7 @@ void SelectRankConstructChecker::Leave( .Attach(prevLocStar, "Previous use"_en_US); } if (saveSelSymbol && - IsAllocatableOrPointer(*saveSelSymbol)) { // C1155 + IsAllocatableOrPointer(*saveSelSymbol)) { // F'2023 C1160 context_.Say(parser::FindSourceLocation(selectRankStmtSel), "RANK (*) cannot be used when selector is " "POINTER or ALLOCATABLE"_err_en_US); diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp index c3826e7f29d7e..7e33357734fa7 100644 --- a/flang/lib/Semantics/definable.cpp +++ b/flang/lib/Semantics/definable.cpp @@ -169,7 +169,7 @@ static std::optional WhyNotDefinableLast(parser::CharBlock at, const Symbol &ultimate{original.GetUltimate()}; if (flags.test(DefinabilityFlag::PointerDefinition)) { if (flags.test(DefinabilityFlag::AcceptAllocatable)) { - if (!IsAllocatableOrPointer(ultimate)) { + if (!IsAllocatableOrObjectPointer(&ultimate)) { return BlameSymbol( at, "'%s' is neither a pointer nor an allocatable"_en_US, original); } diff --git a/flang/lib/Semantics/resolve-directives.cpp b/flang/lib/Semantics/resolve-directives.cpp index c60c693072f49..84f00ef82755e 100644 --- a/flang/lib/Semantics/resolve-directives.cpp +++ b/flang/lib/Semantics/resolve-directives.cpp @@ -1113,7 +1113,7 @@ void AccAttributeVisitor::EnsureAllocatableOrPointer( common::visitors{ [&](const parser::Designator &designator) { const auto &lastName{GetLastName(designator)}; - if (!IsAllocatableOrPointer(*lastName.symbol)) { + if (!IsAllocatableOrObjectPointer(lastName.symbol)) { context_.Say(designator.source, "Argument `%s` on the %s clause must be a variable or " "array with the POINTER or ALLOCATABLE attribute"_err_en_US, diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index c401e9214524b..2a0f4ab9f4171 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -6942,7 +6942,11 @@ void ConstructVisitor::Post(const parser::TypeGuardStmt::Guard &x) { void ConstructVisitor::Post(const parser::SelectRankCaseStmt::Rank &x) { if (auto *symbol{MakeAssocEntity()}) { SetTypeFromAssociation(*symbol); - SetAttrsFromAssociation(*symbol); + // Don't call SetAttrsFromAssociation() for SELECT RANK. + symbol->attrs() |= + evaluate::GetAttrs(GetCurrentAssociation().selector.expr) & + Attrs{Attr::ALLOCATABLE, Attr::ASYNCHRONOUS, Attr::POINTER, + Attr::TARGET, Attr::VOLATILE}; if (const auto *init{std::get_if(&x.u)}) { if (auto val{EvaluateInt64(context(), *init)}) { auto &details{symbol->get()}; @@ -7039,6 +7043,7 @@ void ConstructVisitor::SetTypeFromAssociation(Symbol &symbol) { } // If current selector is a variable, set some of its attributes on symbol. +// For ASSOCIATE, CHANGE TEAM, and SELECT TYPE only; not SELECT RANK. void ConstructVisitor::SetAttrsFromAssociation(Symbol &symbol) { Attrs attrs{evaluate::GetAttrs(GetCurrentAssociation().selector.expr)}; symbol.attrs() |= diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp index 075b7f94c4cfa..7c523971e8e24 100644 --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -1208,13 +1208,13 @@ ComponentIterator::const_iterator::PlanComponentTraversal( // Order Component (only visit parents) traverse = component.test(Symbol::Flag::ParentComp); } else if constexpr (componentKind == ComponentKind::Direct) { - traverse = !IsAllocatableOrPointer(component); + traverse = !IsAllocatableOrObjectPointer(&component); } else if constexpr (componentKind == ComponentKind::Ultimate) { - traverse = !IsAllocatableOrPointer(component); + traverse = !IsAllocatableOrObjectPointer(&component); } else if constexpr (componentKind == ComponentKind::Potential) { traverse = !IsPointer(component); } else if constexpr (componentKind == ComponentKind::Scope) { - traverse = !IsAllocatableOrPointer(component); + traverse = !IsAllocatableOrObjectPointer(&component); } else if constexpr (componentKind == ComponentKind::PotentialAndPointer) { traverse = !IsPointer(component); @@ -1248,7 +1248,7 @@ static bool StopAtComponentPre(const Symbol &component) { return true; } else if constexpr (componentKind == ComponentKind::Ultimate) { return component.has() || - IsAllocatableOrPointer(component) || + IsAllocatableOrObjectPointer(&component) || (component.get().type() && component.get().type()->AsIntrinsic()); } else if constexpr (componentKind == ComponentKind::Potential) { diff --git a/flang/test/Semantics/select-rank03.f90 b/flang/test/Semantics/select-rank03.f90 new file mode 100644 index 0000000000000..038380435d00d --- /dev/null +++ b/flang/test/Semantics/select-rank03.f90 @@ -0,0 +1,115 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +program test + real, allocatable :: a0, a1(:) + real, pointer :: p0, p1(:) + real, target :: t0, t1(1) + contains + subroutine allocatables(a) + real, allocatable :: a(..) + !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE + select rank(a) + rank (0) + allocate(a) ! ok + deallocate(a) ! ok + allocate(a, source=a0) ! ok + allocate(a, mold=p0) ! ok + a = 1. ! ok + !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches scalar REAL(4) and rank 1 array of REAL(4) + a = [1.] + !ERROR: If SOURCE appears, the related expression must be scalar or have the same rank as each allocatable object in ALLOCATE + allocate(a, source=a1) + allocate(a, mold=p1) ! ok, mold= ignored + rank (1) + allocate(a(1)) ! ok + deallocate(a) ! ok + a = 1. ! ok + a = [1.] ! ok + !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD + allocate(a, source=a0) + !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD + allocate(a, mold=p0) + allocate(a, source=a1) ! ok + allocate(a, mold=p1) ! ok + rank (2) + allocate(a(1,1)) ! ok + deallocate(a) ! ok + a = 1. ! ok + !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches rank 2 array of REAL(4) and rank 1 array of REAL(4) + a = [1.] + !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD + allocate(a, source=a0) + !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD + allocate(a, mold=p0) + !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD + allocate(a, source=a1) + !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD + allocate(a, mold=p1) + rank (*) + !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD + allocate(a) + deallocate(a) + a = 1. + rank default + !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD + allocate(a) + deallocate(a) + a = 1. + end select + end + subroutine pointers(p) + real, pointer :: p(..) + !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE + select rank(p) + rank (0) + allocate(p) ! ok + deallocate(p) ! ok + allocate(p, source=a0) ! ok + allocate(p, mold=p0) ! ok + !ERROR: If SOURCE appears, the related expression must be scalar or have the same rank as each allocatable object in ALLOCATE + allocate(p, source=a1) + allocate(p, mold=p1) ! ok, mold ignored + p => t0 ! ok + !ERROR: Pointer has rank 0 but target has rank 1 + p => t1 + rank (1) + allocate(p(1)) ! ok + deallocate(p) ! ok + !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD + allocate(p, source=a0) + !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD + allocate(p, mold=p0) + allocate(p, source=a1) ! ok + allocate(p, mold=p1) ! ok + !ERROR: Pointer has rank 1 but target has rank 0 + p => t0 + p => t1 ! ok + rank (2) + allocate(p(1,1)) ! ok + deallocate(p) ! ok + !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD + allocate(p, source=a0) + !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD + allocate(p, mold=p0) + !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD + allocate(p, source=a1) + !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD + allocate(p, mold=p1) + !ERROR: Pointer has rank 2 but target has rank 0 + p => t0 + !ERROR: Pointer has rank 2 but target has rank 1 + p => t1 + rank (*) + !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD + allocate(p) + deallocate(p) + rank default + !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD + allocate(p) + deallocate(p) + !ERROR: pointer 'p' associated with object 't0' with incompatible type or shape + p => t0 + !ERROR: pointer 'p' associated with object 't1' with incompatible type or shape + p => t1 + end select + end +end