flang/lib/Semantics/check-allocate.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-exception
   6 //
   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/type.h"
  14 #include "flang/Parser/parse-tree.h"
  15 #include "flang/Parser/tools.h"
  16 #include "flang/Semantics/attr.h"
  17 #include "flang/Semantics/expression.h"
  18 #include "flang/Semantics/tools.h"
  19 #include "flang/Semantics/type.h"
  20
  21 namespace Fortran::semantics {
  22
  23 struct AllocateCheckerInfo {
  24   const DeclTypeSpec *typeSpec{nullptr};
  25   std::optional<evaluate::DynamicType> sourceExprType;
  26   std::optional<parser::CharBlock> sourceExprLoc;
  27   std::optional<parser::CharBlock> typeSpecLoc;
  28   int sourceExprRank{0}; // only valid if gotMold || gotSource
  29   bool gotStat{false};
  30   bool gotMsg{false};
  31   bool gotTypeSpec{false};
  32   bool gotSource{false};
  33   bool gotMold{false};
  34 };
  35
  36 class AllocationCheckerHelper {
  37 public:
  38   AllocationCheckerHelper(
  39       const parser::Allocation &alloc, AllocateCheckerInfo &info)
  40       : allocateInfo_{info}, allocateObject_{std::get<parser::AllocateObject>(
  41                                  alloc.t)},
  42         name_{parser::GetLastName(allocateObject_)},
  43         symbol_{name_.symbol ? &name_.symbol->GetUltimate() : nullptr},
  44         type_{symbol_ ? symbol_->GetType() : nullptr},
  45         allocateShapeSpecRank_{ShapeSpecRank(alloc)}, rank_{symbol_
  46                                                               ? symbol_->Rank()
  47                                                               : 0},
  48         allocateCoarraySpecRank_{CoarraySpecRank(alloc)},
  49         corank_{symbol_ ? symbol_->Corank() : 0} {}
  50
  51   bool RunChecks(SemanticsContext &context);
  52
  53 private:
  54   bool hasAllocateShapeSpecList() const { return allocateShapeSpecRank_ != 0; }
  55   bool hasAllocateCoarraySpec() const { return allocateCoarraySpecRank_ != 0; }
  56   bool RunCoarrayRelatedChecks(SemanticsContext &) const;
  57
  58   static int ShapeSpecRank(const parser::Allocation &allocation) {
  59     return static_cast<int>(
  60         std::get<std::list<parser::AllocateShapeSpec>>(allocation.t).size());
  61   }
  62
  63   static int CoarraySpecRank(const parser::Allocation &allocation) {
  64     if (const auto &coarraySpec{
  65             std::get<std::optional<parser::AllocateCoarraySpec>>(
  66                 allocation.t)}) {
  67       return std::get<std::list<parser::AllocateCoshapeSpec>>(coarraySpec->t)
  68                  .size() +
  69           1;
  70     } else {
  71       return 0;
  72     }
  73   }
  74
  75   void GatherAllocationBasicInfo() {
  76     if (type_->category() == DeclTypeSpec::Category::Character) {
  77       hasDeferredTypeParameter_ =
  78           type_->characterTypeSpec().length().isDeferred();
  79     } else if (const DerivedTypeSpec * derivedTypeSpec{type_->AsDerived()}) {
  80       for (const auto &pair : derivedTypeSpec->parameters()) {
  81         hasDeferredTypeParameter_ |= pair.second.isDeferred();
  82       }
  83       isAbstract_ = derivedTypeSpec->typeSymbol().attrs().test(Attr::ABSTRACT);
  84     }
  85     isUnlimitedPolymorphic_ =
  86         type_->category() == DeclTypeSpec::Category::ClassStar;
  87   }
  88
  89   AllocateCheckerInfo &allocateInfo_;
  90   const parser::AllocateObject &allocateObject_;
  91   const parser::Name &name_;
  92   const Symbol *symbol_{nullptr};
  93   const DeclTypeSpec *type_{nullptr};
  94   const int allocateShapeSpecRank_;
  95   const int rank_{0};
  96   const int allocateCoarraySpecRank_;
  97   const int corank_{0};
  98   bool hasDeferredTypeParameter_{false};
  99   bool isUnlimitedPolymorphic_{false};
 100   bool isAbstract_{false};
 101 };
 102
 103 static std::optional<AllocateCheckerInfo> CheckAllocateOptions(
 104     const parser::AllocateStmt &allocateStmt, SemanticsContext &context) {
 105   AllocateCheckerInfo info;
 106   bool stopCheckingAllocate{false}; // for errors that would lead to ambiguity
 107   if (const auto &typeSpec{
 108           std::get<std::optional<parser::TypeSpec>>(allocateStmt.t)}) {
 109     info.typeSpec = typeSpec->declTypeSpec;
 110     if (!info.typeSpec) {
 111       CHECK(context.AnyFatalError());
 112       return std::nullopt;
 113     }
 114     info.gotTypeSpec = true;
 115     info.typeSpecLoc = parser::FindSourceLocation(*typeSpec);
 116     if (const DerivedTypeSpec * derived{info.typeSpec->AsDerived()}) {
 117       // C937
 118       if (auto it{FindCoarrayUltimateComponent(*derived)}) {
 119         context
 120             .Say("Type-spec in ALLOCATE must not specify a type with a coarray"
 121                  " ultimate component"_err_en_US)
 122             .Attach(it->name(),
 123                 "Type '%s' has coarray ultimate component '%s' declared here"_en_US,
 124                 info.typeSpec->AsFortran(), it.BuildResultDesignatorName());
 125       }
 126     }
 127   }
 128
 129   const parser::Expr *parserSourceExpr{nullptr};
 130   for (const parser::AllocOpt &allocOpt :
 131       std::get<std::list<parser::AllocOpt>>(allocateStmt.t)) {
 132     common::visit(
 133         common::visitors{
 134             [&](const parser::StatOrErrmsg &statOrErr) {
 135               common::visit(
 136                   common::visitors{
 137                       [&](const parser::StatVariable &) {
 138                         if (info.gotStat) { // C943
 139                           context.Say(
 140                               "STAT may not be duplicated in a ALLOCATE statement"_err_en_US);
 141                         }
 142                         info.gotStat = true;
 143                       },
 144                       [&](const parser::MsgVariable &) {
 145                         if (info.gotMsg) { // C943
 146                           context.Say(
 147                               "ERRMSG may not be duplicated in a ALLOCATE statement"_err_en_US);
 148                         }
 149                         info.gotMsg = true;
 150                       },
 151                   },
 152                   statOrErr.u);
 153             },
 154             [&](const parser::AllocOpt::Source &source) {
 155               if (info.gotSource) { // C943
 156                 context.Say(
 157                     "SOURCE may not be duplicated in a ALLOCATE statement"_err_en_US);
 158                 stopCheckingAllocate = true;
 159               }
 160               if (info.gotMold || info.gotTypeSpec) { // C944
 161                 context.Say(
 162                     "At most one of source-expr and type-spec may appear in a ALLOCATE statement"_err_en_US);
 163                 stopCheckingAllocate = true;
 164               }
 165               parserSourceExpr = &source.v.value();
 166               info.gotSource = true;
 167             },
 168             [&](const parser::AllocOpt::Mold &mold) {
 169               if (info.gotMold) { // C943
 170                 context.Say(
 171                     "MOLD may not be duplicated in a ALLOCATE statement"_err_en_US);
 172                 stopCheckingAllocate = true;
 173               }
 174               if (info.gotSource || info.gotTypeSpec) { // C944
 175                 context.Say(
 176                     "At most one of source-expr and type-spec may appear in a ALLOCATE statement"_err_en_US);
 177                 stopCheckingAllocate = true;
 178               }
 179               parserSourceExpr = &mold.v.value();
 180               info.gotMold = true;
 181             },
 182         },
 183         allocOpt.u);
 184   }
 185
 186   if (stopCheckingAllocate) {
 187     return std::nullopt;
 188   }
 189
 190   if (info.gotSource || info.gotMold) {
 191     if (const auto *expr{GetExpr(context, DEREF(parserSourceExpr))}) {
 192       parser::CharBlock at{parserSourceExpr->source};
 193       info.sourceExprType = expr->GetType();
 194       if (!info.sourceExprType) {
 195         context.Say(at,
 196             "Typeless item not allowed as SOURCE or MOLD in ALLOCATE"_err_en_US);
 197         return std::nullopt;
 198       }
 199       info.sourceExprRank = expr->Rank();
 200       info.sourceExprLoc = parserSourceExpr->source;
 201       if (const DerivedTypeSpec *
 202           derived{evaluate::GetDerivedTypeSpec(info.sourceExprType)}) {
 203         // C949
 204         if (auto it{FindCoarrayUltimateComponent(*derived)}) {
 205           context
 206               .Say(at,
 207                   "SOURCE or MOLD expression must not have a type with a coarray ultimate component"_err_en_US)
 208               .Attach(it->name(),
 209                   "Type '%s' has coarray ultimate component '%s' declared here"_en_US,
 210                   info.sourceExprType.value().AsFortran(),
 211                   it.BuildResultDesignatorName());
 212         }
 213         if (info.gotSource) {
 214           // C948
 215           if (IsEventTypeOrLockType(derived)) {
 216             context.Say(at,
 217                 "SOURCE expression type must not be EVENT_TYPE or LOCK_TYPE from ISO_FORTRAN_ENV"_err_en_US);
 218           } else if (auto it{FindEventOrLockPotentialComponent(*derived)}) {
 219             context
 220                 .Say(at,
 221                     "SOURCE expression type must not have potential subobject "
 222                     "component"
 223                     " of type EVENT_TYPE or LOCK_TYPE from ISO_FORTRAN_ENV"_err_en_US)
 224                 .Attach(it->name(),
 225                     "Type '%s' has potential ultimate component '%s' declared here"_en_US,
 226                     info.sourceExprType.value().AsFortran(),
 227                     it.BuildResultDesignatorName());
 228           }
 229         }
 230       }
 231       if (info.gotSource) { // C1594(6) - SOURCE= restrictions when pure
 232         const Scope &scope{context.FindScope(at)};
 233         if (FindPureProcedureContaining(scope)) {
 234           parser::ContextualMessages messages{at, &context.messages()};
 235           CheckCopyabilityInPureScope(messages, *expr, scope);
 236         }
 237       }
 238     } else {
 239       // Error already reported on source expression.
 240       // Do not continue allocate checks.
 241       return std::nullopt;
 242     }
 243   }
 244
 245   return info;
 246 }
 247
 248 // Beware, type compatibility is not symmetric, IsTypeCompatible checks that
 249 // type1 is type compatible with type2. Note: type parameters are not considered
 250 // in this test.
 251 static bool IsTypeCompatible(
 252     const DeclTypeSpec &type1, const DerivedTypeSpec &derivedType2) {
 253   if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
 254     if (type1.category() == DeclTypeSpec::Category::TypeDerived) {
 255       return &derivedType1->typeSymbol() == &derivedType2.typeSymbol();
 256     } else if (type1.category() == DeclTypeSpec::Category::ClassDerived) {
 257       for (const DerivedTypeSpec *parent{&derivedType2}; parent;
 258            parent = parent->typeSymbol().GetParentTypeSpec()) {
 259         if (&derivedType1->typeSymbol() == &parent->typeSymbol()) {
 260           return true;
 261         }
 262       }
 263     }
 264   }
 265   return false;
 266 }
 267
 268 static bool IsTypeCompatible(
 269     const DeclTypeSpec &type1, const DeclTypeSpec &type2) {
 270   if (type1.category() == DeclTypeSpec::Category::ClassStar) {
 271     // TypeStar does not make sense in allocate context because assumed type
 272     // cannot be allocatable (C709)
 273     return true;
 274   }
 275   if (const IntrinsicTypeSpec * intrinsicType2{type2.AsIntrinsic()}) {
 276     if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
 277       return intrinsicType1->category() == intrinsicType2->category();
 278     } else {
 279       return false;
 280     }
 281   } else if (const DerivedTypeSpec * derivedType2{type2.AsDerived()}) {
 282     return IsTypeCompatible(type1, *derivedType2);
 283   }
 284   return false;
 285 }
 286
 287 static bool IsTypeCompatible(
 288     const DeclTypeSpec &type1, const evaluate::DynamicType &type2) {
 289   if (type1.category() == DeclTypeSpec::Category::ClassStar) {
 290     // TypeStar does not make sense in allocate context because assumed type
 291     // cannot be allocatable (C709)
 292     return true;
 293   }
 294   if (type2.category() != evaluate::TypeCategory::Derived) {
 295     if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
 296       return intrinsicType1->category() == type2.category();
 297     } else {
 298       return false;
 299     }
 300   } else if (!type2.IsUnlimitedPolymorphic()) {
 301     return IsTypeCompatible(type1, type2.GetDerivedTypeSpec());
 302   }
 303   return false;
 304 }
 305
 306 // Note: Check assumes  type1 is compatible with type2. type2 may have more type
 307 // parameters than type1 but if a type2 type parameter is assumed, then this
 308 // check enforce that type1 has it. type1 can be unlimited polymorphic, but not
 309 // type2.
 310 static bool HaveSameAssumedTypeParameters(
 311     const DeclTypeSpec &type1, const DeclTypeSpec &type2) {
 312   if (type2.category() == DeclTypeSpec::Category::Character) {
 313     bool type2LengthIsAssumed{type2.characterTypeSpec().length().isAssumed()};
 314     if (type1.category() == DeclTypeSpec::Category::Character) {
 315       return type1.characterTypeSpec().length().isAssumed() ==
 316           type2LengthIsAssumed;
 317     }
 318     // It is possible to reach this if type1 is unlimited polymorphic
 319     return !type2LengthIsAssumed;
 320   } else if (const DerivedTypeSpec * derivedType2{type2.AsDerived()}) {
 321     int type2AssumedParametersCount{0};
 322     int type1AssumedParametersCount{0};
 323     for (const auto &pair : derivedType2->parameters()) {
 324       type2AssumedParametersCount += pair.second.isAssumed();
 325     }
 326     // type1 may be unlimited polymorphic
 327     if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
 328       for (auto it{derivedType1->parameters().begin()};
 329            it != derivedType1->parameters().end(); ++it) {
 330         if (it->second.isAssumed()) {
 331           ++type1AssumedParametersCount;
 332           const ParamValue *param{derivedType2->FindParameter(it->first)};
 333           if (!param || !param->isAssumed()) {
 334             // type1 has an assumed parameter that is not a type parameter of
 335             // type2 or not assumed in type2.
 336             return false;
 337           }
 338         }
 339       }
 340     }
 341     // Will return false if type2 has type parameters that are not assumed in
 342     // type1 or do not exist in type1
 343     return type1AssumedParametersCount == type2AssumedParametersCount;
 344   }
 345   return true; // other intrinsic types have no length type parameters
 346 }
 347
 348 static std::optional<std::int64_t> GetTypeParameterInt64Value(
 349     const Symbol &parameterSymbol, const DerivedTypeSpec &derivedType) {
 350   if (const ParamValue *
 351       paramValue{derivedType.FindParameter(parameterSymbol.name())}) {
 352     return evaluate::ToInt64(paramValue->GetExplicit());
 353   } else {
 354     return std::nullopt;
 355   }
 356 }
 357
 358 // HaveCompatibleKindParameters functions assume type1 is type compatible with
 359 // type2 (except for kind type parameters)
 360 static bool HaveCompatibleKindParameters(
 361     const DerivedTypeSpec &derivedType1, const DerivedTypeSpec &derivedType2) {
 362   for (const Symbol &symbol :
 363       OrderParameterDeclarations(derivedType1.typeSymbol())) {
 364     if (symbol.get<TypeParamDetails>().attr() == common::TypeParamAttr::Kind) {
 365       // At this point, it should have been ensured that these contain integer
 366       // constants, so die if this is not the case.
 367       if (GetTypeParameterInt64Value(symbol, derivedType1).value() !=
 368           GetTypeParameterInt64Value(symbol, derivedType2).value()) {
 369         return false;
 370       }
 371     }
 372   }
 373   return true;
 374 }
 375
 376 static bool HaveCompatibleKindParameters(
 377     const DeclTypeSpec &type1, const evaluate::DynamicType &type2) {
 378   if (type1.category() == DeclTypeSpec::Category::ClassStar) {
 379     return true;
 380   }
 381   if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
 382     return evaluate::ToInt64(intrinsicType1->kind()).value() == type2.kind();
 383   } else if (type2.IsUnlimitedPolymorphic()) {
 384     return false;
 385   } else if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
 386     return HaveCompatibleKindParameters(
 387         *derivedType1, type2.GetDerivedTypeSpec());
 388   } else {
 389     common::die("unexpected type1 category");
 390   }
 391 }
 392
 393 static bool HaveCompatibleKindParameters(
 394     const DeclTypeSpec &type1, const DeclTypeSpec &type2) {
 395   if (type1.category() == DeclTypeSpec::Category::ClassStar) {
 396     return true;
 397   }
 398   if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
 399     return intrinsicType1->kind() == DEREF(type2.AsIntrinsic()).kind();
 400   } else if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
 401     return HaveCompatibleKindParameters(
 402         *derivedType1, DEREF(type2.AsDerived()));
 403   } else {
 404     common::die("unexpected type1 category");
 405   }
 406 }
 407
 408 bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
 409   if (!symbol_) {
 410     CHECK(context.AnyFatalError());
 411     return false;
 412   }
 413   if (!IsVariableName(*symbol_)) { // C932 pre-requisite
 414     context.Say(name_.source,
 415         "Name in ALLOCATE statement must be a variable name"_err_en_US);
 416     return false;
 417   }
 418   if (!type_) {
 419     // This is done after variable check because a user could have put
 420     // a subroutine name in allocate for instance which is a symbol with
 421     // no type.
 422     CHECK(context.AnyFatalError());
 423     return false;
 424   }
 425   GatherAllocationBasicInfo();
 426   if (!IsAllocatableOrPointer(*symbol_)) { // C932
 427     context.Say(name_.source,
 428         "Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
 429     return false;
 430   }
 431   bool gotSourceExprOrTypeSpec{allocateInfo_.gotMold ||
 432       allocateInfo_.gotTypeSpec || allocateInfo_.gotSource};
 433   if (hasDeferredTypeParameter_ && !gotSourceExprOrTypeSpec) {
 434     // C933
 435     context.Say(name_.source,
 436         "Either type-spec or source-expr must appear in ALLOCATE when allocatable object has a deferred type parameters"_err_en_US);
 437     return false;
 438   }
 439   if (isUnlimitedPolymorphic_ && !gotSourceExprOrTypeSpec) {
 440     // C933
 441     context.Say(name_.source,
 442         "Either type-spec or source-expr must appear in ALLOCATE when allocatable object is unlimited polymorphic"_err_en_US);
 443     return false;
 444   }
 445   if (isAbstract_ && !gotSourceExprOrTypeSpec) {
 446     // C933
 447     context.Say(name_.source,
 448         "Either type-spec or source-expr must appear in ALLOCATE when allocatable object is of abstract type"_err_en_US);
 449     return false;
 450   }
 451   if (allocateInfo_.gotTypeSpec) {
 452     if (!IsTypeCompatible(*type_, *allocateInfo_.typeSpec)) {
 453       // C934
 454       context.Say(name_.source,
 455           "Allocatable object in ALLOCATE must be type compatible with type-spec"_err_en_US);
 456       return false;
 457     }
 458     if (!HaveCompatibleKindParameters(*type_, *allocateInfo_.typeSpec)) {
 459       context.Say(name_.source,
 460           // C936
 461           "Kind type parameters of allocatable object in ALLOCATE must be the same as the corresponding ones in type-spec"_err_en_US);
 462       return false;
 463     }
 464     if (!HaveSameAssumedTypeParameters(*type_, *allocateInfo_.typeSpec)) {
 465       // C935
 466       context.Say(name_.source,
 467           "Type parameters in type-spec must be assumed if and only if they are assumed for allocatable object in ALLOCATE"_err_en_US);
 468       return false;
 469     }
 470   } else if (allocateInfo_.gotSource || allocateInfo_.gotMold) {
 471     if (!IsTypeCompatible(*type_, allocateInfo_.sourceExprType.value())) {
 472       // first part of C945
 473       context.Say(name_.source,
 474           "Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE"_err_en_US);
 475       return false;
 476     }
 477     if (!HaveCompatibleKindParameters(
 478             *type_, allocateInfo_.sourceExprType.value())) {
 479       // C946
 480       context.Say(name_.source,
 481           "Kind type parameters of allocatable object must be the same as the corresponding ones of SOURCE or MOLD expression"_err_en_US);
 482       return false;
 483     }
 484   }
 485   // Shape related checks
 486   if (rank_ > 0) {
 487     if (!hasAllocateShapeSpecList()) {
 488       // C939
 489       if (!(allocateInfo_.gotSource || allocateInfo_.gotMold)) {
 490         context.Say(name_.source,
 491             "Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD"_err_en_US);
 492         return false;
 493       } else {
 494         if (allocateInfo_.sourceExprRank != rank_) {
 495           context
 496               .Say(name_.source,
 497                   "Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD"_err_en_US)
 498               .Attach(allocateInfo_.sourceExprLoc.value(),
 499                   "Expression in %s has rank %d but allocatable object has rank %d"_en_US,
 500                   allocateInfo_.gotSource ? "SOURCE" : "MOLD",
 501                   allocateInfo_.sourceExprRank, rank_);
 502           return false;
 503         }
 504       }
 505     } else {
 506       // first part of C942
 507       if (allocateShapeSpecRank_ != rank_) {
 508         context
 509             .Say(name_.source,
 510                 "The number of shape specifications, when they appear, must match the rank of allocatable object"_err_en_US)
 511             .Attach(symbol_->name(), "Declared here with rank %d"_en_US, rank_);
 512         return false;
 513       }
 514     }
 515   } else {
 516     // C940
 517     if (hasAllocateShapeSpecList()) {
 518       context.Say(name_.source,
 519           "Shape specifications must not appear when allocatable object is scalar"_err_en_US);
 520       return false;
 521     }
 522   }
 523   // second and last part of C945
 524   if (allocateInfo_.gotSource && allocateInfo_.sourceExprRank &&
 525       allocateInfo_.sourceExprRank != rank_) {
 526     context
 527         .Say(name_.source,
 528             "If SOURCE appears, the related expression must be scalar or have the same rank as each allocatable object in ALLOCATE"_err_en_US)
 529         .Attach(allocateInfo_.sourceExprLoc.value(),
 530             "SOURCE expression has rank %d"_en_US, allocateInfo_.sourceExprRank)
 531         .Attach(symbol_->name(),
 532             "Allocatable object declared here with rank %d"_en_US, rank_);
 533     return false;
 534   }
 535   context.CheckIndexVarRedefine(name_);
 536   if (allocateObject_.typedExpr && allocateObject_.typedExpr->v) {
 537     if (auto whyNot{
 538             WhyNotDefinable(name_.source, context.FindScope(name_.source),
 539                 {DefinabilityFlag::PointerDefinition,
 540                     DefinabilityFlag::AcceptAllocatable},
 541                 *allocateObject_.typedExpr->v)}) {
 542       context
 543           .Say(name_.source,
 544               "Name in ALLOCATE statement is not definable"_err_en_US)
 545           .Attach(std::move(*whyNot));
 546       return false;
 547     }
 548   }
 549   return RunCoarrayRelatedChecks(context);
 550 }
 551
 552 bool AllocationCheckerHelper::RunCoarrayRelatedChecks(
 553     SemanticsContext &context) const {
 554   if (!symbol_) {
 555     CHECK(context.AnyFatalError());
 556     return false;
 557   }
 558   if (evaluate::IsCoarray(*symbol_)) {
 559     if (allocateInfo_.gotTypeSpec) {
 560       // C938
 561       if (const DerivedTypeSpec *
 562           derived{allocateInfo_.typeSpec->AsDerived()}) {
 563         if (IsTeamType(derived)) {
 564           context
 565               .Say(allocateInfo_.typeSpecLoc.value(),
 566                   "Type-Spec in ALLOCATE must not be TEAM_TYPE from ISO_FORTRAN_ENV when an allocatable object is a coarray"_err_en_US)
 567               .Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);
 568           return false;
 569         } else if (IsIsoCType(derived)) {
 570           context
 571               .Say(allocateInfo_.typeSpecLoc.value(),
 572                   "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)
 573               .Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);
 574           return false;
 575         }
 576       }
 577     } else if (allocateInfo_.gotSource || allocateInfo_.gotMold) {
 578       // C948
 579       const evaluate::DynamicType &sourceType{
 580           allocateInfo_.sourceExprType.value()};
 581       if (const auto *derived{evaluate::GetDerivedTypeSpec(sourceType)}) {
 582         if (IsTeamType(derived)) {
 583           context
 584               .Say(allocateInfo_.sourceExprLoc.value(),
 585                   "SOURCE or MOLD expression type must not be TEAM_TYPE from ISO_FORTRAN_ENV when an allocatable object is a coarray"_err_en_US)
 586               .Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);
 587           return false;
 588         } else if (IsIsoCType(derived)) {
 589           context
 590               .Say(allocateInfo_.sourceExprLoc.value(),
 591                   "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)
 592               .Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);
 593           return false;
 594         }
 595       }
 596     }
 597     if (!hasAllocateCoarraySpec()) {
 598       // C941
 599       context.Say(name_.source,
 600           "Coarray specification must appear in ALLOCATE when allocatable object is a coarray"_err_en_US);
 601       return false;
 602     } else {
 603       if (allocateCoarraySpecRank_ != corank_) {
 604         // Second and last part of C942
 605         context
 606             .Say(name_.source,
 607                 "Corank of coarray specification in ALLOCATE must match corank of alloctable coarray"_err_en_US)
 608             .Attach(
 609                 symbol_->name(), "Declared here with corank %d"_en_US, corank_);
 610         return false;
 611       }
 612     }
 613   } else { // Not a coarray
 614     if (hasAllocateCoarraySpec()) {
 615       // C941
 616       context.Say(name_.source,
 617           "Coarray specification must not appear in ALLOCATE when allocatable object is not a coarray"_err_en_US);
 618       return false;
 619     }
 620   }
 621   if (const parser::CoindexedNamedObject *
 622       coindexedObject{parser::GetCoindexedNamedObject(allocateObject_)}) {
 623     // C950
 624     context.Say(parser::FindSourceLocation(*coindexedObject),
 625         "Allocatable object must not be coindexed in ALLOCATE"_err_en_US);
 626     return false;
 627   }
 628   return true;
 629 }
 630
 631 void AllocateChecker::Leave(const parser::AllocateStmt &allocateStmt) {
 632   if (auto info{CheckAllocateOptions(allocateStmt, context_)}) {
 633     for (const parser::Allocation &allocation :
 634         std::get<std::list<parser::Allocation>>(allocateStmt.t)) {
 635       AllocationCheckerHelper{allocation, *info}.RunChecks(context_);
 636     }
 637   }
 638 }
 639 } // namespace Fortran::semantics