llvm-project

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}, allocateObject_{std::get<parser::AllocateObject>(
43
                                 alloc.t)},
44
        allocateShapeSpecRank_{ShapeSpecRank(alloc)}, allocateCoarraySpecRank_{
45
                                                          CoarraySpecRank(
46
                                                              alloc)} {}
47

48
  bool RunChecks(SemanticsContext &context);
49

50
private:
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

102
static std::optional<AllocateCheckerInfo> CheckAllocateOptions(
103
    const parser::AllocateStmt &allocateStmt, SemanticsContext &context) {
104
  AllocateCheckerInfo info;
105
  bool stopCheckingAllocate{false}; // for errors that would lead to ambiguity
106
  if (const auto &typeSpec{
107
          std::get<std::optional<parser::TypeSpec>>(allocateStmt.t)}) {
108
    info.typeSpec = typeSpec->declTypeSpec;
109
    if (!info.typeSpec) {
110
      CHECK(context.AnyFatalError());
111
      return std::nullopt;
112
    }
113
    info.gotTypeSpec = true;
114
    info.typeSpecLoc = parser::FindSourceLocation(*typeSpec);
115
    if (const DerivedTypeSpec * derived{info.typeSpec->AsDerived()}) {
116
      // C937
117
      if (auto it{FindCoarrayUltimateComponent(*derived)}) {
118
        context
119
            .Say("Type-spec in ALLOCATE must not specify a type with a coarray"
120
                 " ultimate component"_err_en_US)
121
            .Attach(it->name(),
122
                "Type '%s' has coarray ultimate component '%s' declared here"_en_US,
123
                info.typeSpec->AsFortran(), it.BuildResultDesignatorName());
124
      }
125
    }
126
  }
127

128
  const parser::Expr *parserSourceExpr{nullptr};
129
  for (const parser::AllocOpt &allocOpt :
130
      std::get<std::list<parser::AllocOpt>>(allocateStmt.t)) {
131
    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.
269
static 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

286
static 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

305
static 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.
328
static 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

366
static 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

375
static 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

388
static 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

405
static 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

421
static 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

435
static 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

448
bool 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 dummy argument 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

631
bool 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

710
void 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