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

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