840 lines · cpp
1//===-- lib/Semantics/check-allocate.cpp ----------------------------------===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8 9#include "check-allocate.h"10#include "assignment.h"11#include "definable.h"12#include "flang/Evaluate/fold.h"13#include "flang/Evaluate/shape.h"14#include "flang/Evaluate/type.h"15#include "flang/Parser/parse-tree.h"16#include "flang/Parser/tools.h"17#include "flang/Semantics/attr.h"18#include "flang/Semantics/expression.h"19#include "flang/Semantics/tools.h"20#include "flang/Semantics/type.h"21 22namespace Fortran::semantics {23 24struct AllocateCheckerInfo {25 const DeclTypeSpec *typeSpec{nullptr};26 std::optional<evaluate::DynamicType> sourceExprType;27 std::optional<parser::CharBlock> sourceExprLoc;28 std::optional<parser::CharBlock> typeSpecLoc;29 std::optional<parser::CharBlock> statSource;30 std::optional<parser::CharBlock> msgSource;31 const SomeExpr *statVar{nullptr};32 const SomeExpr *msgVar{nullptr};33 int sourceExprRank{0}; // only valid if gotMold || gotSource34 bool gotStat{false};35 bool gotMsg{false};36 bool gotTypeSpec{false};37 bool gotSource{false};38 bool gotMold{false};39 bool gotStream{false};40 bool gotPinned{false};41 std::optional<evaluate::ConstantSubscripts> sourceExprShape;42};43 44class AllocationCheckerHelper {45public:46 AllocationCheckerHelper(47 const parser::Allocation &alloc, AllocateCheckerInfo &info)48 : allocateInfo_{info}, allocation_{alloc},49 allocateObject_{std::get<parser::AllocateObject>(alloc.t)},50 allocateShapeSpecRank_{ShapeSpecRank(alloc)},51 allocateCoarraySpecRank_{CoarraySpecRank(alloc)} {}52 53 bool RunChecks(SemanticsContext &context);54 55private:56 bool hasAllocateShapeSpecList() const { return allocateShapeSpecRank_ != 0; }57 bool hasAllocateCoarraySpec() const { return allocateCoarraySpecRank_ != 0; }58 bool RunCoarrayRelatedChecks(SemanticsContext &) const;59 60 static int ShapeSpecRank(const parser::Allocation &allocation) {61 return static_cast<int>(62 std::get<std::list<parser::AllocateShapeSpec>>(allocation.t).size());63 }64 65 static int CoarraySpecRank(const parser::Allocation &allocation) {66 if (const auto &coarraySpec{67 std::get<std::optional<parser::AllocateCoarraySpec>>(68 allocation.t)}) {69 return std::get<std::list<parser::AllocateCoshapeSpec>>(coarraySpec->t)70 .size() +71 1;72 } else {73 return 0;74 }75 }76 77 void GatherAllocationBasicInfo() {78 if (type_->category() == DeclTypeSpec::Category::Character) {79 hasDeferredTypeParameter_ =80 type_->characterTypeSpec().length().isDeferred();81 } else if (const DerivedTypeSpec * derivedTypeSpec{type_->AsDerived()}) {82 for (const auto &pair : derivedTypeSpec->parameters()) {83 hasDeferredTypeParameter_ |= pair.second.isDeferred();84 }85 isAbstract_ = derivedTypeSpec->typeSymbol().attrs().test(Attr::ABSTRACT);86 }87 isUnlimitedPolymorphic_ =88 type_->category() == DeclTypeSpec::Category::ClassStar;89 }90 91 AllocateCheckerInfo &allocateInfo_;92 const parser::Allocation &allocation_;93 const parser::AllocateObject &allocateObject_;94 const int allocateShapeSpecRank_{0};95 const int allocateCoarraySpecRank_{0};96 const parser::Name &name_{parser::GetLastName(allocateObject_)};97 // no USE or host association98 const Symbol *ultimate_{99 name_.symbol ? &name_.symbol->GetUltimate() : nullptr};100 const DeclTypeSpec *type_{ultimate_ ? ultimate_->GetType() : nullptr};101 const int rank_{ultimate_ ? ultimate_->Rank() : 0};102 const int corank_{ultimate_ ? ultimate_->Corank() : 0};103 bool hasDeferredTypeParameter_{false};104 bool isUnlimitedPolymorphic_{false};105 bool isAbstract_{false};106};107 108static std::optional<AllocateCheckerInfo> CheckAllocateOptions(109 const parser::AllocateStmt &allocateStmt, SemanticsContext &context) {110 AllocateCheckerInfo info;111 bool stopCheckingAllocate{false}; // for errors that would lead to ambiguity112 if (const auto &typeSpec{113 std::get<std::optional<parser::TypeSpec>>(allocateStmt.t)}) {114 info.typeSpec = typeSpec->declTypeSpec;115 if (!info.typeSpec) {116 CHECK(context.AnyFatalError());117 return std::nullopt;118 }119 info.gotTypeSpec = true;120 info.typeSpecLoc = parser::FindSourceLocation(*typeSpec);121 if (const DerivedTypeSpec * derived{info.typeSpec->AsDerived()}) {122 // C937123 if (auto it{FindCoarrayUltimateComponent(*derived)}) {124 context125 .Say(126 "Type-spec in ALLOCATE must not specify a type with a coarray ultimate component"_err_en_US)127 .Attach(it->name(),128 "Type '%s' has coarray ultimate component '%s' declared here"_en_US,129 info.typeSpec->AsFortran(), it.BuildResultDesignatorName());130 }131 }132 if (auto dyType{evaluate::DynamicType::From(*info.typeSpec)}) {133 if (dyType->HasDeferredTypeParameter()) {134 context.Say(135 "Type-spec in ALLOCATE must not have a deferred type parameter"_err_en_US);136 }137 }138 }139 140 const parser::Expr *parserSourceExpr{nullptr};141 for (const parser::AllocOpt &allocOpt :142 std::get<std::list<parser::AllocOpt>>(allocateStmt.t)) {143 common::visit(144 common::visitors{145 [&](const parser::StatOrErrmsg &statOrErr) {146 common::visit(147 common::visitors{148 [&](const parser::StatVariable &var) {149 if (info.gotStat) { // C943150 context.Say(151 "STAT may not be duplicated in a ALLOCATE statement"_err_en_US);152 }153 info.gotStat = true;154 info.statVar = GetExpr(context, var);155 info.statSource =156 parser::Unwrap<parser::Variable>(var)->GetSource();157 },158 [&](const parser::MsgVariable &var) {159 WarnOnDeferredLengthCharacterScalar(context,160 GetExpr(context, var),161 parser::UnwrapRef<parser::Variable>(var)162 .GetSource(),163 "ERRMSG=");164 if (info.gotMsg) { // C943165 context.Say(166 "ERRMSG may not be duplicated in a ALLOCATE statement"_err_en_US);167 }168 info.gotMsg = true;169 info.msgVar = GetExpr(context, var);170 info.msgSource =171 parser::Unwrap<parser::Variable>(var)->GetSource();172 },173 },174 statOrErr.u);175 },176 [&](const parser::AllocOpt::Source &source) {177 if (info.gotSource) { // C943178 context.Say(179 "SOURCE may not be duplicated in a ALLOCATE statement"_err_en_US);180 stopCheckingAllocate = true;181 }182 if (info.gotMold || info.gotTypeSpec) { // C944183 context.Say(184 "At most one of source-expr and type-spec may appear in a ALLOCATE statement"_err_en_US);185 stopCheckingAllocate = true;186 }187 parserSourceExpr = &source.v.value();188 info.gotSource = true;189 },190 [&](const parser::AllocOpt::Mold &mold) {191 if (info.gotMold) { // C943192 context.Say(193 "MOLD may not be duplicated in a ALLOCATE statement"_err_en_US);194 stopCheckingAllocate = true;195 }196 if (info.gotSource || info.gotTypeSpec) { // C944197 context.Say(198 "At most one of source-expr and type-spec may appear in a ALLOCATE statement"_err_en_US);199 stopCheckingAllocate = true;200 }201 parserSourceExpr = &mold.v.value();202 info.gotMold = true;203 },204 [&](const parser::AllocOpt::Stream &stream) { // CUDA205 if (info.gotStream) {206 context.Say(207 "STREAM may not be duplicated in a ALLOCATE statement"_err_en_US);208 stopCheckingAllocate = true;209 }210 info.gotStream = true;211 },212 [&](const parser::AllocOpt::Pinned &pinned) { // CUDA213 if (info.gotPinned) {214 context.Say(215 "PINNED may not be duplicated in a ALLOCATE statement"_err_en_US);216 stopCheckingAllocate = true;217 }218 info.gotPinned = true;219 },220 },221 allocOpt.u);222 }223 224 if (stopCheckingAllocate) {225 return std::nullopt;226 }227 228 if (info.gotSource || info.gotMold) {229 if (const auto *expr{GetExpr(context, DEREF(parserSourceExpr))}) {230 parser::CharBlock at{parserSourceExpr->source};231 info.sourceExprType = expr->GetType();232 if (!info.sourceExprType) {233 context.Say(at,234 "Typeless item not allowed as SOURCE or MOLD in ALLOCATE"_err_en_US);235 return std::nullopt;236 }237 info.sourceExprRank = expr->Rank();238 info.sourceExprLoc = parserSourceExpr->source;239 if (const DerivedTypeSpec *240 derived{evaluate::GetDerivedTypeSpec(info.sourceExprType)}) {241 // C949242 if (auto it{FindCoarrayUltimateComponent(*derived)}) {243 context244 .Say(at,245 "SOURCE or MOLD expression must not have a type with a coarray ultimate component"_err_en_US)246 .Attach(it->name(),247 "Type '%s' has coarray ultimate component '%s' declared here"_en_US,248 info.sourceExprType.value().AsFortran(),249 it.BuildResultDesignatorName());250 }251 if (info.gotSource) {252 // C948253 if (IsEventTypeOrLockType(derived)) {254 context.Say(at,255 "SOURCE expression type must not be EVENT_TYPE or LOCK_TYPE from ISO_FORTRAN_ENV"_err_en_US);256 } else if (auto it{FindEventOrLockPotentialComponent(*derived)}) {257 context258 .Say(at,259 "SOURCE expression type must not have potential subobject "260 "component"261 " of type EVENT_TYPE or LOCK_TYPE from ISO_FORTRAN_ENV"_err_en_US)262 .Attach(it->name(),263 "Type '%s' has potential ultimate component '%s' declared here"_en_US,264 info.sourceExprType.value().AsFortran(),265 it.BuildResultDesignatorName());266 }267 }268 }269 if (info.gotSource) { // C1594(6) - SOURCE= restrictions when pure270 const Scope &scope{context.FindScope(at)};271 if (FindPureProcedureContaining(scope)) {272 parser::ContextualMessages messages{at, &context.messages()};273 CheckCopyabilityInPureScope(messages, *expr, scope);274 }275 }276 auto maybeShape{evaluate::GetShape(context.foldingContext(), *expr)};277 info.sourceExprShape =278 evaluate::AsConstantExtents(context.foldingContext(), maybeShape);279 } else {280 // Error already reported on source expression.281 // Do not continue allocate checks.282 return std::nullopt;283 }284 }285 286 return info;287}288 289// Beware, type compatibility is not symmetric, IsTypeCompatible checks that290// type1 is type compatible with type2. Note: type parameters are not considered291// in this test.292static bool IsTypeCompatible(293 const DeclTypeSpec &type1, const DerivedTypeSpec &derivedType2) {294 if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {295 if (type1.category() == DeclTypeSpec::Category::TypeDerived) {296 return evaluate::AreSameDerivedTypeIgnoringTypeParameters(297 *derivedType1, derivedType2);298 } else if (type1.category() == DeclTypeSpec::Category::ClassDerived) {299 for (const DerivedTypeSpec *parent{&derivedType2}; parent;300 parent = parent->typeSymbol().GetParentTypeSpec()) {301 if (evaluate::AreSameDerivedTypeIgnoringTypeParameters(302 *derivedType1, *parent)) {303 return true;304 }305 }306 }307 }308 return false;309}310 311static bool IsTypeCompatible(312 const DeclTypeSpec &type1, const DeclTypeSpec &type2) {313 if (type1.category() == DeclTypeSpec::Category::ClassStar) {314 // TypeStar does not make sense in allocate context because assumed type315 // cannot be allocatable (C709)316 return true;317 }318 if (const IntrinsicTypeSpec * intrinsicType2{type2.AsIntrinsic()}) {319 if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {320 return intrinsicType1->category() == intrinsicType2->category();321 } else {322 return false;323 }324 } else if (const DerivedTypeSpec * derivedType2{type2.AsDerived()}) {325 return IsTypeCompatible(type1, *derivedType2);326 }327 return false;328}329 330static bool IsTypeCompatible(331 const DeclTypeSpec &type1, const evaluate::DynamicType &type2) {332 if (type1.category() == DeclTypeSpec::Category::ClassStar) {333 // TypeStar does not make sense in allocate context because assumed type334 // cannot be allocatable (C709)335 return true;336 }337 if (type2.category() != evaluate::TypeCategory::Derived) {338 if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {339 return intrinsicType1->category() == type2.category();340 } else {341 return false;342 }343 } else if (!type2.IsUnlimitedPolymorphic()) {344 return IsTypeCompatible(type1, type2.GetDerivedTypeSpec());345 }346 return false;347}348 349// Note: Check assumes type1 is compatible with type2. type2 may have more type350// parameters than type1 but if a type2 type parameter is assumed, then this351// check enforce that type1 has it. type1 can be unlimited polymorphic, but not352// type2.353static bool HaveSameAssumedTypeParameters(354 const DeclTypeSpec &type1, const DeclTypeSpec &type2) {355 if (type2.category() == DeclTypeSpec::Category::Character) {356 bool type2LengthIsAssumed{type2.characterTypeSpec().length().isAssumed()};357 if (type1.category() == DeclTypeSpec::Category::Character) {358 return type1.characterTypeSpec().length().isAssumed() ==359 type2LengthIsAssumed;360 }361 // It is possible to reach this if type1 is unlimited polymorphic362 return !type2LengthIsAssumed;363 } else if (const DerivedTypeSpec * derivedType2{type2.AsDerived()}) {364 int type2AssumedParametersCount{0};365 int type1AssumedParametersCount{0};366 for (const auto &pair : derivedType2->parameters()) {367 type2AssumedParametersCount += pair.second.isAssumed();368 }369 // type1 may be unlimited polymorphic370 if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {371 for (auto it{derivedType1->parameters().begin()};372 it != derivedType1->parameters().end(); ++it) {373 if (it->second.isAssumed()) {374 ++type1AssumedParametersCount;375 const ParamValue *param{derivedType2->FindParameter(it->first)};376 if (!param || !param->isAssumed()) {377 // type1 has an assumed parameter that is not a type parameter of378 // type2 or not assumed in type2.379 return false;380 }381 }382 }383 }384 // Will return false if type2 has type parameters that are not assumed in385 // type1 or do not exist in type1386 return type1AssumedParametersCount == type2AssumedParametersCount;387 }388 return true; // other intrinsic types have no length type parameters389}390 391static std::optional<std::int64_t> GetTypeParameterInt64Value(392 const Symbol ¶meterSymbol, const DerivedTypeSpec &derivedType) {393 if (const ParamValue *394 paramValue{derivedType.FindParameter(parameterSymbol.name())}) {395 return evaluate::ToInt64(paramValue->GetExplicit());396 }397 return std::nullopt;398}399 400static bool HaveCompatibleTypeParameters(401 const DerivedTypeSpec &derivedType1, const DerivedTypeSpec &derivedType2) {402 for (const Symbol &symbol :403 OrderParameterDeclarations(derivedType1.typeSymbol())) {404 auto v1{GetTypeParameterInt64Value(symbol, derivedType1)};405 auto v2{GetTypeParameterInt64Value(symbol, derivedType2)};406 if (v1 && v2 && *v1 != *v2) {407 return false;408 }409 }410 return true;411}412 413static bool HaveCompatibleTypeParameters(414 const DeclTypeSpec &type1, const evaluate::DynamicType &type2) {415 if (type1.category() == DeclTypeSpec::Category::ClassStar) {416 return true;417 }418 if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {419 return evaluate::ToInt64(intrinsicType1->kind()).value() == type2.kind();420 } else if (type2.IsUnlimitedPolymorphic()) {421 return false;422 } else if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {423 return HaveCompatibleTypeParameters(424 *derivedType1, type2.GetDerivedTypeSpec());425 } else {426 common::die("unexpected type1 category");427 }428}429 430static bool HaveCompatibleTypeParameters(431 const DeclTypeSpec &type1, const DeclTypeSpec &type2) {432 if (type1.category() == DeclTypeSpec::Category::ClassStar) {433 return true;434 } else if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {435 const IntrinsicTypeSpec *intrinsicType2{type2.AsIntrinsic()};436 return !intrinsicType2 || intrinsicType1->kind() == intrinsicType2->kind();437 } else if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {438 const DerivedTypeSpec *derivedType2{type2.AsDerived()};439 return !derivedType2 ||440 HaveCompatibleTypeParameters(*derivedType1, *derivedType2);441 } else {442 common::die("unexpected type1 category");443 }444}445 446static bool HaveCompatibleLengths(447 const DeclTypeSpec &type1, const DeclTypeSpec &type2) {448 if (type1.category() == DeclTypeSpec::Character &&449 type2.category() == DeclTypeSpec::Character) {450 auto v1{451 evaluate::ToInt64(type1.characterTypeSpec().length().GetExplicit())};452 auto v2{453 evaluate::ToInt64(type2.characterTypeSpec().length().GetExplicit())};454 return !v1 || !v2 || (*v1 >= 0 ? *v1 : 0) == (*v2 >= 0 ? *v2 : 0);455 } else {456 return true;457 }458}459 460static bool HaveCompatibleLengths(461 const DeclTypeSpec &type1, const evaluate::DynamicType &type2) {462 if (type1.category() == DeclTypeSpec::Character &&463 type2.category() == TypeCategory::Character) {464 auto v1{465 evaluate::ToInt64(type1.characterTypeSpec().length().GetExplicit())};466 auto v2{type2.knownLength()};467 return !v1 || !v2 || (*v1 >= 0 ? *v1 : 0) == (*v2 >= 0 ? *v2 : 0);468 } else {469 return true;470 }471}472 473bool AreSameAllocation(const SomeExpr *root, const SomeExpr *path) {474 if (root && path) {475 // For now we just use equality of expressions. If we implement a more476 // sophisticated alias analysis we should use it here.477 return *root == *path;478 } else {479 return false;480 }481}482 483bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {484 if (!ultimate_) {485 CHECK(context.AnyFatalError());486 return false;487 }488 if (!IsVariableName(*ultimate_)) { // C932 pre-requisite489 context.Say(name_.source,490 "Name in ALLOCATE statement must be a variable name"_err_en_US);491 return false;492 }493 if (!type_) {494 // This is done after variable check because a user could have put495 // a subroutine name in allocate for instance which is a symbol with496 // no type.497 CHECK(context.AnyFatalError());498 return false;499 }500 GatherAllocationBasicInfo();501 if (!IsAllocatableOrObjectPointer(ultimate_)) { // C932502 context.Say(name_.source,503 "Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);504 return false;505 }506 bool gotSourceExprOrTypeSpec{allocateInfo_.gotMold ||507 allocateInfo_.gotTypeSpec || allocateInfo_.gotSource};508 if (hasDeferredTypeParameter_ && !gotSourceExprOrTypeSpec) {509 // C933510 context.Say(name_.source,511 "Either type-spec or source-expr must appear in ALLOCATE when allocatable object has a deferred type parameters"_err_en_US);512 return false;513 }514 if (isUnlimitedPolymorphic_ && !gotSourceExprOrTypeSpec) {515 // C933516 context.Say(name_.source,517 "Either type-spec or source-expr must appear in ALLOCATE when allocatable object is unlimited polymorphic"_err_en_US);518 return false;519 }520 if (isAbstract_ && !gotSourceExprOrTypeSpec) {521 // C933522 context.Say(name_.source,523 "Either type-spec or source-expr must appear in ALLOCATE when allocatable object is of abstract type"_err_en_US);524 return false;525 }526 if (allocateInfo_.gotTypeSpec) {527 if (!IsTypeCompatible(*type_, *allocateInfo_.typeSpec)) {528 // C934529 context.Say(name_.source,530 "Allocatable object in ALLOCATE must be type compatible with type-spec"_err_en_US);531 return false;532 }533 if (!HaveCompatibleTypeParameters(*type_, *allocateInfo_.typeSpec)) {534 context.Say(name_.source,535 // C936536 "Type parameters of allocatable object in ALLOCATE must be the same as the corresponding ones in type-spec"_err_en_US);537 return false;538 }539 if (!HaveCompatibleLengths(*type_, *allocateInfo_.typeSpec)) { // C934540 context.Say(name_.source,541 "Character length of allocatable object in ALLOCATE must be the same as the type-spec"_err_en_US);542 return false;543 }544 if (!HaveSameAssumedTypeParameters(*type_, *allocateInfo_.typeSpec)) {545 // C935546 context.Say(name_.source,547 "Type parameters in type-spec must be assumed if and only if they are assumed for allocatable object in ALLOCATE"_err_en_US);548 return false;549 }550 } else if (allocateInfo_.gotSource || allocateInfo_.gotMold) {551 if (!IsTypeCompatible(*type_, allocateInfo_.sourceExprType.value())) {552 // first part of C945553 context.Say(name_.source,554 "Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE"_err_en_US);555 return false;556 }557 if (!HaveCompatibleTypeParameters(558 *type_, allocateInfo_.sourceExprType.value())) {559 // C946560 context.Say(name_.source,561 "Derived type parameters of allocatable object must be the same as the corresponding ones of SOURCE or MOLD expression"_err_en_US);562 return false;563 }564 // Character length distinction is allowed, with a warning565 if (!HaveCompatibleLengths(566 *type_, allocateInfo_.sourceExprType.value())) { // F'2023 C950567 context.Warn(common::LanguageFeature::AllocateToOtherLength, name_.source,568 "Character length of allocatable object in ALLOCATE should be the same as the SOURCE or MOLD"_port_en_US);569 return false;570 }571 }572 // Shape related checks573 if (ultimate_ && IsAssumedRank(*ultimate_)) {574 context.Say(name_.source,575 "An assumed-rank dummy argument may not appear in an ALLOCATE statement"_err_en_US);576 return false;577 }578 if (ultimate_ && IsAssumedSizeArray(*ultimate_) && context.AnyFatalError()) {579 // An assumed-size dummy array or RANK(*) case of SELECT RANK will have580 // already been diagnosed; don't pile on.581 return false;582 }583 if (rank_ > 0) {584 if (!hasAllocateShapeSpecList()) {585 // C939586 if (!(allocateInfo_.gotSource || allocateInfo_.gotMold)) {587 context.Say(name_.source,588 "Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD"_err_en_US);589 return false;590 } else {591 if (allocateInfo_.sourceExprRank != rank_) {592 context593 .Say(name_.source,594 "Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD"_err_en_US)595 .Attach(allocateInfo_.sourceExprLoc.value(),596 "Expression in %s has rank %d but allocatable object has rank %d"_en_US,597 allocateInfo_.gotSource ? "SOURCE" : "MOLD",598 allocateInfo_.sourceExprRank, rank_);599 return false;600 }601 }602 } else {603 // explicit shape-spec-list604 if (allocateShapeSpecRank_ != rank_) {605 context606 .Say(name_.source,607 "The number of shape specifications, when they appear, must match the rank of allocatable object"_err_en_US)608 .Attach(609 ultimate_->name(), "Declared here with rank %d"_en_US, rank_);610 return false;611 } else if (allocateInfo_.gotSource && allocateInfo_.sourceExprShape &&612 allocateInfo_.sourceExprShape->size() ==613 static_cast<std::size_t>(allocateShapeSpecRank_)) {614 std::size_t j{0};615 for (const auto &shapeSpec :616 std::get<std::list<parser::AllocateShapeSpec>>(allocation_.t)) {617 if (j >= allocateInfo_.sourceExprShape->size()) {618 break;619 }620 std::optional<evaluate::ConstantSubscript> lbound;621 if (const auto &lb{std::get<0>(shapeSpec.t)}) {622 lbound.reset();623 const auto &lbExpr{parser::UnwrapRef<parser::Expr>(lb)};624 if (const auto *expr{GetExpr(context, lbExpr)}) {625 auto folded{626 evaluate::Fold(context.foldingContext(), SomeExpr(*expr))};627 lbound = evaluate::ToInt64(folded);628 evaluate::SetExpr(lbExpr, std::move(folded));629 }630 } else {631 lbound = 1;632 }633 if (lbound) {634 const auto &ubExpr{635 parser::UnwrapRef<parser::Expr>(std::get<1>(shapeSpec.t))};636 if (const auto *expr{GetExpr(context, ubExpr)}) {637 auto folded{638 evaluate::Fold(context.foldingContext(), SomeExpr(*expr))};639 auto ubound{evaluate::ToInt64(folded)};640 evaluate::SetExpr(ubExpr, std::move(folded));641 if (ubound) {642 auto extent{*ubound - *lbound + 1};643 if (extent < 0) {644 extent = 0;645 }646 if (extent != allocateInfo_.sourceExprShape->at(j)) {647 context.Say(name_.source,648 "Allocation has extent %jd on dimension %d, but SOURCE= has extent %jd"_err_en_US,649 static_cast<std::intmax_t>(extent), j + 1,650 static_cast<std::intmax_t>(651 allocateInfo_.sourceExprShape->at(j)));652 }653 }654 }655 }656 ++j;657 }658 }659 }660 } else { // allocating a scalar object661 if (hasAllocateShapeSpecList()) {662 context.Say(name_.source,663 "Shape specifications must not appear when allocatable object is scalar"_err_en_US);664 return false;665 }666 }667 // second and last part of C945668 if (allocateInfo_.gotSource && allocateInfo_.sourceExprRank &&669 allocateInfo_.sourceExprRank != rank_) {670 context671 .Say(name_.source,672 "If SOURCE appears, the related expression must be scalar or have the same rank as each allocatable object in ALLOCATE"_err_en_US)673 .Attach(allocateInfo_.sourceExprLoc.value(),674 "SOURCE expression has rank %d"_en_US, allocateInfo_.sourceExprRank)675 .Attach(ultimate_->name(),676 "Allocatable object declared here with rank %d"_en_US, rank_);677 return false;678 }679 context.CheckIndexVarRedefine(name_);680 const Scope &subpScope{681 GetProgramUnitContaining(context.FindScope(name_.source))};682 if (allocateObject_.typedExpr && allocateObject_.typedExpr->v) {683 DefinabilityFlags flags{DefinabilityFlag::PointerDefinition,684 DefinabilityFlag::AcceptAllocatable};685 if (allocateInfo_.gotSource) {686 flags.set(DefinabilityFlag::SourcedAllocation);687 }688 if (auto whyNot{WhyNotDefinable(689 name_.source, subpScope, flags, *allocateObject_.typedExpr->v)}) {690 context691 .Say(name_.source,692 "Name in ALLOCATE statement is not definable"_err_en_US)693 .Attach(std::move(whyNot->set_severity(parser::Severity::Because)));694 return false;695 }696 }697 if (allocateInfo_.gotPinned) {698 std::optional<common::CUDADataAttr> cudaAttr{GetCUDADataAttr(ultimate_)};699 if ((!cudaAttr || *cudaAttr != common::CUDADataAttr::Pinned) &&700 context.languageFeatures().ShouldWarn(701 common::UsageWarning::CUDAUsage)) {702 context.Say(name_.source,703 "Object in ALLOCATE should have PINNED attribute when PINNED option is specified"_warn_en_US);704 }705 }706 if (allocateInfo_.gotStream) {707 std::optional<common::CUDADataAttr> cudaAttr{GetCUDADataAttr(ultimate_)};708 if (!cudaAttr || *cudaAttr != common::CUDADataAttr::Device) {709 context.Say(name_.source,710 "Object in ALLOCATE must have DEVICE attribute when STREAM option is specified"_err_en_US);711 }712 }713 714 if (const SomeExpr *allocObj{GetExpr(context, allocateObject_)}) {715 if (AreSameAllocation(allocObj, allocateInfo_.statVar)) {716 context.Say(allocateInfo_.statSource.value_or(name_.source),717 "STAT variable in ALLOCATE must not be the variable being allocated"_err_en_US);718 }719 if (AreSameAllocation(allocObj, allocateInfo_.msgVar)) {720 context.Say(allocateInfo_.msgSource.value_or(name_.source),721 "ERRMSG variable in ALLOCATE must not be the variable being allocated"_err_en_US);722 }723 }724 return RunCoarrayRelatedChecks(context);725}726 727bool AllocationCheckerHelper::RunCoarrayRelatedChecks(728 SemanticsContext &context) const {729 if (!ultimate_) {730 CHECK(context.AnyFatalError());731 return false;732 }733 if (evaluate::IsCoarray(*ultimate_)) {734 if (allocateInfo_.gotTypeSpec) {735 // C938736 if (const DerivedTypeSpec *737 derived{allocateInfo_.typeSpec->AsDerived()}) {738 if (IsTeamType(derived)) {739 context740 .Say(allocateInfo_.typeSpecLoc.value(),741 "Type-Spec in ALLOCATE must not be TEAM_TYPE from ISO_FORTRAN_ENV when an allocatable object is a coarray"_err_en_US)742 .Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);743 return false;744 } else if (IsIsoCType(derived)) {745 context746 .Say(allocateInfo_.typeSpecLoc.value(),747 "Type-Spec in ALLOCATE must not be C_PTR or C_FUNPTR from ISO_C_BINDING when an allocatable object is a coarray"_err_en_US)748 .Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);749 return false;750 }751 }752 } else if (allocateInfo_.gotSource || allocateInfo_.gotMold) {753 // C948754 const evaluate::DynamicType &sourceType{755 allocateInfo_.sourceExprType.value()};756 if (const auto *derived{evaluate::GetDerivedTypeSpec(sourceType)}) {757 if (IsTeamType(derived)) {758 context759 .Say(allocateInfo_.sourceExprLoc.value(),760 "SOURCE or MOLD expression type must not be TEAM_TYPE from ISO_FORTRAN_ENV when an allocatable object is a coarray"_err_en_US)761 .Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);762 return false;763 } else if (IsIsoCType(derived)) {764 context765 .Say(allocateInfo_.sourceExprLoc.value(),766 "SOURCE or MOLD expression type must not be C_PTR or C_FUNPTR from ISO_C_BINDING when an allocatable object is a coarray"_err_en_US)767 .Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);768 return false;769 }770 }771 }772 if (!hasAllocateCoarraySpec()) {773 // C941774 context.Say(name_.source,775 "Coarray specification must appear in ALLOCATE when allocatable object is a coarray"_err_en_US);776 return false;777 } else {778 if (allocateCoarraySpecRank_ != corank_) {779 // Second and last part of C942780 context781 .Say(name_.source,782 "Corank of coarray specification in ALLOCATE must match corank of alloctable coarray"_err_en_US)783 .Attach(ultimate_->name(), "Declared here with corank %d"_en_US,784 corank_);785 return false;786 }787 if (const auto &coarraySpec{788 std::get<std::optional<parser::AllocateCoarraySpec>>(789 allocation_.t)}) {790 int dim{0};791 for (const auto &spec :792 std::get<std::list<parser::AllocateCoshapeSpec>>(coarraySpec->t)) {793 if (auto ubv{evaluate::ToInt64(794 GetExpr(context, std::get<parser::BoundExpr>(spec.t)))}) {795 if (auto *lbx{GetExpr(context,796 std::get<std::optional<parser::BoundExpr>>(spec.t))}) {797 auto lbv{evaluate::ToInt64(*lbx)};798 if (lbv && *ubv < *lbv) {799 context.Say(name_.source,800 "Upper cobound %jd is less than lower cobound %jd of codimension %d"_err_en_US,801 std::intmax_t{*ubv}, std::intmax_t{*lbv}, dim + 1);802 }803 } else if (*ubv < 1) {804 context.Say(name_.source,805 "Upper cobound %jd of codimension %d is less than 1"_err_en_US,806 std::intmax_t{*ubv}, dim + 1);807 }808 }809 ++dim;810 }811 }812 }813 } else { // Not a coarray814 if (hasAllocateCoarraySpec()) {815 // C941816 context.Say(name_.source,817 "Coarray specification must not appear in ALLOCATE when allocatable object is not a coarray"_err_en_US);818 return false;819 }820 }821 if (const parser::CoindexedNamedObject *822 coindexedObject{parser::GetCoindexedNamedObject(allocateObject_)}) {823 // C950824 context.Say(parser::FindSourceLocation(*coindexedObject),825 "Allocatable object must not be coindexed in ALLOCATE"_err_en_US);826 return false;827 }828 return true;829}830 831void AllocateChecker::Leave(const parser::AllocateStmt &allocateStmt) {832 if (auto info{CheckAllocateOptions(allocateStmt, context_)}) {833 for (const parser::Allocation &allocation :834 std::get<std::list<parser::Allocation>>(allocateStmt.t)) {835 AllocationCheckerHelper{allocation, *info}.RunChecks(context_);836 }837 }838}839} // namespace Fortran::semantics840