Index: flang/include/flang/Evaluate/tools.h =================================================================== --- flang/include/flang/Evaluate/tools.h +++ flang/include/flang/Evaluate/tools.h @@ -1189,7 +1189,10 @@ 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 &); Index: flang/include/flang/Semantics/symbol.h =================================================================== --- flang/include/flang/Semantics/symbol.h +++ flang/include/flang/Semantics/symbol.h @@ -237,7 +237,8 @@ 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 @@ private: MaybeExpr expr_; - std::optional rank_; + std::optional rank_; // for SELECT RANK }; llvm::raw_ostream &operator<<(llvm::raw_ostream &, const AssocEntityDetails &); Index: flang/include/flang/Semantics/tools.h =================================================================== --- flang/include/flang/Semantics/tools.h +++ flang/include/flang/Semantics/tools.h @@ -143,6 +143,7 @@ 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); } Index: flang/lib/Evaluate/intrinsics.cpp =================================================================== --- flang/lib/Evaluate/intrinsics.cpp +++ flang/lib/Evaluate/intrinsics.cpp @@ -2219,7 +2219,7 @@ 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); Index: flang/lib/Evaluate/tools.cpp =================================================================== --- flang/lib/Evaluate/tools.cpp +++ flang/lib/Evaluate/tools.cpp @@ -1158,7 +1158,8 @@ 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 @@ 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 @@ 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) { Index: flang/lib/Lower/Bridge.cpp =================================================================== --- flang/lib/Lower/Bridge.cpp +++ flang/lib/Lower/Bridge.cpp @@ -581,7 +581,7 @@ 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()), Index: flang/lib/Lower/ConvertExprToHLFIR.cpp =================================================================== --- flang/lib/Lower/ConvertExprToHLFIR.cpp +++ flang/lib/Lower/ConvertExprToHLFIR.cpp @@ -129,7 +129,7 @@ // 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 @@ // 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 @@ 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 Index: flang/lib/Lower/IO.cpp =================================================================== --- flang/lib/Lower/IO.cpp +++ flang/lib/Lower/IO.cpp @@ -498,7 +498,7 @@ // 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)) Index: flang/lib/Lower/Mangler.cpp =================================================================== --- flang/lib/Lower/Mangler.cpp +++ flang/lib/Lower/Mangler.cpp @@ -277,5 +277,5 @@ 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; } Index: flang/lib/Lower/OpenMP.cpp =================================================================== --- flang/lib/Lower/OpenMP.cpp +++ flang/lib/Lower/OpenMP.cpp @@ -1553,7 +1553,8 @@ 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 @@ 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) { Index: flang/lib/Semantics/check-allocate.cpp =================================================================== --- flang/lib/Semantics/check-allocate.cpp +++ flang/lib/Semantics/check-allocate.cpp @@ -39,14 +39,14 @@ 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 @@ 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 @@ } } } 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); Index: flang/lib/Semantics/check-call.cpp =================================================================== --- flang/lib/Semantics/check-call.cpp +++ flang/lib/Semantics/check-call.cpp @@ -1430,7 +1430,7 @@ 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); } Index: flang/lib/Semantics/check-deallocate.cpp =================================================================== --- flang/lib/Semantics/check-deallocate.cpp +++ flang/lib/Semantics/check-deallocate.cpp @@ -19,20 +19,18 @@ 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 @@ [&](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)); } } }, Index: flang/lib/Semantics/check-declarations.cpp =================================================================== --- flang/lib/Semantics/check-declarations.cpp +++ flang/lib/Semantics/check-declarations.cpp @@ -731,7 +731,7 @@ "!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); Index: flang/lib/Semantics/check-omp-structure.cpp =================================================================== --- flang/lib/Semantics/check-omp-structure.cpp +++ flang/lib/Semantics/check-omp-structure.cpp @@ -203,8 +203,8 @@ "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, Index: flang/lib/Semantics/check-select-rank.cpp =================================================================== --- flang/lib/Semantics/check-select-rank.cpp +++ flang/lib/Semantics/check-select-rank.cpp @@ -86,7 +86,7 @@ .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); Index: flang/lib/Semantics/definable.cpp =================================================================== --- flang/lib/Semantics/definable.cpp +++ flang/lib/Semantics/definable.cpp @@ -169,7 +169,7 @@ 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); } Index: flang/lib/Semantics/resolve-directives.cpp =================================================================== --- flang/lib/Semantics/resolve-directives.cpp +++ flang/lib/Semantics/resolve-directives.cpp @@ -1113,7 +1113,7 @@ 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, Index: flang/lib/Semantics/resolve-names.cpp =================================================================== --- flang/lib/Semantics/resolve-names.cpp +++ flang/lib/Semantics/resolve-names.cpp @@ -6923,7 +6923,11 @@ 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()}; @@ -7020,6 +7024,7 @@ } // 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() |= Index: flang/lib/Semantics/tools.cpp =================================================================== --- flang/lib/Semantics/tools.cpp +++ flang/lib/Semantics/tools.cpp @@ -1208,13 +1208,13 @@ // 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 @@ 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) { Index: flang/test/Semantics/select-rank03.f90 =================================================================== --- /dev/null +++ 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