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