1 | //===-- lib/Semantics/check-allocate.cpp ----------------------------------===// |
---|---|
2 | // |
3 | // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. |
4 | // See https://llvm.org/LICENSE.txt for license information. |
5 | // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception |
6 | // |
7 | //===----------------------------------------------------------------------===// |
8 | |
9 | #include "check-allocate.h" |
10 | #include "assignment.h" |
11 | #include "definable.h" |
12 | #include "flang/Evaluate/fold.h" |
13 | #include "flang/Evaluate/type.h" |
14 | #include "flang/Parser/parse-tree.h" |
15 | #include "flang/Parser/tools.h" |
16 | #include "flang/Semantics/attr.h" |
17 | #include "flang/Semantics/expression.h" |
18 | #include "flang/Semantics/tools.h" |
19 | #include "flang/Semantics/type.h" |
20 | |
21 | namespace Fortran::semantics { |
22 | |
23 | struct AllocateCheckerInfo { |
24 | const DeclTypeSpec *typeSpec{nullptr}; |
25 | std::optional<evaluate::DynamicType> sourceExprType; |
26 | std::optional<parser::CharBlock> sourceExprLoc; |
27 | std::optional<parser::CharBlock> typeSpecLoc; |
28 | int sourceExprRank{0}; // only valid if gotMold || gotSource |
29 | bool gotStat{false}; |
30 | bool gotMsg{false}; |
31 | bool gotTypeSpec{false}; |
32 | bool gotSource{false}; |
33 | bool gotMold{false}; |
34 | bool gotStream{false}; |
35 | bool gotPinned{false}; |
36 | }; |
37 | |
38 | class AllocationCheckerHelper { |
39 | public: |
40 | AllocationCheckerHelper( |
41 | const parser::Allocation &alloc, AllocateCheckerInfo &info) |
42 | : allocateInfo_{info}, 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 | |
49 | private: |
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 | |
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( |
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. |
275 | static 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 | |
294 | static 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 | |
313 | static 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. |
336 | static 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 | |
374 | static std::optional<std::int64_t> GetTypeParameterInt64Value( |
375 | const Symbol ¶meterSymbol, 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 | |
383 | static 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 | |
396 | static 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 | |
413 | static 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 | |
429 | static 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 | |
443 | static 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 | |
456 | bool 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 | |
642 | bool 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 | |
746 | void 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 |
Definitions
- AllocateCheckerInfo
- AllocationCheckerHelper
- AllocationCheckerHelper
- hasAllocateShapeSpecList
- hasAllocateCoarraySpec
- ShapeSpecRank
- CoarraySpecRank
- GatherAllocationBasicInfo
- CheckAllocateOptions
- IsTypeCompatible
- IsTypeCompatible
- IsTypeCompatible
- HaveSameAssumedTypeParameters
- GetTypeParameterInt64Value
- HaveCompatibleTypeParameters
- HaveCompatibleTypeParameters
- HaveCompatibleTypeParameters
- HaveCompatibleLengths
- HaveCompatibleLengths
- RunChecks
- RunCoarrayRelatedChecks
Update your C++ knowledge – Modern C++11/14/17 Training
Find out more