xref: /llvm-project/flang/lib/Semantics/check-allocate.cpp (revision 39a9073f9eb71ac610cbafe7eed05ca668871b5c) 
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   bool gotStream{false};
35   bool gotPinned{false};
36 };
37 
38 class AllocationCheckerHelper {
39 public:
40   AllocationCheckerHelper(
41       const parser::Allocation &alloc, AllocateCheckerInfo &info)
42       : allocateInfo_{info}, allocateObject_{std::get<parser::AllocateObject>(
43                                  alloc.t)},
44         allocateShapeSpecRank_{ShapeSpecRank(alloc)}, allocateCoarraySpecRank_{
45                                                           CoarraySpecRank(
46                                                               alloc)} {}
47 
48   bool RunChecks(SemanticsContext &context);
49 
50 private:
51   bool hasAllocateShapeSpecList() const { return allocateShapeSpecRank_ != 0; }
52   bool hasAllocateCoarraySpec() const { return allocateCoarraySpecRank_ != 0; }
53   bool RunCoarrayRelatedChecks(SemanticsContext &) const;
54 
55   static int ShapeSpecRank(const parser::Allocation &allocation) {
56     return static_cast<int>(
57         std::get<std::list<parser::AllocateShapeSpec>>(allocation.t).size());
58   }
59 
60   static int CoarraySpecRank(const parser::Allocation &allocation) {
61     if (const auto &coarraySpec{
62             std::get<std::optional<parser::AllocateCoarraySpec>>(
63                 allocation.t)}) {
64       return std::get<std::list<parser::AllocateCoshapeSpec>>(coarraySpec->t)
65                  .size() +
66           1;
67     } else {
68       return 0;
69     }
70   }
71 
72   void GatherAllocationBasicInfo() {
73     if (type_->category() == DeclTypeSpec::Category::Character) {
74       hasDeferredTypeParameter_ =
75           type_->characterTypeSpec().length().isDeferred();
76     } else if (const DerivedTypeSpec * derivedTypeSpec{type_->AsDerived()}) {
77       for (const auto &pair : derivedTypeSpec->parameters()) {
78         hasDeferredTypeParameter_ |= pair.second.isDeferred();
79       }
80       isAbstract_ = derivedTypeSpec->typeSymbol().attrs().test(Attr::ABSTRACT);
81     }
82     isUnlimitedPolymorphic_ =
83         type_->category() == DeclTypeSpec::Category::ClassStar;
84   }
85 
86   AllocateCheckerInfo &allocateInfo_;
87   const parser::AllocateObject &allocateObject_;
88   const int allocateShapeSpecRank_{0};
89   const int allocateCoarraySpecRank_{0};
90   const parser::Name &name_{parser::GetLastName(allocateObject_)};
91   // no USE or host association
92   const Symbol *ultimate_{
93       name_.symbol ? &name_.symbol->GetUltimate() : nullptr};
94   const DeclTypeSpec *type_{ultimate_ ? ultimate_->GetType() : nullptr};
95   const int rank_{ultimate_ ? ultimate_->Rank() : 0};
96   const int corank_{ultimate_ ? ultimate_->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     common::visit(
132         common::visitors{
133             [&](const parser::StatOrErrmsg &statOrErr) {
134               common::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 &var) {
144                         WarnOnDeferredLengthCharacterScalar(context,
145                             GetExpr(context, var),
146                             var.v.thing.thing.GetSource(), "ERRMSG=");
147                         if (info.gotMsg) { // C943
148                           context.Say(
149                               "ERRMSG may not be duplicated in a ALLOCATE statement"_err_en_US);
150                         }
151                         info.gotMsg = true;
152                       },
153                   },
154                   statOrErr.u);
155             },
156             [&](const parser::AllocOpt::Source &source) {
157               if (info.gotSource) { // C943
158                 context.Say(
159                     "SOURCE may not be duplicated in a ALLOCATE statement"_err_en_US);
160                 stopCheckingAllocate = true;
161               }
162               if (info.gotMold || info.gotTypeSpec) { // C944
163                 context.Say(
164                     "At most one of source-expr and type-spec may appear in a ALLOCATE statement"_err_en_US);
165                 stopCheckingAllocate = true;
166               }
167               parserSourceExpr = &source.v.value();
168               info.gotSource = true;
169             },
170             [&](const parser::AllocOpt::Mold &mold) {
171               if (info.gotMold) { // C943
172                 context.Say(
173                     "MOLD may not be duplicated in a ALLOCATE statement"_err_en_US);
174                 stopCheckingAllocate = true;
175               }
176               if (info.gotSource || info.gotTypeSpec) { // C944
177                 context.Say(
178                     "At most one of source-expr and type-spec may appear in a ALLOCATE statement"_err_en_US);
179                 stopCheckingAllocate = true;
180               }
181               parserSourceExpr = &mold.v.value();
182               info.gotMold = true;
183             },
184             [&](const parser::AllocOpt::Stream &stream) { // CUDA
185               if (info.gotStream) {
186                 context.Say(
187                     "STREAM may not be duplicated in a ALLOCATE statement"_err_en_US);
188                 stopCheckingAllocate = true;
189               }
190               info.gotStream = true;
191             },
192             [&](const parser::AllocOpt::Pinned &pinned) { // CUDA
193               if (info.gotPinned) {
194                 context.Say(
195                     "PINNED may not be duplicated in a ALLOCATE statement"_err_en_US);
196                 stopCheckingAllocate = true;
197               }
198               info.gotPinned = true;
199             },
200         },
201         allocOpt.u);
202   }
203 
204   if (stopCheckingAllocate) {
205     return std::nullopt;
206   }
207 
208   if (info.gotSource || info.gotMold) {
209     if (const auto *expr{GetExpr(context, DEREF(parserSourceExpr))}) {
210       parser::CharBlock at{parserSourceExpr->source};
211       info.sourceExprType = expr->GetType();
212       if (!info.sourceExprType) {
213         context.Say(at,
214             "Typeless item not allowed as SOURCE or MOLD in ALLOCATE"_err_en_US);
215         return std::nullopt;
216       }
217       info.sourceExprRank = expr->Rank();
218       info.sourceExprLoc = parserSourceExpr->source;
219       if (const DerivedTypeSpec *
220           derived{evaluate::GetDerivedTypeSpec(info.sourceExprType)}) {
221         // C949
222         if (auto it{FindCoarrayUltimateComponent(*derived)}) {
223           context
224               .Say(at,
225                   "SOURCE or MOLD expression must not have a type with a coarray ultimate component"_err_en_US)
226               .Attach(it->name(),
227                   "Type '%s' has coarray ultimate component '%s' declared here"_en_US,
228                   info.sourceExprType.value().AsFortran(),
229                   it.BuildResultDesignatorName());
230         }
231         if (info.gotSource) {
232           // C948
233           if (IsEventTypeOrLockType(derived)) {
234             context.Say(at,
235                 "SOURCE expression type must not be EVENT_TYPE or LOCK_TYPE from ISO_FORTRAN_ENV"_err_en_US);
236           } else if (auto it{FindEventOrLockPotentialComponent(*derived)}) {
237             context
238                 .Say(at,
239                     "SOURCE expression type must not have potential subobject "
240                     "component"
241                     " of type EVENT_TYPE or LOCK_TYPE from ISO_FORTRAN_ENV"_err_en_US)
242                 .Attach(it->name(),
243                     "Type '%s' has potential ultimate component '%s' declared here"_en_US,
244                     info.sourceExprType.value().AsFortran(),
245                     it.BuildResultDesignatorName());
246           }
247         }
248       }
249       if (info.gotSource) { // C1594(6) - SOURCE= restrictions when pure
250         const Scope &scope{context.FindScope(at)};
251         if (FindPureProcedureContaining(scope)) {
252           parser::ContextualMessages messages{at, &context.messages()};
253           CheckCopyabilityInPureScope(messages, *expr, scope);
254         }
255       }
256     } else {
257       // Error already reported on source expression.
258       // Do not continue allocate checks.
259       return std::nullopt;
260     }
261   }
262 
263   return info;
264 }
265 
266 // Beware, type compatibility is not symmetric, IsTypeCompatible checks that
267 // type1 is type compatible with type2. Note: type parameters are not considered
268 // in this test.
269 static bool IsTypeCompatible(
270     const DeclTypeSpec &type1, const DerivedTypeSpec &derivedType2) {
271   if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
272     if (type1.category() == DeclTypeSpec::Category::TypeDerived) {
273       return evaluate::AreSameDerivedTypeIgnoringTypeParameters(
274           *derivedType1, derivedType2);
275     } else if (type1.category() == DeclTypeSpec::Category::ClassDerived) {
276       for (const DerivedTypeSpec *parent{&derivedType2}; parent;
277            parent = parent->typeSymbol().GetParentTypeSpec()) {
278         if (evaluate::AreSameDerivedTypeIgnoringTypeParameters(
279                 *derivedType1, *parent)) {
280           return true;
281         }
282       }
283     }
284   }
285   return false;
286 }
287 
288 static bool IsTypeCompatible(
289     const DeclTypeSpec &type1, const DeclTypeSpec &type2) {
290   if (type1.category() == DeclTypeSpec::Category::ClassStar) {
291     // TypeStar does not make sense in allocate context because assumed type
292     // cannot be allocatable (C709)
293     return true;
294   }
295   if (const IntrinsicTypeSpec * intrinsicType2{type2.AsIntrinsic()}) {
296     if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
297       return intrinsicType1->category() == intrinsicType2->category();
298     } else {
299       return false;
300     }
301   } else if (const DerivedTypeSpec * derivedType2{type2.AsDerived()}) {
302     return IsTypeCompatible(type1, *derivedType2);
303   }
304   return false;
305 }
306 
307 static bool IsTypeCompatible(
308     const DeclTypeSpec &type1, const evaluate::DynamicType &type2) {
309   if (type1.category() == DeclTypeSpec::Category::ClassStar) {
310     // TypeStar does not make sense in allocate context because assumed type
311     // cannot be allocatable (C709)
312     return true;
313   }
314   if (type2.category() != evaluate::TypeCategory::Derived) {
315     if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
316       return intrinsicType1->category() == type2.category();
317     } else {
318       return false;
319     }
320   } else if (!type2.IsUnlimitedPolymorphic()) {
321     return IsTypeCompatible(type1, type2.GetDerivedTypeSpec());
322   }
323   return false;
324 }
325 
326 // Note: Check assumes  type1 is compatible with type2. type2 may have more type
327 // parameters than type1 but if a type2 type parameter is assumed, then this
328 // check enforce that type1 has it. type1 can be unlimited polymorphic, but not
329 // type2.
330 static bool HaveSameAssumedTypeParameters(
331     const DeclTypeSpec &type1, const DeclTypeSpec &type2) {
332   if (type2.category() == DeclTypeSpec::Category::Character) {
333     bool type2LengthIsAssumed{type2.characterTypeSpec().length().isAssumed()};
334     if (type1.category() == DeclTypeSpec::Category::Character) {
335       return type1.characterTypeSpec().length().isAssumed() ==
336           type2LengthIsAssumed;
337     }
338     // It is possible to reach this if type1 is unlimited polymorphic
339     return !type2LengthIsAssumed;
340   } else if (const DerivedTypeSpec * derivedType2{type2.AsDerived()}) {
341     int type2AssumedParametersCount{0};
342     int type1AssumedParametersCount{0};
343     for (const auto &pair : derivedType2->parameters()) {
344       type2AssumedParametersCount += pair.second.isAssumed();
345     }
346     // type1 may be unlimited polymorphic
347     if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
348       for (auto it{derivedType1->parameters().begin()};
349            it != derivedType1->parameters().end(); ++it) {
350         if (it->second.isAssumed()) {
351           ++type1AssumedParametersCount;
352           const ParamValue *param{derivedType2->FindParameter(it->first)};
353           if (!param || !param->isAssumed()) {
354             // type1 has an assumed parameter that is not a type parameter of
355             // type2 or not assumed in type2.
356             return false;
357           }
358         }
359       }
360     }
361     // Will return false if type2 has type parameters that are not assumed in
362     // type1 or do not exist in type1
363     return type1AssumedParametersCount == type2AssumedParametersCount;
364   }
365   return true; // other intrinsic types have no length type parameters
366 }
367 
368 static std::optional<std::int64_t> GetTypeParameterInt64Value(
369     const Symbol &parameterSymbol, const DerivedTypeSpec &derivedType) {
370   if (const ParamValue *
371       paramValue{derivedType.FindParameter(parameterSymbol.name())}) {
372     return evaluate::ToInt64(paramValue->GetExplicit());
373   }
374   return std::nullopt;
375 }
376 
377 static bool HaveCompatibleTypeParameters(
378     const DerivedTypeSpec &derivedType1, const DerivedTypeSpec &derivedType2) {
379   for (const Symbol &symbol :
380       OrderParameterDeclarations(derivedType1.typeSymbol())) {
381     auto v1{GetTypeParameterInt64Value(symbol, derivedType1)};
382     auto v2{GetTypeParameterInt64Value(symbol, derivedType2)};
383     if (v1 && v2 && *v1 != *v2) {
384       return false;
385     }
386   }
387   return true;
388 }
389 
390 static bool HaveCompatibleTypeParameters(
391     const DeclTypeSpec &type1, const evaluate::DynamicType &type2) {
392   if (type1.category() == DeclTypeSpec::Category::ClassStar) {
393     return true;
394   }
395   if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
396     return evaluate::ToInt64(intrinsicType1->kind()).value() == type2.kind();
397   } else if (type2.IsUnlimitedPolymorphic()) {
398     return false;
399   } else if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
400     return HaveCompatibleTypeParameters(
401         *derivedType1, type2.GetDerivedTypeSpec());
402   } else {
403     common::die("unexpected type1 category");
404   }
405 }
406 
407 static bool HaveCompatibleTypeParameters(
408     const DeclTypeSpec &type1, const DeclTypeSpec &type2) {
409   if (type1.category() == DeclTypeSpec::Category::ClassStar) {
410     return true;
411   } else if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
412     const IntrinsicTypeSpec *intrinsicType2{type2.AsIntrinsic()};
413     return !intrinsicType2 || intrinsicType1->kind() == intrinsicType2->kind();
414   } else if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
415     const DerivedTypeSpec *derivedType2{type2.AsDerived()};
416     return !derivedType2 ||
417         HaveCompatibleTypeParameters(*derivedType1, *derivedType2);
418   } else {
419     common::die("unexpected type1 category");
420   }
421 }
422 
423 static bool HaveCompatibleLengths(
424     const DeclTypeSpec &type1, const DeclTypeSpec &type2) {
425   if (type1.category() == DeclTypeSpec::Character &&
426       type2.category() == DeclTypeSpec::Character) {
427     auto v1{
428         evaluate::ToInt64(type1.characterTypeSpec().length().GetExplicit())};
429     auto v2{
430         evaluate::ToInt64(type2.characterTypeSpec().length().GetExplicit())};
431     return !v1 || !v2 || *v1 == *v2;
432   } else {
433     return true;
434   }
435 }
436 
437 static bool HaveCompatibleLengths(
438     const DeclTypeSpec &type1, const evaluate::DynamicType &type2) {
439   if (type1.category() == DeclTypeSpec::Character &&
440       type2.category() == TypeCategory::Character) {
441     auto v1{
442         evaluate::ToInt64(type1.characterTypeSpec().length().GetExplicit())};
443     auto v2{type2.knownLength()};
444     return !v1 || !v2 || *v1 == *v2;
445   } else {
446     return true;
447   }
448 }
449 
450 bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
451   if (!ultimate_) {
452     CHECK(context.AnyFatalError());
453     return false;
454   }
455   if (!IsVariableName(*ultimate_)) { // C932 pre-requisite
456     context.Say(name_.source,
457         "Name in ALLOCATE statement must be a variable name"_err_en_US);
458     return false;
459   }
460   if (!type_) {
461     // This is done after variable check because a user could have put
462     // a subroutine name in allocate for instance which is a symbol with
463     // no type.
464     CHECK(context.AnyFatalError());
465     return false;
466   }
467   GatherAllocationBasicInfo();
468   if (!IsAllocatableOrObjectPointer(ultimate_)) { // C932
469     context.Say(name_.source,
470         "Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
471     return false;
472   }
473   bool gotSourceExprOrTypeSpec{allocateInfo_.gotMold ||
474       allocateInfo_.gotTypeSpec || allocateInfo_.gotSource};
475   if (hasDeferredTypeParameter_ && !gotSourceExprOrTypeSpec) {
476     // C933
477     context.Say(name_.source,
478         "Either type-spec or source-expr must appear in ALLOCATE when allocatable object has a deferred type parameters"_err_en_US);
479     return false;
480   }
481   if (isUnlimitedPolymorphic_ && !gotSourceExprOrTypeSpec) {
482     // C933
483     context.Say(name_.source,
484         "Either type-spec or source-expr must appear in ALLOCATE when allocatable object is unlimited polymorphic"_err_en_US);
485     return false;
486   }
487   if (isAbstract_ && !gotSourceExprOrTypeSpec) {
488     // C933
489     context.Say(name_.source,
490         "Either type-spec or source-expr must appear in ALLOCATE when allocatable object is of abstract type"_err_en_US);
491     return false;
492   }
493   if (allocateInfo_.gotTypeSpec) {
494     if (!IsTypeCompatible(*type_, *allocateInfo_.typeSpec)) {
495       // C934
496       context.Say(name_.source,
497           "Allocatable object in ALLOCATE must be type compatible with type-spec"_err_en_US);
498       return false;
499     }
500     if (!HaveCompatibleTypeParameters(*type_, *allocateInfo_.typeSpec)) {
501       context.Say(name_.source,
502           // C936
503           "Type parameters of allocatable object in ALLOCATE must be the same as the corresponding ones in type-spec"_err_en_US);
504       return false;
505     }
506     if (!HaveCompatibleLengths(*type_, *allocateInfo_.typeSpec)) { // C934
507       context.Say(name_.source,
508           "Character length of allocatable object in ALLOCATE must be the same as the type-spec"_err_en_US);
509       return false;
510     }
511     if (!HaveSameAssumedTypeParameters(*type_, *allocateInfo_.typeSpec)) {
512       // C935
513       context.Say(name_.source,
514           "Type parameters in type-spec must be assumed if and only if they are assumed for allocatable object in ALLOCATE"_err_en_US);
515       return false;
516     }
517   } else if (allocateInfo_.gotSource || allocateInfo_.gotMold) {
518     if (!IsTypeCompatible(*type_, allocateInfo_.sourceExprType.value())) {
519       // first part of C945
520       context.Say(name_.source,
521           "Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE"_err_en_US);
522       return false;
523     }
524     if (!HaveCompatibleTypeParameters(
525             *type_, allocateInfo_.sourceExprType.value())) {
526       // C946
527       context.Say(name_.source,
528           "Derived type parameters of allocatable object must be the same as the corresponding ones of SOURCE or MOLD expression"_err_en_US);
529       return false;
530     }
531     // Character length distinction is allowed, with a warning
532     if (!HaveCompatibleLengths(
533             *type_, allocateInfo_.sourceExprType.value())) { // F'2023 C950
534       context.Warn(common::LanguageFeature::AllocateToOtherLength, name_.source,
535           "Character length of allocatable object in ALLOCATE should be the same as the SOURCE or MOLD"_port_en_US);
536       return false;
537     }
538   }
539   // Shape related checks
540   if (ultimate_ && evaluate::IsAssumedRank(*ultimate_)) {
541     context.Say(name_.source,
542         "An assumed-rank dummy argument may not appear in an ALLOCATE statement"_err_en_US);
543     return false;
544   }
545   if (ultimate_ && IsAssumedSizeArray(*ultimate_) && context.AnyFatalError()) {
546     // An assumed-size dummy array or RANK(*) case of SELECT RANK will have
547     // already been diagnosed; don't pile on.
548     return false;
549   }
550   if (rank_ > 0) {
551     if (!hasAllocateShapeSpecList()) {
552       // C939
553       if (!(allocateInfo_.gotSource || allocateInfo_.gotMold)) {
554         context.Say(name_.source,
555             "Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD"_err_en_US);
556         return false;
557       } else {
558         if (allocateInfo_.sourceExprRank != rank_) {
559           context
560               .Say(name_.source,
561                   "Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD"_err_en_US)
562               .Attach(allocateInfo_.sourceExprLoc.value(),
563                   "Expression in %s has rank %d but allocatable object has rank %d"_en_US,
564                   allocateInfo_.gotSource ? "SOURCE" : "MOLD",
565                   allocateInfo_.sourceExprRank, rank_);
566           return false;
567         }
568       }
569     } else {
570       // explicit shape-spec-list
571       if (allocateShapeSpecRank_ != rank_) {
572         context
573             .Say(name_.source,
574                 "The number of shape specifications, when they appear, must match the rank of allocatable object"_err_en_US)
575             .Attach(
576                 ultimate_->name(), "Declared here with rank %d"_en_US, rank_);
577         return false;
578       }
579     }
580   } else { // allocating a scalar object
581     if (hasAllocateShapeSpecList()) {
582       context.Say(name_.source,
583           "Shape specifications must not appear when allocatable object is scalar"_err_en_US);
584       return false;
585     }
586   }
587   // second and last part of C945
588   if (allocateInfo_.gotSource && allocateInfo_.sourceExprRank &&
589       allocateInfo_.sourceExprRank != rank_) {
590     context
591         .Say(name_.source,
592             "If SOURCE appears, the related expression must be scalar or have the same rank as each allocatable object in ALLOCATE"_err_en_US)
593         .Attach(allocateInfo_.sourceExprLoc.value(),
594             "SOURCE expression has rank %d"_en_US, allocateInfo_.sourceExprRank)
595         .Attach(ultimate_->name(),
596             "Allocatable object declared here with rank %d"_en_US, rank_);
597     return false;
598   }
599   context.CheckIndexVarRedefine(name_);
600   const Scope &subpScope{
601       GetProgramUnitContaining(context.FindScope(name_.source))};
602   if (allocateObject_.typedExpr && allocateObject_.typedExpr->v) {
603     DefinabilityFlags flags{DefinabilityFlag::PointerDefinition,
604         DefinabilityFlag::AcceptAllocatable};
605     if (allocateInfo_.gotSource) {
606       flags.set(DefinabilityFlag::SourcedAllocation);
607     }
608     if (auto whyNot{WhyNotDefinable(
609             name_.source, subpScope, flags, *allocateObject_.typedExpr->v)}) {
610       context
611           .Say(name_.source,
612               "Name in ALLOCATE statement is not definable"_err_en_US)
613           .Attach(std::move(whyNot->set_severity(parser::Severity::Because)));
614       return false;
615     }
616   }
617   if (allocateInfo_.gotPinned) {
618     std::optional<common::CUDADataAttr> cudaAttr{GetCUDADataAttr(ultimate_)};
619     if ((!cudaAttr || *cudaAttr != common::CUDADataAttr::Pinned) &&
620         context.languageFeatures().ShouldWarn(
621             common::UsageWarning::CUDAUsage)) {
622       context.Say(name_.source,
623           "Object in ALLOCATE should have PINNED attribute when PINNED option is specified"_warn_en_US);
624     }
625   }
626   if (allocateInfo_.gotStream) {
627     std::optional<common::CUDADataAttr> cudaAttr{GetCUDADataAttr(ultimate_)};
628     if (!cudaAttr || *cudaAttr != common::CUDADataAttr::Device) {
629       context.Say(name_.source,
630           "Object in ALLOCATE must have DEVICE attribute when STREAM option is specified"_err_en_US);
631     }
632   }
633   return RunCoarrayRelatedChecks(context);
634 }
635 
636 bool AllocationCheckerHelper::RunCoarrayRelatedChecks(
637     SemanticsContext &context) const {
638   if (!ultimate_) {
639     CHECK(context.AnyFatalError());
640     return false;
641   }
642   if (evaluate::IsCoarray(*ultimate_)) {
643     if (allocateInfo_.gotTypeSpec) {
644       // C938
645       if (const DerivedTypeSpec *
646           derived{allocateInfo_.typeSpec->AsDerived()}) {
647         if (IsTeamType(derived)) {
648           context
649               .Say(allocateInfo_.typeSpecLoc.value(),
650                   "Type-Spec in ALLOCATE must not be TEAM_TYPE from ISO_FORTRAN_ENV when an allocatable object is a coarray"_err_en_US)
651               .Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);
652           return false;
653         } else if (IsIsoCType(derived)) {
654           context
655               .Say(allocateInfo_.typeSpecLoc.value(),
656                   "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)
657               .Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);
658           return false;
659         }
660       }
661     } else if (allocateInfo_.gotSource || allocateInfo_.gotMold) {
662       // C948
663       const evaluate::DynamicType &sourceType{
664           allocateInfo_.sourceExprType.value()};
665       if (const auto *derived{evaluate::GetDerivedTypeSpec(sourceType)}) {
666         if (IsTeamType(derived)) {
667           context
668               .Say(allocateInfo_.sourceExprLoc.value(),
669                   "SOURCE or MOLD expression type must not be TEAM_TYPE from ISO_FORTRAN_ENV when an allocatable object is a coarray"_err_en_US)
670               .Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);
671           return false;
672         } else if (IsIsoCType(derived)) {
673           context
674               .Say(allocateInfo_.sourceExprLoc.value(),
675                   "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)
676               .Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);
677           return false;
678         }
679       }
680     }
681     if (!hasAllocateCoarraySpec()) {
682       // C941
683       context.Say(name_.source,
684           "Coarray specification must appear in ALLOCATE when allocatable object is a coarray"_err_en_US);
685       return false;
686     } else {
687       if (allocateCoarraySpecRank_ != corank_) {
688         // Second and last part of C942
689         context
690             .Say(name_.source,
691                 "Corank of coarray specification in ALLOCATE must match corank of alloctable coarray"_err_en_US)
692             .Attach(ultimate_->name(), "Declared here with corank %d"_en_US,
693                 corank_);
694         return false;
695       }
696     }
697   } else { // Not a coarray
698     if (hasAllocateCoarraySpec()) {
699       // C941
700       context.Say(name_.source,
701           "Coarray specification must not appear in ALLOCATE when allocatable object is not a coarray"_err_en_US);
702       return false;
703     }
704   }
705   if (const parser::CoindexedNamedObject *
706       coindexedObject{parser::GetCoindexedNamedObject(allocateObject_)}) {
707     // C950
708     context.Say(parser::FindSourceLocation(*coindexedObject),
709         "Allocatable object must not be coindexed in ALLOCATE"_err_en_US);
710     return false;
711   }
712   return true;
713 }
714 
715 void AllocateChecker::Leave(const parser::AllocateStmt &allocateStmt) {
716   if (auto info{CheckAllocateOptions(allocateStmt, context_)}) {
717     for (const parser::Allocation &allocation :
718         std::get<std::list<parser::Allocation>>(allocateStmt.t)) {
719       AllocationCheckerHelper{allocation, *info}.RunChecks(context_);
720     }
721   }
722 }
723 } // namespace Fortran::semantics
724