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
21namespace Fortran::semantics {
22
23struct 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
38class AllocationCheckerHelper {
39public:
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
50private:
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
102static 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.
269static 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 &derivedType1->typeSymbol() == &derivedType2.typeSymbol();
274 } else if (type1.category() == DeclTypeSpec::Category::ClassDerived) {
275 for (const DerivedTypeSpec *parent{&derivedType2}; parent;
276 parent = parent->typeSymbol().GetParentTypeSpec()) {
277 if (&derivedType1->typeSymbol() == &parent->typeSymbol()) {
278 return true;
279 }
280 }
281 }
282 }
283 return false;
284}
285
286static bool IsTypeCompatible(
287 const DeclTypeSpec &type1, const DeclTypeSpec &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 (const IntrinsicTypeSpec * intrinsicType2{type2.AsIntrinsic()}) {
294 if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
295 return intrinsicType1->category() == intrinsicType2->category();
296 } else {
297 return false;
298 }
299 } else if (const DerivedTypeSpec * derivedType2{type2.AsDerived()}) {
300 return IsTypeCompatible(type1, *derivedType2);
301 }
302 return false;
303}
304
305static bool IsTypeCompatible(
306 const DeclTypeSpec &type1, const evaluate::DynamicType &type2) {
307 if (type1.category() == DeclTypeSpec::Category::ClassStar) {
308 // TypeStar does not make sense in allocate context because assumed type
309 // cannot be allocatable (C709)
310 return true;
311 }
312 if (type2.category() != evaluate::TypeCategory::Derived) {
313 if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
314 return intrinsicType1->category() == type2.category();
315 } else {
316 return false;
317 }
318 } else if (!type2.IsUnlimitedPolymorphic()) {
319 return IsTypeCompatible(type1, type2.GetDerivedTypeSpec());
320 }
321 return false;
322}
323
324// Note: Check assumes type1 is compatible with type2. type2 may have more type
325// parameters than type1 but if a type2 type parameter is assumed, then this
326// check enforce that type1 has it. type1 can be unlimited polymorphic, but not
327// type2.
328static bool HaveSameAssumedTypeParameters(
329 const DeclTypeSpec &type1, const DeclTypeSpec &type2) {
330 if (type2.category() == DeclTypeSpec::Category::Character) {
331 bool type2LengthIsAssumed{type2.characterTypeSpec().length().isAssumed()};
332 if (type1.category() == DeclTypeSpec::Category::Character) {
333 return type1.characterTypeSpec().length().isAssumed() ==
334 type2LengthIsAssumed;
335 }
336 // It is possible to reach this if type1 is unlimited polymorphic
337 return !type2LengthIsAssumed;
338 } else if (const DerivedTypeSpec * derivedType2{type2.AsDerived()}) {
339 int type2AssumedParametersCount{0};
340 int type1AssumedParametersCount{0};
341 for (const auto &pair : derivedType2->parameters()) {
342 type2AssumedParametersCount += pair.second.isAssumed();
343 }
344 // type1 may be unlimited polymorphic
345 if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
346 for (auto it{derivedType1->parameters().begin()};
347 it != derivedType1->parameters().end(); ++it) {
348 if (it->second.isAssumed()) {
349 ++type1AssumedParametersCount;
350 const ParamValue *param{derivedType2->FindParameter(it->first)};
351 if (!param || !param->isAssumed()) {
352 // type1 has an assumed parameter that is not a type parameter of
353 // type2 or not assumed in type2.
354 return false;
355 }
356 }
357 }
358 }
359 // Will return false if type2 has type parameters that are not assumed in
360 // type1 or do not exist in type1
361 return type1AssumedParametersCount == type2AssumedParametersCount;
362 }
363 return true; // other intrinsic types have no length type parameters
364}
365
366static std::optional<std::int64_t> GetTypeParameterInt64Value(
367 const Symbol &parameterSymbol, const DerivedTypeSpec &derivedType) {
368 if (const ParamValue *
369 paramValue{derivedType.FindParameter(parameterSymbol.name())}) {
370 return evaluate::ToInt64(paramValue->GetExplicit());
371 }
372 return std::nullopt;
373}
374
375static bool HaveCompatibleTypeParameters(
376 const DerivedTypeSpec &derivedType1, const DerivedTypeSpec &derivedType2) {
377 for (const Symbol &symbol :
378 OrderParameterDeclarations(derivedType1.typeSymbol())) {
379 auto v1{GetTypeParameterInt64Value(symbol, derivedType1)};
380 auto v2{GetTypeParameterInt64Value(symbol, derivedType2)};
381 if (v1 && v2 && *v1 != *v2) {
382 return false;
383 }
384 }
385 return true;
386}
387
388static bool HaveCompatibleTypeParameters(
389 const DeclTypeSpec &type1, const evaluate::DynamicType &type2) {
390 if (type1.category() == DeclTypeSpec::Category::ClassStar) {
391 return true;
392 }
393 if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
394 return evaluate::ToInt64(intrinsicType1->kind()).value() == type2.kind();
395 } else if (type2.IsUnlimitedPolymorphic()) {
396 return false;
397 } else if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
398 return HaveCompatibleTypeParameters(
399 *derivedType1, type2.GetDerivedTypeSpec());
400 } else {
401 common::die("unexpected type1 category");
402 }
403}
404
405static bool HaveCompatibleTypeParameters(
406 const DeclTypeSpec &type1, const DeclTypeSpec &type2) {
407 if (type1.category() == DeclTypeSpec::Category::ClassStar) {
408 return true;
409 } else if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
410 const IntrinsicTypeSpec *intrinsicType2{type2.AsIntrinsic()};
411 return !intrinsicType2 || intrinsicType1->kind() == intrinsicType2->kind();
412 } else if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
413 const DerivedTypeSpec *derivedType2{type2.AsDerived()};
414 return !derivedType2 ||
415 HaveCompatibleTypeParameters(*derivedType1, *derivedType2);
416 } else {
417 common::die("unexpected type1 category");
418 }
419}
420
421static bool HaveCompatibleLengths(
422 const DeclTypeSpec &type1, const DeclTypeSpec &type2) {
423 if (type1.category() == DeclTypeSpec::Character &&
424 type2.category() == DeclTypeSpec::Character) {
425 auto v1{
426 evaluate::ToInt64(type1.characterTypeSpec().length().GetExplicit())};
427 auto v2{
428 evaluate::ToInt64(type2.characterTypeSpec().length().GetExplicit())};
429 return !v1 || !v2 || *v1 == *v2;
430 } else {
431 return true;
432 }
433}
434
435static bool HaveCompatibleLengths(
436 const DeclTypeSpec &type1, const evaluate::DynamicType &type2) {
437 if (type1.category() == DeclTypeSpec::Character &&
438 type2.category() == TypeCategory::Character) {
439 auto v1{
440 evaluate::ToInt64(type1.characterTypeSpec().length().GetExplicit())};
441 auto v2{type2.knownLength()};
442 return !v1 || !v2 || *v1 == *v2;
443 } else {
444 return true;
445 }
446}
447
448bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
449 if (!ultimate_) {
450 CHECK(context.AnyFatalError());
451 return false;
452 }
453 if (!IsVariableName(*ultimate_)) { // C932 pre-requisite
454 context.Say(name_.source,
455 "Name in ALLOCATE statement must be a variable name"_err_en_US);
456 return false;
457 }
458 if (!type_) {
459 // This is done after variable check because a user could have put
460 // a subroutine name in allocate for instance which is a symbol with
461 // no type.
462 CHECK(context.AnyFatalError());
463 return false;
464 }
465 GatherAllocationBasicInfo();
466 if (!IsAllocatableOrObjectPointer(ultimate_)) { // C932
467 context.Say(name_.source,
468 "Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
469 return false;
470 }
471 bool gotSourceExprOrTypeSpec{allocateInfo_.gotMold ||
472 allocateInfo_.gotTypeSpec || allocateInfo_.gotSource};
473 if (hasDeferredTypeParameter_ && !gotSourceExprOrTypeSpec) {
474 // C933
475 context.Say(name_.source,
476 "Either type-spec or source-expr must appear in ALLOCATE when allocatable object has a deferred type parameters"_err_en_US);
477 return false;
478 }
479 if (isUnlimitedPolymorphic_ && !gotSourceExprOrTypeSpec) {
480 // C933
481 context.Say(name_.source,
482 "Either type-spec or source-expr must appear in ALLOCATE when allocatable object is unlimited polymorphic"_err_en_US);
483 return false;
484 }
485 if (isAbstract_ && !gotSourceExprOrTypeSpec) {
486 // C933
487 context.Say(name_.source,
488 "Either type-spec or source-expr must appear in ALLOCATE when allocatable object is of abstract type"_err_en_US);
489 return false;
490 }
491 if (allocateInfo_.gotTypeSpec) {
492 if (!IsTypeCompatible(*type_, *allocateInfo_.typeSpec)) {
493 // C934
494 context.Say(name_.source,
495 "Allocatable object in ALLOCATE must be type compatible with type-spec"_err_en_US);
496 return false;
497 }
498 if (!HaveCompatibleTypeParameters(*type_, *allocateInfo_.typeSpec)) {
499 context.Say(name_.source,
500 // C936
501 "Type parameters of allocatable object in ALLOCATE must be the same as the corresponding ones in type-spec"_err_en_US);
502 return false;
503 }
504 if (!HaveCompatibleLengths(*type_, *allocateInfo_.typeSpec)) { // C934
505 context.Say(name_.source,
506 "Character length of allocatable object in ALLOCATE must be the same as the type-spec"_err_en_US);
507 return false;
508 }
509 if (!HaveSameAssumedTypeParameters(*type_, *allocateInfo_.typeSpec)) {
510 // C935
511 context.Say(name_.source,
512 "Type parameters in type-spec must be assumed if and only if they are assumed for allocatable object in ALLOCATE"_err_en_US);
513 return false;
514 }
515 } else if (allocateInfo_.gotSource || allocateInfo_.gotMold) {
516 if (!IsTypeCompatible(*type_, allocateInfo_.sourceExprType.value())) {
517 // first part of C945
518 context.Say(name_.source,
519 "Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE"_err_en_US);
520 return false;
521 }
522 if (!HaveCompatibleTypeParameters(
523 *type_, allocateInfo_.sourceExprType.value())) {
524 // C946
525 context.Say(name_.source,
526 "Derived type parameters of allocatable object must be the same as the corresponding ones of SOURCE or MOLD expression"_err_en_US);
527 return false;
528 }
529 // Character length distinction is allowed, with a warning
530 if (!HaveCompatibleLengths(
531 *type_, allocateInfo_.sourceExprType.value())) { // F'2023 C950
532 if (context.ShouldWarn(common::LanguageFeature::AllocateToOtherLength)) {
533 context.Say(name_.source,
534 "Character length of allocatable object in ALLOCATE should be the same as the SOURCE or MOLD"_port_en_US);
535 }
536 return false;
537 }
538 }
539 // Shape related checks
540 if (ultimate_ && evaluate::IsAssumedRank(*ultimate_)) {
541 context.Say(name_.source,
542 "An assumed-rank object 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 if (auto whyNot{WhyNotDefinable(name_.source, subpScope,
604 {DefinabilityFlag::PointerDefinition,
605 DefinabilityFlag::AcceptAllocatable},
606 *allocateObject_.typedExpr->v)}) {
607 context
608 .Say(name_.source,
609 "Name in ALLOCATE statement is not definable"_err_en_US)
610 .Attach(std::move(*whyNot));
611 return false;
612 }
613 }
614 if (allocateInfo_.gotPinned) {
615 std::optional<common::CUDADataAttr> cudaAttr{GetCUDADataAttr(ultimate_)};
616 if (!cudaAttr || *cudaAttr != common::CUDADataAttr::Pinned) {
617 context.Say(name_.source,
618 "Object in ALLOCATE must have PINNED attribute when PINNED option is specified"_err_en_US);
619 }
620 }
621 if (allocateInfo_.gotStream) {
622 std::optional<common::CUDADataAttr> cudaAttr{GetCUDADataAttr(ultimate_)};
623 if (!cudaAttr || *cudaAttr != common::CUDADataAttr::Device) {
624 context.Say(name_.source,
625 "Object in ALLOCATE must have DEVICE attribute when STREAM option is specified"_err_en_US);
626 }
627 }
628 return RunCoarrayRelatedChecks(context);
629}
630
631bool AllocationCheckerHelper::RunCoarrayRelatedChecks(
632 SemanticsContext &context) const {
633 if (!ultimate_) {
634 CHECK(context.AnyFatalError());
635 return false;
636 }
637 if (evaluate::IsCoarray(*ultimate_)) {
638 if (allocateInfo_.gotTypeSpec) {
639 // C938
640 if (const DerivedTypeSpec *
641 derived{allocateInfo_.typeSpec->AsDerived()}) {
642 if (IsTeamType(derived)) {
643 context
644 .Say(allocateInfo_.typeSpecLoc.value(),
645 "Type-Spec in ALLOCATE must not be TEAM_TYPE from ISO_FORTRAN_ENV when an allocatable object is a coarray"_err_en_US)
646 .Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);
647 return false;
648 } else if (IsIsoCType(derived)) {
649 context
650 .Say(allocateInfo_.typeSpecLoc.value(),
651 "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)
652 .Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);
653 return false;
654 }
655 }
656 } else if (allocateInfo_.gotSource || allocateInfo_.gotMold) {
657 // C948
658 const evaluate::DynamicType &sourceType{
659 allocateInfo_.sourceExprType.value()};
660 if (const auto *derived{evaluate::GetDerivedTypeSpec(sourceType)}) {
661 if (IsTeamType(derived)) {
662 context
663 .Say(allocateInfo_.sourceExprLoc.value(),
664 "SOURCE or MOLD expression type must not be TEAM_TYPE from ISO_FORTRAN_ENV when an allocatable object is a coarray"_err_en_US)
665 .Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);
666 return false;
667 } else if (IsIsoCType(derived)) {
668 context
669 .Say(allocateInfo_.sourceExprLoc.value(),
670 "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)
671 .Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);
672 return false;
673 }
674 }
675 }
676 if (!hasAllocateCoarraySpec()) {
677 // C941
678 context.Say(name_.source,
679 "Coarray specification must appear in ALLOCATE when allocatable object is a coarray"_err_en_US);
680 return false;
681 } else {
682 if (allocateCoarraySpecRank_ != corank_) {
683 // Second and last part of C942
684 context
685 .Say(name_.source,
686 "Corank of coarray specification in ALLOCATE must match corank of alloctable coarray"_err_en_US)
687 .Attach(ultimate_->name(), "Declared here with corank %d"_en_US,
688 corank_);
689 return false;
690 }
691 }
692 } else { // Not a coarray
693 if (hasAllocateCoarraySpec()) {
694 // C941
695 context.Say(name_.source,
696 "Coarray specification must not appear in ALLOCATE when allocatable object is not a coarray"_err_en_US);
697 return false;
698 }
699 }
700 if (const parser::CoindexedNamedObject *
701 coindexedObject{parser::GetCoindexedNamedObject(allocateObject_)}) {
702 // C950
703 context.Say(parser::FindSourceLocation(*coindexedObject),
704 "Allocatable object must not be coindexed in ALLOCATE"_err_en_US);
705 return false;
706 }
707 return true;
708}
709
710void AllocateChecker::Leave(const parser::AllocateStmt &allocateStmt) {
711 if (auto info{CheckAllocateOptions(allocateStmt, context_)}) {
712 for (const parser::Allocation &allocation :
713 std::get<std::list<parser::Allocation>>(allocateStmt.t)) {
714 AllocationCheckerHelper{allocation, *info}.RunChecks(context_);
715 }
716 }
717}
718} // namespace Fortran::semantics
719

source code of flang/lib/Semantics/check-allocate.cpp