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:
AllocationCheckerHelper(const parser::Allocation & alloc,AllocateCheckerInfo & info)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:
hasAllocateShapeSpecList() const53 bool hasAllocateShapeSpecList() const { return allocateShapeSpecRank_ != 0; }
hasAllocateCoarraySpec() const54 bool hasAllocateCoarraySpec() const { return allocateCoarraySpecRank_ != 0; }
55 bool RunCoarrayRelatedChecks(SemanticsContext &) const;
56
ShapeSpecRank(const parser::Allocation & allocation)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
CoarraySpecRank(const parser::Allocation & allocation)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
GatherAllocationBasicInfo()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
CheckAllocateOptions(const parser::AllocateStmt & allocateStmt,SemanticsContext & context)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.
IsTypeCompatible(const DeclTypeSpec & type1,const DerivedTypeSpec & derivedType2)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
IsTypeCompatible(const DeclTypeSpec & type1,const DeclTypeSpec & type2)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
IsTypeCompatible(const DeclTypeSpec & type1,const evaluate::DynamicType & type2)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.
HaveSameAssumedTypeParameters(const DeclTypeSpec & type1,const DeclTypeSpec & 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
GetTypeParameterInt64Value(const Symbol & parameterSymbol,const DerivedTypeSpec & derivedType)347 static std::optional<std::int64_t> GetTypeParameterInt64Value(
348 const Symbol ¶meterSymbol, 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)
HaveCompatibleKindParameters(const DerivedTypeSpec & derivedType1,const DerivedTypeSpec & derivedType2)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
HaveCompatibleKindParameters(const DeclTypeSpec & type1,const evaluate::DynamicType & type2)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
HaveCompatibleKindParameters(const DeclTypeSpec & type1,const DeclTypeSpec & type2)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
RunChecks(SemanticsContext & context)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
RunCoarrayRelatedChecks(SemanticsContext & context) const538 bool AllocationCheckerHelper::RunCoarrayRelatedChecks(
539 SemanticsContext &context) const {
540 if (!symbol_) {
541 CHECK(context.AnyFatalError());
542 return false;
543 }
544 if (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
Leave(const parser::AllocateStmt & allocateStmt)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