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

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