llvm-project

1
//===-- lib/Semantics/check-declarations.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
// Static declaration checking
10

11
#include "check-declarations.h"
12
#include "definable.h"
13
#include "pointer-assignment.h"
14
#include "flang/Evaluate/check-expression.h"
15
#include "flang/Evaluate/fold.h"
16
#include "flang/Evaluate/tools.h"
17
#include "flang/Parser/characters.h"
18
#include "flang/Semantics/scope.h"
19
#include "flang/Semantics/semantics.h"
20
#include "flang/Semantics/symbol.h"
21
#include "flang/Semantics/tools.h"
22
#include "flang/Semantics/type.h"
23
#include <algorithm>
24
#include <map>
25
#include <string>
26

27
namespace Fortran::semantics {
28

29
namespace characteristics = evaluate::characteristics;
30
using characteristics::DummyArgument;
31
using characteristics::DummyDataObject;
32
using characteristics::DummyProcedure;
33
using characteristics::FunctionResult;
34
using characteristics::Procedure;
35

36
class CheckHelper {
37
public:
38
  explicit CheckHelper(SemanticsContext &c) : context_{c} {}
39

40
  SemanticsContext &context() { return context_; }
41
  void Check() { Check(context_.globalScope()); }
42
  void Check(const ParamValue &, bool canBeAssumed);
43
  void Check(const Bound &bound) {
44
    CheckSpecExpr(bound.GetExplicit(), /*forElementalFunctionResult=*/false);
45
  }
46
  void Check(const ShapeSpec &spec) {
47
    Check(spec.lbound());
48
    Check(spec.ubound());
49
  }
50
  void Check(const ArraySpec &);
51
  void Check(const DeclTypeSpec &, bool canHaveAssumedTypeParameters);
52
  void Check(const Symbol &);
53
  void CheckCommonBlock(const Symbol &);
54
  void Check(const Scope &);
55
  const Procedure *Characterize(const Symbol &);
56

57
private:
58
  template <typename A>
59
  void CheckSpecExpr(const A &x, bool forElementalFunctionResult) {
60
    evaluate::CheckSpecificationExpr(
61
        x, DEREF(scope_), foldingContext_, forElementalFunctionResult);
62
  }
63
  void CheckValue(const Symbol &, const DerivedTypeSpec *);
64
  void CheckVolatile(const Symbol &, const DerivedTypeSpec *);
65
  void CheckContiguous(const Symbol &);
66
  void CheckPointer(const Symbol &);
67
  void CheckPassArg(
68
      const Symbol &proc, const Symbol *interface, const WithPassArg &);
69
  void CheckProcBinding(const Symbol &, const ProcBindingDetails &);
70
  void CheckObjectEntity(const Symbol &, const ObjectEntityDetails &);
71
  void CheckPointerInitialization(const Symbol &);
72
  void CheckArraySpec(const Symbol &, const ArraySpec &);
73
  void CheckProcEntity(const Symbol &, const ProcEntityDetails &);
74
  void CheckSubprogram(const Symbol &, const SubprogramDetails &);
75
  void CheckExternal(const Symbol &);
76
  void CheckAssumedTypeEntity(const Symbol &, const ObjectEntityDetails &);
77
  void CheckDerivedType(const Symbol &, const DerivedTypeDetails &);
78
  bool CheckFinal(
79
      const Symbol &subroutine, SourceName, const Symbol &derivedType);
80
  bool CheckDistinguishableFinals(const Symbol &f1, SourceName f1name,
81
      const Symbol &f2, SourceName f2name, const Symbol &derivedType);
82
  void CheckGeneric(const Symbol &, const GenericDetails &);
83
  void CheckHostAssoc(const Symbol &, const HostAssocDetails &);
84
  bool CheckDefinedOperator(
85
      SourceName, GenericKind, const Symbol &, const Procedure &);
86
  std::optional<parser::MessageFixedText> CheckNumberOfArgs(
87
      const GenericKind &, std::size_t);
88
  bool CheckDefinedOperatorArg(
89
      const SourceName &, const Symbol &, const Procedure &, std::size_t);
90
  bool CheckDefinedAssignment(const Symbol &, const Procedure &);
91
  bool CheckDefinedAssignmentArg(const Symbol &, const DummyArgument &, int);
92
  void CheckSpecifics(const Symbol &, const GenericDetails &);
93
  void CheckEquivalenceSet(const EquivalenceSet &);
94
  void CheckEquivalenceObject(const EquivalenceObject &);
95
  void CheckBlockData(const Scope &);
96
  void CheckGenericOps(const Scope &);
97
  bool CheckConflicting(const Symbol &, Attr, Attr);
98
  void WarnMissingFinal(const Symbol &);
99
  void CheckSymbolType(const Symbol &); // C702
100
  bool InPure() const {
101
    return innermostSymbol_ && IsPureProcedure(*innermostSymbol_);
102
  }
103
  bool InElemental() const {
104
    return innermostSymbol_ && IsElementalProcedure(*innermostSymbol_);
105
  }
106
  bool InFunction() const {
107
    return innermostSymbol_ && IsFunction(*innermostSymbol_);
108
  }
109
  bool InInterface() const {
110
    const SubprogramDetails *subp{innermostSymbol_
111
            ? innermostSymbol_->detailsIf<SubprogramDetails>()
112
            : nullptr};
113
    return subp && subp->isInterface();
114
  }
115
  template <typename... A>
116
  parser::Message *SayWithDeclaration(const Symbol &symbol, A &&...x) {
117
    parser::Message *msg{messages_.Say(std::forward<A>(x)...)};
118
    if (msg && messages_.at().begin() != symbol.name().begin()) {
119
      evaluate::AttachDeclaration(*msg, symbol);
120
    }
121
    return msg;
122
  }
123
  bool InModuleFile() const {
124
    return FindModuleFileContaining(context_.FindScope(messages_.at())) !=
125
        nullptr;
126
  }
127
  template <typename... A> parser::Message *WarnIfNotInModuleFile(A &&...x) {
128
    if (InModuleFile()) {
129
      return nullptr;
130
    } else {
131
      return messages_.Say(std::forward<A>(x)...);
132
    }
133
  }
134
  template <typename... A>
135
  parser::Message *WarnIfNotInModuleFile(parser::CharBlock source, A &&...x) {
136
    if (FindModuleFileContaining(context_.FindScope(source))) {
137
      return nullptr;
138
    }
139
    return messages_.Say(source, std::forward<A>(x)...);
140
  }
141
  bool IsResultOkToDiffer(const FunctionResult &);
142
  void CheckGlobalName(const Symbol &);
143
  void CheckProcedureAssemblyName(const Symbol &symbol);
144
  void CheckExplicitSave(const Symbol &);
145
  parser::Messages WhyNotInteroperableDerivedType(const Symbol &);
146
  parser::Messages WhyNotInteroperableObject(const Symbol &);
147
  parser::Messages WhyNotInteroperableFunctionResult(const Symbol &);
148
  parser::Messages WhyNotInteroperableProcedure(const Symbol &, bool isError);
149
  void CheckBindC(const Symbol &);
150
  // Check functions for defined I/O procedures
151
  void CheckDefinedIoProc(
152
      const Symbol &, const GenericDetails &, common::DefinedIo);
153
  bool CheckDioDummyIsData(const Symbol &, const Symbol *, std::size_t);
154
  void CheckDioDummyIsDerived(
155
      const Symbol &, const Symbol &, common::DefinedIo ioKind, const Symbol &);
156
  void CheckDioDummyIsDefaultInteger(const Symbol &, const Symbol &);
157
  void CheckDioDummyIsScalar(const Symbol &, const Symbol &);
158
  void CheckDioDummyAttrs(const Symbol &, const Symbol &, Attr);
159
  void CheckDioDtvArg(
160
      const Symbol &, const Symbol *, common::DefinedIo, const Symbol &);
161
  void CheckGenericVsIntrinsic(const Symbol &, const GenericDetails &);
162
  void CheckDefaultIntegerArg(const Symbol &, const Symbol *, Attr);
163
  void CheckDioAssumedLenCharacterArg(
164
      const Symbol &, const Symbol *, std::size_t, Attr);
165
  void CheckDioVlistArg(const Symbol &, const Symbol *, std::size_t);
166
  void CheckDioArgCount(const Symbol &, common::DefinedIo ioKind, std::size_t);
167
  struct TypeWithDefinedIo {
168
    const DerivedTypeSpec &type;
169
    common::DefinedIo ioKind;
170
    const Symbol &proc;
171
    const Symbol &generic;
172
  };
173
  void CheckAlreadySeenDefinedIo(const DerivedTypeSpec &, common::DefinedIo,
174
      const Symbol &, const Symbol &generic);
175
  void CheckModuleProcedureDef(const Symbol &);
176

177
  SemanticsContext &context_;
178
  evaluate::FoldingContext &foldingContext_{context_.foldingContext()};
179
  parser::ContextualMessages &messages_{foldingContext_.messages()};
180
  const Scope *scope_{nullptr};
181
  bool scopeIsUninstantiatedPDT_{false};
182
  // This symbol is the one attached to the innermost enclosing scope
183
  // that has a symbol.
184
  const Symbol *innermostSymbol_{nullptr};
185
  // Cache of calls to Procedure::Characterize(Symbol)
186
  std::map<SymbolRef, std::optional<Procedure>, SymbolAddressCompare>
187
      characterizeCache_;
188
  // Collection of module procedure symbols with non-BIND(C)
189
  // global names, qualified by their module.
190
  std::map<std::pair<SourceName, const Symbol *>, SymbolRef> moduleProcs_;
191
  // Collection of symbols with global names, BIND(C) or otherwise
192
  std::map<std::string, SymbolRef> globalNames_;
193
  // Collection of external procedures without global definitions
194
  std::map<std::string, SymbolRef> externalNames_;
195
  // Collection of target dependent assembly names of external and BIND(C)
196
  // procedures.
197
  std::map<std::string, SymbolRef> procedureAssemblyNames_;
198
  // Derived types that have been examined by WhyNotInteroperable_XXX
199
  UnorderedSymbolSet examinedByWhyNotInteroperable_;
200
};
201

202
class DistinguishabilityHelper {
203
public:
204
  DistinguishabilityHelper(SemanticsContext &context) : context_{context} {}
205
  void Add(const Symbol &, GenericKind, const Symbol &, const Procedure &);
206
  void Check(const Scope &);
207

208
private:
209
  void SayNotDistinguishable(const Scope &, const SourceName &, GenericKind,
210
      const Symbol &, const Symbol &, bool isHardConflict);
211
  void AttachDeclaration(parser::Message &, const Scope &, const Symbol &);
212

213
  SemanticsContext &context_;
214
  struct ProcedureInfo {
215
    GenericKind kind;
216
    const Procedure &procedure;
217
  };
218
  std::map<SourceName, std::map<const Symbol *, ProcedureInfo>>
219
      nameToSpecifics_;
220
};
221

222
void CheckHelper::Check(const ParamValue &value, bool canBeAssumed) {
223
  if (value.isAssumed()) {
224
    if (!canBeAssumed) { // C795, C721, C726
225
      messages_.Say(
226
          "An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, character named constant, or external function result"_err_en_US);
227
    }
228
  } else {
229
    CheckSpecExpr(value.GetExplicit(), /*forElementalFunctionResult=*/false);
230
  }
231
}
232

233
void CheckHelper::Check(const ArraySpec &shape) {
234
  for (const auto &spec : shape) {
235
    Check(spec);
236
  }
237
}
238

239
void CheckHelper::Check(
240
    const DeclTypeSpec &type, bool canHaveAssumedTypeParameters) {
241
  if (type.category() == DeclTypeSpec::Character) {
242
    Check(type.characterTypeSpec().length(), canHaveAssumedTypeParameters);
243
  } else if (const DerivedTypeSpec *derived{type.AsDerived()}) {
244
    for (auto &parm : derived->parameters()) {
245
      Check(parm.second, canHaveAssumedTypeParameters);
246
    }
247
  }
248
}
249

250
void CheckHelper::Check(const Symbol &symbol) {
251
  if (symbol.name().size() > common::maxNameLen &&
252
      &symbol == &symbol.GetUltimate()) {
253
    if (context_.ShouldWarn(common::LanguageFeature::LongNames)) {
254
      WarnIfNotInModuleFile(symbol.name(),
255
          "%s has length %d, which is greater than the maximum name length %d"_port_en_US,
256
          symbol.name(), symbol.name().size(), common::maxNameLen);
257
    }
258
  }
259
  if (context_.HasError(symbol)) {
260
    return;
261
  }
262
  auto restorer{messages_.SetLocation(symbol.name())};
263
  context_.set_location(symbol.name());
264
  const DeclTypeSpec *type{symbol.GetType()};
265
  const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
266
  bool isDone{false};
267
  common::visit(
268
      common::visitors{
269
          [&](const UseDetails &x) { isDone = true; },
270
          [&](const HostAssocDetails &x) {
271
            CheckHostAssoc(symbol, x);
272
            isDone = true;
273
          },
274
          [&](const ProcBindingDetails &x) {
275
            CheckProcBinding(symbol, x);
276
            isDone = true;
277
          },
278
          [&](const ObjectEntityDetails &x) { CheckObjectEntity(symbol, x); },
279
          [&](const ProcEntityDetails &x) { CheckProcEntity(symbol, x); },
280
          [&](const SubprogramDetails &x) { CheckSubprogram(symbol, x); },
281
          [&](const DerivedTypeDetails &x) { CheckDerivedType(symbol, x); },
282
          [&](const GenericDetails &x) { CheckGeneric(symbol, x); },
283
          [](const auto &) {},
284
      },
285
      symbol.details());
286
  if (symbol.attrs().test(Attr::VOLATILE)) {
287
    CheckVolatile(symbol, derived);
288
  }
289
  if (symbol.attrs().test(Attr::BIND_C)) {
290
    CheckBindC(symbol);
291
  }
292
  if (symbol.attrs().test(Attr::SAVE) &&
293
      !symbol.implicitAttrs().test(Attr::SAVE)) {
294
    CheckExplicitSave(symbol);
295
  }
296
  if (symbol.attrs().test(Attr::CONTIGUOUS)) {
297
    CheckContiguous(symbol);
298
  }
299
  CheckGlobalName(symbol);
300
  CheckProcedureAssemblyName(symbol);
301
  if (symbol.attrs().test(Attr::ASYNCHRONOUS) &&
302
      !evaluate::IsVariable(symbol)) {
303
    messages_.Say(
304
        "An entity may not have the ASYNCHRONOUS attribute unless it is a variable"_err_en_US);
305
  }
306
  if (symbol.attrs().HasAny({Attr::INTENT_IN, Attr::INTENT_INOUT,
307
          Attr::INTENT_OUT, Attr::OPTIONAL, Attr::VALUE}) &&
308
      !IsDummy(symbol)) {
309
    messages_.Say(
310
        "Only a dummy argument may have an INTENT, VALUE, or OPTIONAL attribute"_err_en_US);
311
  } else if (symbol.attrs().test(Attr::VALUE)) {
312
    CheckValue(symbol, derived);
313
  }
314

315
  if (isDone) {
316
    return; // following checks do not apply
317
  }
318

319
  if (symbol.attrs().test(Attr::PROTECTED)) {
320
    if (symbol.owner().kind() != Scope::Kind::Module) { // C854
321
      messages_.Say(
322
          "A PROTECTED entity must be in the specification part of a module"_err_en_US);
323
    }
324
    if (!evaluate::IsVariable(symbol) && !IsProcedurePointer(symbol)) { // C855
325
      messages_.Say(
326
          "A PROTECTED entity must be a variable or pointer"_err_en_US);
327
    }
328
    if (FindCommonBlockContaining(symbol)) { // C856
329
      messages_.Say(
330
          "A PROTECTED entity may not be in a common block"_err_en_US);
331
    }
332
  }
333
  if (IsPointer(symbol)) {
334
    CheckPointer(symbol);
335
  }
336
  if (InPure()) {
337
    if (InInterface()) {
338
      // Declarations in interface definitions "have no effect" if they
339
      // are not pertinent to the characteristics of the procedure.
340
      // Restrictions on entities in pure procedure interfaces don't need
341
      // enforcement.
342
    } else if (!FindCommonBlockContaining(symbol) && IsSaved(symbol)) {
343
      if (IsInitialized(symbol)) {
344
        messages_.Say(
345
            "A pure subprogram may not initialize a variable"_err_en_US);
346
      } else {
347
        messages_.Say(
348
            "A pure subprogram may not have a variable with the SAVE attribute"_err_en_US);
349
      }
350
    }
351
    if (symbol.attrs().test(Attr::VOLATILE) &&
352
        (IsDummy(symbol) || !InInterface())) {
353
      messages_.Say(
354
          "A pure subprogram may not have a variable with the VOLATILE attribute"_err_en_US);
355
    }
356
    if (innermostSymbol_ && innermostSymbol_->name() == "__builtin_c_funloc") {
357
      // The intrinsic procedure C_FUNLOC() gets a pass on this check.
358
    } else if (IsProcedure(symbol) && !IsPureProcedure(symbol) &&
359
        IsDummy(symbol)) {
360
      messages_.Say(
361
          "A dummy procedure of a pure subprogram must be pure"_err_en_US);
362
    }
363
  }
364
  const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
365
  if (type) { // Section 7.2, paragraph 7; C795
366
    bool isChar{type->category() == DeclTypeSpec::Character};
367
    bool canHaveAssumedParameter{(isChar && IsNamedConstant(symbol)) ||
368
        (IsAssumedLengthCharacter(symbol) && // C722
369
            (IsExternal(symbol) ||
370
                ClassifyProcedure(symbol) ==
371
                    ProcedureDefinitionClass::Dummy)) ||
372
        symbol.test(Symbol::Flag::ParentComp)};
373
    if (!IsStmtFunctionDummy(symbol)) { // C726
374
      if (object) {
375
        canHaveAssumedParameter |= object->isDummy() ||
376
            (isChar && object->isFuncResult()) ||
377
            IsStmtFunctionResult(symbol); // Avoids multiple messages
378
      } else {
379
        canHaveAssumedParameter |= symbol.has<AssocEntityDetails>();
380
      }
381
    }
382
    if (IsProcedurePointer(symbol) && symbol.HasExplicitInterface()) {
383
      // Don't check function result types here
384
    } else {
385
      Check(*type, canHaveAssumedParameter);
386
    }
387
    if (InFunction() && IsFunctionResult(symbol)) {
388
      if (InPure()) {
389
        if (type->IsPolymorphic() && IsAllocatable(symbol)) { // C1585
390
          messages_.Say(
391
              "Result of pure function may not be both polymorphic and ALLOCATABLE"_err_en_US);
392
        }
393
        if (derived) {
394
          // These cases would be caught be the general validation of local
395
          // variables in a pure context, but these messages are more specific.
396
          if (HasImpureFinal(symbol)) { // C1584
397
            messages_.Say(
398
                "Result of pure function may not have an impure FINAL subroutine"_err_en_US);
399
          }
400
          if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) {
401
            SayWithDeclaration(*bad,
402
                "Result of pure function may not have polymorphic ALLOCATABLE ultimate component '%s'"_err_en_US,
403
                bad.BuildResultDesignatorName());
404
          }
405
        }
406
      }
407
      if (InElemental() && isChar) { // F'2023 C15121
408
        CheckSpecExpr(type->characterTypeSpec().length().GetExplicit(),
409
            /*forElementalFunctionResult=*/true);
410
        // TODO: check PDT LEN parameters
411
      }
412
    }
413
  }
414
  if (IsAssumedLengthCharacter(symbol) && IsFunction(symbol)) { // C723
415
    if (symbol.attrs().test(Attr::RECURSIVE)) {
416
      messages_.Say(
417
          "An assumed-length CHARACTER(*) function cannot be RECURSIVE"_err_en_US);
418
    }
419
    if (symbol.Rank() > 0) {
420
      messages_.Say(
421
          "An assumed-length CHARACTER(*) function cannot return an array"_err_en_US);
422
    }
423
    if (!IsStmtFunction(symbol)) {
424
      if (IsElementalProcedure(symbol)) {
425
        messages_.Say(
426
            "An assumed-length CHARACTER(*) function cannot be ELEMENTAL"_err_en_US);
427
      } else if (IsPureProcedure(symbol)) {
428
        messages_.Say(
429
            "An assumed-length CHARACTER(*) function cannot be PURE"_err_en_US);
430
      }
431
    }
432
    if (const Symbol *result{FindFunctionResult(symbol)}) {
433
      if (IsPointer(*result)) {
434
        messages_.Say(
435
            "An assumed-length CHARACTER(*) function cannot return a POINTER"_err_en_US);
436
      }
437
    }
438
    if (IsProcedurePointer(symbol) && IsDummy(symbol)) {
439
      if (context_.ShouldWarn(common::UsageWarning::Portability)) {
440
        messages_.Say(
441
            "A dummy procedure pointer should not have assumed-length CHARACTER(*) result type"_port_en_US);
442
      }
443
      // The non-dummy case is a hard error that's caught elsewhere.
444
    }
445
  }
446
  if (IsDummy(symbol)) {
447
    if (IsNamedConstant(symbol)) {
448
      messages_.Say(
449
          "A dummy argument may not also be a named constant"_err_en_US);
450
    }
451
  } else if (IsFunctionResult(symbol)) {
452
    if (IsNamedConstant(symbol)) {
453
      messages_.Say(
454
          "A function result may not also be a named constant"_err_en_US);
455
    }
456
  }
457
  if (IsAutomatic(symbol)) {
458
    if (const Symbol * common{FindCommonBlockContaining(symbol)}) {
459
      messages_.Say(
460
          "Automatic data object '%s' may not appear in COMMON block /%s/"_err_en_US,
461
          symbol.name(), common->name());
462
    } else if (symbol.owner().IsModule()) {
463
      messages_.Say(
464
          "Automatic data object '%s' may not appear in a module"_err_en_US,
465
          symbol.name());
466
    }
467
  }
468
  if (IsProcedure(symbol)) {
469
    if (IsAllocatable(symbol)) {
470
      messages_.Say(
471
          "Procedure '%s' may not be ALLOCATABLE"_err_en_US, symbol.name());
472
    }
473
    if (!symbol.HasExplicitInterface() && symbol.Rank() > 0) {
474
      messages_.Say(
475
          "Procedure '%s' may not be an array without an explicit interface"_err_en_US,
476
          symbol.name());
477
    }
478
  }
479
}
480

481
void CheckHelper::CheckCommonBlock(const Symbol &symbol) {
482
  CheckGlobalName(symbol);
483
  if (symbol.attrs().test(Attr::BIND_C)) {
484
    CheckBindC(symbol);
485
  }
486
  for (MutableSymbolRef ref : symbol.get<CommonBlockDetails>().objects()) {
487
    if (ref->test(Symbol::Flag::CrayPointee)) {
488
      messages_.Say(ref->name(),
489
          "Cray pointee '%s' may not be a member of a COMMON block"_err_en_US,
490
          ref->name());
491
    }
492
  }
493
}
494

495
// C859, C860
496
void CheckHelper::CheckExplicitSave(const Symbol &symbol) {
497
  const Symbol &ultimate{symbol.GetUltimate()};
498
  if (ultimate.test(Symbol::Flag::InDataStmt)) {
499
    // checked elsewhere
500
  } else if (symbol.has<UseDetails>()) {
501
    messages_.Say(
502
        "The USE-associated name '%s' may not have an explicit SAVE attribute"_err_en_US,
503
        symbol.name());
504
  } else if (IsDummy(ultimate)) {
505
    messages_.Say(
506
        "The dummy argument '%s' may not have an explicit SAVE attribute"_err_en_US,
507
        symbol.name());
508
  } else if (IsFunctionResult(ultimate)) {
509
    messages_.Say(
510
        "The function result variable '%s' may not have an explicit SAVE attribute"_err_en_US,
511
        symbol.name());
512
  } else if (const Symbol * common{FindCommonBlockContaining(ultimate)}) {
513
    messages_.Say(
514
        "The entity '%s' in COMMON block /%s/ may not have an explicit SAVE attribute"_err_en_US,
515
        symbol.name(), common->name());
516
  } else if (IsAutomatic(ultimate)) {
517
    messages_.Say(
518
        "The automatic object '%s' may not have an explicit SAVE attribute"_err_en_US,
519
        symbol.name());
520
  } else if (!evaluate::IsVariable(ultimate) && !IsProcedurePointer(ultimate)) {
521
    messages_.Say(
522
        "The entity '%s' with an explicit SAVE attribute must be a variable, procedure pointer, or COMMON block"_err_en_US,
523
        symbol.name());
524
  }
525
}
526

527
void CheckHelper::CheckValue(
528
    const Symbol &symbol, const DerivedTypeSpec *derived) { // C863 - C865
529
  if (IsProcedure(symbol)) {
530
    messages_.Say(
531
        "VALUE attribute may apply only to a dummy data object"_err_en_US);
532
    return; // don't pile on
533
  }
534
  if (IsAssumedSizeArray(symbol)) {
535
    messages_.Say(
536
        "VALUE attribute may not apply to an assumed-size array"_err_en_US);
537
  }
538
  if (evaluate::IsCoarray(symbol)) {
539
    messages_.Say("VALUE attribute may not apply to a coarray"_err_en_US);
540
  }
541
  if (IsAllocatable(symbol)) {
542
    messages_.Say("VALUE attribute may not apply to an ALLOCATABLE"_err_en_US);
543
  } else if (IsPointer(symbol)) {
544
    messages_.Say("VALUE attribute may not apply to a POINTER"_err_en_US);
545
  }
546
  if (IsIntentInOut(symbol)) {
547
    messages_.Say(
548
        "VALUE attribute may not apply to an INTENT(IN OUT) argument"_err_en_US);
549
  } else if (IsIntentOut(symbol)) {
550
    messages_.Say(
551
        "VALUE attribute may not apply to an INTENT(OUT) argument"_err_en_US);
552
  }
553
  if (symbol.attrs().test(Attr::VOLATILE)) {
554
    messages_.Say("VALUE attribute may not apply to a VOLATILE"_err_en_US);
555
  }
556
  if (innermostSymbol_ && IsBindCProcedure(*innermostSymbol_)) {
557
    if (IsOptional(symbol)) {
558
      messages_.Say(
559
          "VALUE attribute may not apply to an OPTIONAL in a BIND(C) procedure"_err_en_US);
560
    }
561
    if (symbol.Rank() > 0) {
562
      messages_.Say(
563
          "VALUE attribute may not apply to an array in a BIND(C) procedure"_err_en_US);
564
    }
565
  }
566
  if (derived) {
567
    if (FindCoarrayUltimateComponent(*derived)) {
568
      messages_.Say(
569
          "VALUE attribute may not apply to a type with a coarray ultimate component"_err_en_US);
570
    }
571
  }
572
  if (evaluate::IsAssumedRank(symbol)) {
573
    messages_.Say(
574
        "VALUE attribute may not apply to an assumed-rank array"_err_en_US);
575
  }
576
  if (context_.ShouldWarn(common::UsageWarning::Portability) &&
577
      IsAssumedLengthCharacter(symbol)) {
578
    // F'2008 feature not widely implemented
579
    messages_.Say(
580
        "VALUE attribute on assumed-length CHARACTER may not be portable"_port_en_US);
581
  }
582
}
583

584
void CheckHelper::CheckAssumedTypeEntity( // C709
585
    const Symbol &symbol, const ObjectEntityDetails &details) {
586
  if (const DeclTypeSpec *type{symbol.GetType()};
587
      type && type->category() == DeclTypeSpec::TypeStar) {
588
    if (!IsDummy(symbol)) {
589
      messages_.Say(
590
          "Assumed-type entity '%s' must be a dummy argument"_err_en_US,
591
          symbol.name());
592
    } else {
593
      if (symbol.attrs().test(Attr::ALLOCATABLE)) {
594
        messages_.Say("Assumed-type argument '%s' cannot have the ALLOCATABLE"
595
                      " attribute"_err_en_US,
596
            symbol.name());
597
      }
598
      if (symbol.attrs().test(Attr::POINTER)) {
599
        messages_.Say("Assumed-type argument '%s' cannot have the POINTER"
600
                      " attribute"_err_en_US,
601
            symbol.name());
602
      }
603
      if (symbol.attrs().test(Attr::VALUE)) {
604
        messages_.Say("Assumed-type argument '%s' cannot have the VALUE"
605
                      " attribute"_err_en_US,
606
            symbol.name());
607
      }
608
      if (symbol.attrs().test(Attr::INTENT_OUT)) {
609
        messages_.Say(
610
            "Assumed-type argument '%s' cannot be INTENT(OUT)"_err_en_US,
611
            symbol.name());
612
      }
613
      if (evaluate::IsCoarray(symbol)) {
614
        messages_.Say(
615
            "Assumed-type argument '%s' cannot be a coarray"_err_en_US,
616
            symbol.name());
617
      }
618
      if (details.IsArray() && details.shape().IsExplicitShape()) {
619
        messages_.Say("Assumed-type array argument '%s' must be assumed shape,"
620
                      " assumed size, or assumed rank"_err_en_US,
621
            symbol.name());
622
      }
623
    }
624
  }
625
}
626

627
void CheckHelper::CheckObjectEntity(
628
    const Symbol &symbol, const ObjectEntityDetails &details) {
629
  CheckSymbolType(symbol);
630
  CheckArraySpec(symbol, details.shape());
631
  CheckConflicting(symbol, Attr::ALLOCATABLE, Attr::PARAMETER);
632
  CheckConflicting(symbol, Attr::ASYNCHRONOUS, Attr::PARAMETER);
633
  CheckConflicting(symbol, Attr::SAVE, Attr::PARAMETER);
634
  CheckConflicting(symbol, Attr::TARGET, Attr::PARAMETER);
635
  CheckConflicting(symbol, Attr::VOLATILE, Attr::PARAMETER);
636
  Check(details.shape());
637
  Check(details.coshape());
638
  if (details.shape().Rank() > common::maxRank) {
639
    messages_.Say(
640
        "'%s' has rank %d, which is greater than the maximum supported rank %d"_err_en_US,
641
        symbol.name(), details.shape().Rank(), common::maxRank);
642
  } else if (details.shape().Rank() + details.coshape().Rank() >
643
      common::maxRank) {
644
    messages_.Say(
645
        "'%s' has rank %d and corank %d, whose sum is greater than the maximum supported rank %d"_err_en_US,
646
        symbol.name(), details.shape().Rank(), details.coshape().Rank(),
647
        common::maxRank);
648
  }
649
  CheckAssumedTypeEntity(symbol, details);
650
  WarnMissingFinal(symbol);
651
  const DeclTypeSpec *type{details.type()};
652
  const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
653
  bool isComponent{symbol.owner().IsDerivedType()};
654
  if (!details.coshape().empty()) {
655
    bool isDeferredCoshape{details.coshape().CanBeDeferredShape()};
656
    if (IsAllocatable(symbol)) {
657
      if (!isDeferredCoshape) { // C827
658
        messages_.Say("'%s' is an ALLOCATABLE coarray and must have a deferred"
659
                      " coshape"_err_en_US,
660
            symbol.name());
661
      }
662
    } else if (isComponent) { // C746
663
      std::string deferredMsg{
664
          isDeferredCoshape ? "" : " and have a deferred coshape"};
665
      messages_.Say("Component '%s' is a coarray and must have the ALLOCATABLE"
666
                    " attribute%s"_err_en_US,
667
          symbol.name(), deferredMsg);
668
    } else {
669
      if (!details.coshape().CanBeAssumedSize()) { // C828
670
        messages_.Say(
671
            "'%s' is a non-ALLOCATABLE coarray and must have an explicit coshape"_err_en_US,
672
            symbol.name());
673
      }
674
    }
675
    if (IsBadCoarrayType(derived)) { // C747 & C824
676
      messages_.Say(
677
          "Coarray '%s' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR"_err_en_US,
678
          symbol.name());
679
    }
680
    if (evaluate::IsAssumedRank(symbol)) {
681
      messages_.Say("Coarray '%s' may not be an assumed-rank array"_err_en_US,
682
          symbol.name());
683
    }
684
  }
685
  if (details.isDummy()) {
686
    if (IsIntentOut(symbol)) {
687
      // Some of these errors would also be caught by the general check
688
      // for definability of automatically deallocated local variables,
689
      // but these messages are more specific.
690
      if (FindUltimateComponent(symbol, [](const Symbol &x) {
691
            return evaluate::IsCoarray(x) && IsAllocatable(x);
692
          })) { // C846
693
        messages_.Say(
694
            "An INTENT(OUT) dummy argument may not be, or contain, an ALLOCATABLE coarray"_err_en_US);
695
      }
696
      if (IsOrContainsEventOrLockComponent(symbol)) { // C847
697
        messages_.Say(
698
            "An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE"_err_en_US);
699
      }
700
      if (IsAssumedSizeArray(symbol)) { // C834
701
        if (type && type->IsPolymorphic()) {
702
          messages_.Say(
703
              "An INTENT(OUT) assumed-size dummy argument array may not be polymorphic"_err_en_US);
704
        }
705
        if (derived) {
706
          if (derived->HasDefaultInitialization()) {
707
            messages_.Say(
708
                "An INTENT(OUT) assumed-size dummy argument array may not have a derived type with any default component initialization"_err_en_US);
709
          }
710
          if (IsFinalizable(*derived)) {
711
            messages_.Say(
712
                "An INTENT(OUT) assumed-size dummy argument array may not be finalizable"_err_en_US);
713
          }
714
        }
715
      }
716
    }
717
    if (InPure() && !IsStmtFunction(DEREF(innermostSymbol_)) &&
718
        !IsPointer(symbol) && !IsIntentIn(symbol) &&
719
        !symbol.attrs().test(Attr::VALUE)) {
720
      const char *what{InFunction() ? "function" : "subroutine"};
721
      bool ok{true};
722
      if (IsIntentOut(symbol)) {
723
        if (type && type->IsPolymorphic()) { // C1588
724
          messages_.Say(
725
              "An INTENT(OUT) dummy argument of a pure %s may not be polymorphic"_err_en_US,
726
              what);
727
          ok = false;
728
        } else if (derived) {
729
          if (FindUltimateComponent(*derived, [](const Symbol &x) {
730
                const DeclTypeSpec *type{x.GetType()};
731
                return type && type->IsPolymorphic();
732
              })) { // C1588
733
            messages_.Say(
734
                "An INTENT(OUT) dummy argument of a pure %s may not have a polymorphic ultimate component"_err_en_US,
735
                what);
736
            ok = false;
737
          }
738
          if (HasImpureFinal(symbol)) { // C1587
739
            messages_.Say(
740
                "An INTENT(OUT) dummy argument of a pure %s may not have an impure FINAL subroutine"_err_en_US,
741
                what);
742
            ok = false;
743
          }
744
        }
745
      } else if (!IsIntentInOut(symbol)) { // C1586
746
        messages_.Say(
747
            "non-POINTER dummy argument of pure %s must have INTENT() or VALUE attribute"_err_en_US,
748
            what);
749
        ok = false;
750
      }
751
      if (ok && InFunction() && !InModuleFile() && !InElemental()) {
752
        if (context_.IsEnabled(common::LanguageFeature::RelaxedPureDummy)) {
753
          if (context_.ShouldWarn(common::LanguageFeature::RelaxedPureDummy)) {
754
            messages_.Say(
755
                "non-POINTER dummy argument of pure function should be INTENT(IN) or VALUE"_warn_en_US);
756
          }
757
        } else {
758
          messages_.Say(
759
              "non-POINTER dummy argument of pure function must be INTENT(IN) or VALUE"_err_en_US);
760
        }
761
      }
762
    }
763
    if (auto ignoreTKR{GetIgnoreTKR(symbol)}; !ignoreTKR.empty()) {
764
      const Symbol *ownerSymbol{symbol.owner().symbol()};
765
      const auto *ownerSubp{ownerSymbol->detailsIf<SubprogramDetails>()};
766
      bool inInterface{ownerSubp && ownerSubp->isInterface()};
767
      bool inExplicitInterface{
768
          inInterface && !IsSeparateModuleProcedureInterface(ownerSymbol)};
769
      bool inModuleProc{
770
          !inInterface && ownerSymbol && IsModuleProcedure(*ownerSymbol)};
771
      if (!inExplicitInterface && !inModuleProc) {
772
        messages_.Say(
773
            "!DIR$ IGNORE_TKR may apply only in an interface or a module procedure"_err_en_US);
774
      }
775
      if (ownerSymbol && ownerSymbol->attrs().test(Attr::ELEMENTAL) &&
776
          details.ignoreTKR().test(common::IgnoreTKR::Rank)) {
777
        messages_.Say(
778
            "!DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure"_err_en_US);
779
      }
780
      if (IsPassedViaDescriptor(symbol)) {
781
        if (IsAllocatableOrObjectPointer(&symbol)) {
782
          if (inExplicitInterface) {
783
            if (context_.ShouldWarn(common::UsageWarning::IgnoreTKRUsage)) {
784
              WarnIfNotInModuleFile(
785
                  "!DIR$ IGNORE_TKR should not apply to an allocatable or pointer"_warn_en_US);
786
            }
787
          } else {
788
            messages_.Say(
789
                "!DIR$ IGNORE_TKR may not apply to an allocatable or pointer"_err_en_US);
790
          }
791
        } else if (ignoreTKR.test(common::IgnoreTKR::Rank)) {
792
          if (ignoreTKR.count() == 1 && evaluate::IsAssumedRank(symbol)) {
793
            if (context_.ShouldWarn(common::UsageWarning::IgnoreTKRUsage)) {
794
              WarnIfNotInModuleFile(
795
                  "!DIR$ IGNORE_TKR(R) is not meaningful for an assumed-rank array"_warn_en_US);
796
            }
797
          } else if (inExplicitInterface) {
798
            if (context_.ShouldWarn(common::UsageWarning::IgnoreTKRUsage)) {
799
              WarnIfNotInModuleFile(
800
                  "!DIR$ IGNORE_TKR(R) should not apply to a dummy argument passed via descriptor"_warn_en_US);
801
            }
802
          } else {
803
            messages_.Say(
804
                "!DIR$ IGNORE_TKR(R) may not apply to a dummy argument passed via descriptor"_err_en_US);
805
          }
806
        }
807
      }
808
    }
809
  } else if (!details.ignoreTKR().empty()) {
810
    messages_.Say(
811
        "!DIR$ IGNORE_TKR directive may apply only to a dummy data argument"_err_en_US);
812
  }
813
  if (InElemental()) {
814
    if (details.isDummy()) { // C15100
815
      if (details.shape().Rank() > 0) {
816
        messages_.Say(
817
            "A dummy argument of an ELEMENTAL procedure must be scalar"_err_en_US);
818
      }
819
      if (IsAllocatable(symbol)) {
820
        messages_.Say(
821
            "A dummy argument of an ELEMENTAL procedure may not be ALLOCATABLE"_err_en_US);
822
      }
823
      if (evaluate::IsCoarray(symbol)) {
824
        messages_.Say(
825
            "A dummy argument of an ELEMENTAL procedure may not be a coarray"_err_en_US);
826
      }
827
      if (IsPointer(symbol)) {
828
        messages_.Say(
829
            "A dummy argument of an ELEMENTAL procedure may not be a POINTER"_err_en_US);
830
      }
831
      if (!symbol.attrs().HasAny(Attrs{Attr::VALUE, Attr::INTENT_IN,
832
              Attr::INTENT_INOUT, Attr::INTENT_OUT})) { // F'2023 C15120
833
        messages_.Say(
834
            "A dummy argument of an ELEMENTAL procedure must have an INTENT() or VALUE attribute"_err_en_US);
835
      }
836
    } else if (IsFunctionResult(symbol)) { // C15101
837
      if (details.shape().Rank() > 0) {
838
        messages_.Say(
839
            "The result of an ELEMENTAL function must be scalar"_err_en_US);
840
      }
841
      if (IsAllocatable(symbol)) {
842
        messages_.Say(
843
            "The result of an ELEMENTAL function may not be ALLOCATABLE"_err_en_US);
844
      }
845
      if (IsPointer(symbol)) {
846
        messages_.Say(
847
            "The result of an ELEMENTAL function may not be a POINTER"_err_en_US);
848
      }
849
    }
850
  }
851
  if (HasDeclarationInitializer(symbol)) { // C808; ignore DATA initialization
852
    CheckPointerInitialization(symbol);
853
    if (IsAutomatic(symbol)) {
854
      messages_.Say(
855
          "An automatic variable or component must not be initialized"_err_en_US);
856
    } else if (IsDummy(symbol)) {
857
      messages_.Say("A dummy argument must not be initialized"_err_en_US);
858
    } else if (IsFunctionResult(symbol)) {
859
      messages_.Say("A function result must not be initialized"_err_en_US);
860
    } else if (IsInBlankCommon(symbol)) {
861
      if (context_.ShouldWarn(common::LanguageFeature::InitBlankCommon)) {
862
        WarnIfNotInModuleFile(
863
            "A variable in blank COMMON should not be initialized"_port_en_US);
864
      }
865
    }
866
  }
867
  if (symbol.owner().kind() == Scope::Kind::BlockData) {
868
    if (IsAllocatable(symbol)) {
869
      messages_.Say(
870
          "An ALLOCATABLE variable may not appear in a BLOCK DATA subprogram"_err_en_US);
871
    } else if (IsInitialized(symbol) && !FindCommonBlockContaining(symbol)) {
872
      messages_.Say(
873
          "An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US);
874
    }
875
  }
876
  if (derived && InPure() && !InInterface() &&
877
      IsAutomaticallyDestroyed(symbol) &&
878
      !IsIntentOut(symbol) /*has better messages*/ &&
879
      !IsFunctionResult(symbol) /*ditto*/) {
880
    // Check automatically deallocated local variables for possible
881
    // problems with finalization in PURE.
882
    if (auto whyNot{
883
            WhyNotDefinable(symbol.name(), symbol.owner(), {}, symbol)}) {
884
      if (auto *msg{messages_.Say(
885
              "'%s' may not be a local variable in a pure subprogram"_err_en_US,
886
              symbol.name())}) {
887
        msg->Attach(std::move(*whyNot));
888
      }
889
    }
890
  }
891
  if (symbol.attrs().test(Attr::EXTERNAL)) {
892
    SayWithDeclaration(symbol,
893
        "'%s' is a data object and may not be EXTERNAL"_err_en_US,
894
        symbol.name());
895
  }
896

897
  // Check CUDA attributes and special circumstances of being in device
898
  // subprograms
899
  const Scope &progUnit{GetProgramUnitContaining(symbol)};
900
  const auto *subpDetails{!isComponent && progUnit.symbol()
901
          ? progUnit.symbol()->detailsIf<SubprogramDetails>()
902
          : nullptr};
903
  bool inDeviceSubprogram{IsCUDADeviceContext(&symbol.owner())};
904
  if (inDeviceSubprogram) {
905
    if (IsSaved(symbol)) {
906
      if (context_.ShouldWarn(common::UsageWarning::CUDAUsage)) {
907
        WarnIfNotInModuleFile(
908
            "'%s' should not have the SAVE attribute or initialization in a device subprogram"_warn_en_US,
909
            symbol.name());
910
      }
911
    }
912
    if (IsPointer(symbol)) {
913
      if (context_.ShouldWarn(common::UsageWarning::CUDAUsage)) {
914
        WarnIfNotInModuleFile(
915
            "Pointer '%s' may not be associated in a device subprogram"_warn_en_US,
916
            symbol.name());
917
      }
918
    }
919
    if (details.isDummy() &&
920
        details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=
921
            common::CUDADataAttr::Device &&
922
        details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=
923
            common::CUDADataAttr::Managed) {
924
      if (context_.ShouldWarn(common::UsageWarning::CUDAUsage)) {
925
        WarnIfNotInModuleFile(
926
            "Dummy argument '%s' may not have ATTRIBUTES(%s) in a device subprogram"_warn_en_US,
927
            symbol.name(),
928
            parser::ToUpperCaseLetters(
929
                common::EnumToString(*details.cudaDataAttr())));
930
      }
931
    }
932
  }
933
  if (details.cudaDataAttr()) {
934
    if (auto dyType{evaluate::DynamicType::From(symbol)}) {
935
      if (dyType->category() != TypeCategory::Derived) {
936
        if (!IsCUDAIntrinsicType(*dyType)) {
937
          messages_.Say(
938
              "'%s' has intrinsic type '%s' that is not available on the device"_err_en_US,
939
              symbol.name(), dyType->AsFortran());
940
        }
941
      }
942
    }
943
    auto attr{*details.cudaDataAttr()};
944
    switch (attr) {
945
    case common::CUDADataAttr::Constant:
946
      if (subpDetails && !inDeviceSubprogram) {
947
        messages_.Say(
948
            "Object '%s' with ATTRIBUTES(CONSTANT) may not be declared in a host subprogram"_err_en_US,
949
            symbol.name());
950
      } else if (IsAllocatableOrPointer(symbol) ||
951
          symbol.attrs().test(Attr::TARGET)) {
952
        messages_.Say(
953
            "Object '%s' with ATTRIBUTES(CONSTANT) may not be allocatable, pointer, or target"_err_en_US,
954
            symbol.name());
955
      } else if (auto shape{evaluate::GetShape(foldingContext_, symbol)};
956
                 !shape ||
957
                 !evaluate::AsConstantExtents(foldingContext_, *shape)) {
958
        messages_.Say(
959
            "Object '%s' with ATTRIBUTES(CONSTANT) must have constant array bounds"_err_en_US,
960
            symbol.name());
961
      }
962
      break;
963
    case common::CUDADataAttr::Device:
964
      if (isComponent && !IsAllocatable(symbol)) {
965
        messages_.Say(
966
            "Component '%s' with ATTRIBUTES(DEVICE) must also be allocatable"_err_en_US,
967
            symbol.name());
968
      }
969
      break;
970
    case common::CUDADataAttr::Managed:
971
      if (!IsAutomatic(symbol) && !IsAllocatable(symbol) &&
972
          !details.isDummy() && !evaluate::IsExplicitShape(symbol)) {
973
        messages_.Say(
974
            "Object '%s' with ATTRIBUTES(MANAGED) must also be allocatable, automatic, explicit shape, or a dummy argument"_err_en_US,
975
            symbol.name());
976
      }
977
      break;
978
    case common::CUDADataAttr::Pinned:
979
      if (inDeviceSubprogram) {
980
        if (context_.ShouldWarn(common::UsageWarning::CUDAUsage)) {
981
          WarnIfNotInModuleFile(
982
              "Object '%s' with ATTRIBUTES(PINNED) may not be declared in a device subprogram"_warn_en_US,
983
              symbol.name());
984
        }
985
      } else if (IsPointer(symbol)) {
986
        if (context_.ShouldWarn(common::UsageWarning::CUDAUsage)) {
987
          WarnIfNotInModuleFile(
988
              "Object '%s' with ATTRIBUTES(PINNED) may not be a pointer"_warn_en_US,
989
              symbol.name());
990
        }
991
      } else if (!IsAllocatable(symbol)) {
992
        if (context_.ShouldWarn(common::UsageWarning::CUDAUsage)) {
993
          WarnIfNotInModuleFile(
994
              "Object '%s' with ATTRIBUTES(PINNED) should also be allocatable"_warn_en_US,
995
              symbol.name());
996
        }
997
      }
998
      break;
999
    case common::CUDADataAttr::Shared:
1000
      if (IsAllocatableOrPointer(symbol) || symbol.attrs().test(Attr::TARGET)) {
1001
        messages_.Say(
1002
            "Object '%s' with ATTRIBUTES(SHARED) may not be allocatable, pointer, or target"_err_en_US,
1003
            symbol.name());
1004
      } else if (!inDeviceSubprogram) {
1005
        messages_.Say(
1006
            "Object '%s' with ATTRIBUTES(SHARED) must be declared in a device subprogram"_err_en_US,
1007
            symbol.name());
1008
      }
1009
      break;
1010
    case common::CUDADataAttr::Unified:
1011
      if (((!subpDetails &&
1012
               symbol.owner().kind() != Scope::Kind::MainProgram) ||
1013
              inDeviceSubprogram) &&
1014
          !isComponent) {
1015
        messages_.Say(
1016
            "Object '%s' with ATTRIBUTES(UNIFIED) must be declared in a host subprogram"_err_en_US,
1017
            symbol.name());
1018
      }
1019
      break;
1020
    case common::CUDADataAttr::Texture:
1021
      messages_.Say(
1022
          "ATTRIBUTES(TEXTURE) is obsolete and no longer supported"_err_en_US);
1023
      break;
1024
    }
1025
    if (attr != common::CUDADataAttr::Pinned) {
1026
      if (details.commonBlock()) {
1027
        messages_.Say(
1028
            "Object '%s' with ATTRIBUTES(%s) may not be in COMMON"_err_en_US,
1029
            symbol.name(),
1030
            parser::ToUpperCaseLetters(common::EnumToString(attr)));
1031
      } else if (FindEquivalenceSet(symbol)) {
1032
        messages_.Say(
1033
            "Object '%s' with ATTRIBUTES(%s) may not be in an equivalence group"_err_en_US,
1034
            symbol.name(),
1035
            parser::ToUpperCaseLetters(common::EnumToString(attr)));
1036
      }
1037
    }
1038
    if (subpDetails /* not a module variable */ && IsSaved(symbol) &&
1039
        !inDeviceSubprogram && !IsAllocatable(symbol) &&
1040
        attr == common::CUDADataAttr::Device) {
1041
      messages_.Say(
1042
          "Saved object '%s' in host code may not have ATTRIBUTES(DEVICE) unless allocatable"_err_en_US,
1043
          symbol.name(),
1044
          parser::ToUpperCaseLetters(common::EnumToString(attr)));
1045
    }
1046
    if (isComponent) {
1047
      if (attr == common::CUDADataAttr::Device) {
1048
        const DeclTypeSpec *type{symbol.GetType()};
1049
        if (const DerivedTypeSpec *
1050
            derived{type ? type->AsDerived() : nullptr}) {
1051
          DirectComponentIterator directs{*derived};
1052
          if (auto iter{std::find_if(directs.begin(), directs.end(),
1053
                  [](const Symbol &) { return false; })}) {
1054
            messages_.Say(
1055
                "Derived type component '%s' may not have ATTRIBUTES(DEVICE) as it has a direct device component '%s'"_err_en_US,
1056
                symbol.name(), iter.BuildResultDesignatorName());
1057
          }
1058
        }
1059
      } else if (attr == common::CUDADataAttr::Constant ||
1060
          attr == common::CUDADataAttr::Shared) {
1061
        messages_.Say(
1062
            "Derived type component '%s' may not have ATTRIBUTES(%s)"_err_en_US,
1063
            symbol.name(),
1064
            parser::ToUpperCaseLetters(common::EnumToString(attr)));
1065
      }
1066
    } else if (!subpDetails && symbol.owner().kind() != Scope::Kind::Module &&
1067
        symbol.owner().kind() != Scope::Kind::MainProgram &&
1068
        symbol.owner().kind() != Scope::Kind::BlockConstruct) {
1069
      messages_.Say(
1070
          "ATTRIBUTES(%s) may apply only to module, host subprogram, block, or device subprogram data"_err_en_US,
1071
          parser::ToUpperCaseLetters(common::EnumToString(attr)));
1072
    }
1073
  }
1074

1075
  if (derived && derived->IsVectorType()) {
1076
    CHECK(type);
1077
    std::string typeName{type->AsFortran()};
1078
    if (IsAssumedShape(symbol)) {
1079
      SayWithDeclaration(symbol,
1080
          "Assumed-shape entity of %s type is not supported"_err_en_US,
1081
          typeName);
1082
    } else if (IsDeferredShape(symbol)) {
1083
      SayWithDeclaration(symbol,
1084
          "Deferred-shape entity of %s type is not supported"_err_en_US,
1085
          typeName);
1086
    } else if (evaluate::IsAssumedRank(symbol)) {
1087
      SayWithDeclaration(symbol,
1088
          "Assumed Rank entity of %s type is not supported"_err_en_US,
1089
          typeName);
1090
    }
1091
  }
1092
}
1093

1094
void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
1095
  if (IsPointer(symbol) && !context_.HasError(symbol) &&
1096
      !scopeIsUninstantiatedPDT_) {
1097
    if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
1098
      if (object->init()) { // C764, C765; C808
1099
        if (auto designator{evaluate::AsGenericExpr(symbol)}) {
1100
          auto restorer{messages_.SetLocation(symbol.name())};
1101
          context_.set_location(symbol.name());
1102
          CheckInitialDataPointerTarget(
1103
              context_, *designator, *object->init(), DEREF(scope_));
1104
        }
1105
      }
1106
    } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
1107
      if (proc->init() && *proc->init()) {
1108
        // C1519 - must be nonelemental external or module procedure,
1109
        // or an unrestricted specific intrinsic function.
1110
        const Symbol &ultimate{(*proc->init())->GetUltimate()};
1111
        bool checkTarget{true};
1112
        if (ultimate.attrs().test(Attr::INTRINSIC)) {
1113
          if (auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
1114
                  ultimate.name().ToString())};
1115
              !intrinsic || intrinsic->isRestrictedSpecific) { // C1030
1116
            context_.Say(
1117
                "Intrinsic procedure '%s' is not an unrestricted specific "
1118
                "intrinsic permitted for use as the initializer for procedure "
1119
                "pointer '%s'"_err_en_US,
1120
                ultimate.name(), symbol.name());
1121
            checkTarget = false;
1122
          }
1123
        } else if ((!ultimate.attrs().test(Attr::EXTERNAL) &&
1124
                       ultimate.owner().kind() != Scope::Kind::Module) ||
1125
            IsDummy(ultimate) || IsPointer(ultimate)) {
1126
          context_.Say("Procedure pointer '%s' initializer '%s' is neither "
1127
                       "an external nor a module procedure"_err_en_US,
1128
              symbol.name(), ultimate.name());
1129
          checkTarget = false;
1130
        } else if (IsElementalProcedure(ultimate)) {
1131
          context_.Say("Procedure pointer '%s' cannot be initialized with the "
1132
                       "elemental procedure '%s'"_err_en_US,
1133
              symbol.name(), ultimate.name());
1134
          checkTarget = false;
1135
        }
1136
        if (checkTarget) {
1137
          SomeExpr lhs{evaluate::ProcedureDesignator{symbol}};
1138
          SomeExpr rhs{evaluate::ProcedureDesignator{**proc->init()}};
1139
          CheckPointerAssignment(context_, lhs, rhs,
1140
              GetProgramUnitOrBlockConstructContaining(symbol),
1141
              /*isBoundsRemapping=*/false, /*isAssumedRank=*/false);
1142
        }
1143
      }
1144
    }
1145
  }
1146
}
1147

1148
// The six different kinds of array-specs:
1149
//   array-spec     -> explicit-shape-list | deferred-shape-list
1150
//                     | assumed-shape-list | implied-shape-list
1151
//                     | assumed-size | assumed-rank
1152
//   explicit-shape -> [ lb : ] ub
1153
//   deferred-shape -> :
1154
//   assumed-shape  -> [ lb ] :
1155
//   implied-shape  -> [ lb : ] *
1156
//   assumed-size   -> [ explicit-shape-list , ] [ lb : ] *
1157
//   assumed-rank   -> ..
1158
// Note:
1159
// - deferred-shape is also an assumed-shape
1160
// - A single "*" or "lb:*" might be assumed-size or implied-shape-list
1161
void CheckHelper::CheckArraySpec(
1162
    const Symbol &symbol, const ArraySpec &arraySpec) {
1163
  if (arraySpec.Rank() == 0) {
1164
    return;
1165
  }
1166
  bool isExplicit{arraySpec.IsExplicitShape()};
1167
  bool canBeDeferred{arraySpec.CanBeDeferredShape()};
1168
  bool canBeImplied{arraySpec.CanBeImpliedShape()};
1169
  bool canBeAssumedShape{arraySpec.CanBeAssumedShape()};
1170
  bool canBeAssumedSize{arraySpec.CanBeAssumedSize()};
1171
  bool isAssumedRank{arraySpec.IsAssumedRank()};
1172
  bool isCUDAShared{
1173
      GetCUDADataAttr(&symbol).value_or(common::CUDADataAttr::Device) ==
1174
      common::CUDADataAttr::Shared};
1175
  bool isCrayPointee{symbol.test(Symbol::Flag::CrayPointee)};
1176
  std::optional<parser::MessageFixedText> msg;
1177
  if (isCrayPointee && !isExplicit && !canBeAssumedSize) {
1178
    msg =
1179
        "Cray pointee '%s' must have explicit shape or assumed size"_err_en_US;
1180
  } else if (IsAllocatableOrPointer(symbol) && !canBeDeferred &&
1181
      !isAssumedRank) {
1182
    if (symbol.owner().IsDerivedType()) { // C745
1183
      if (IsAllocatable(symbol)) {
1184
        msg = "Allocatable array component '%s' must have"
1185
              " deferred shape"_err_en_US;
1186
      } else {
1187
        msg = "Array pointer component '%s' must have deferred shape"_err_en_US;
1188
      }
1189
    } else {
1190
      if (IsAllocatable(symbol)) { // C832
1191
        msg = "Allocatable array '%s' must have deferred shape or"
1192
              " assumed rank"_err_en_US;
1193
      } else {
1194
        msg = "Array pointer '%s' must have deferred shape or"
1195
              " assumed rank"_err_en_US;
1196
      }
1197
    }
1198
  } else if (IsDummy(symbol)) {
1199
    if (canBeImplied && !canBeAssumedSize) { // C836
1200
      msg = "Dummy array argument '%s' may not have implied shape"_err_en_US;
1201
    }
1202
  } else if (canBeAssumedShape && !canBeDeferred) {
1203
    msg = "Assumed-shape array '%s' must be a dummy argument"_err_en_US;
1204
  } else if (isAssumedRank) { // C837
1205
    msg = "Assumed-rank array '%s' must be a dummy argument"_err_en_US;
1206
  } else if (canBeAssumedSize && !canBeImplied && !isCUDAShared &&
1207
      !isCrayPointee) { // C833
1208
    msg = "Assumed-size array '%s' must be a dummy argument"_err_en_US;
1209
  } else if (canBeImplied) {
1210
    if (!IsNamedConstant(symbol) && !isCUDAShared &&
1211
        !isCrayPointee) { // C835, C836
1212
      msg = "Implied-shape array '%s' must be a named constant or a "
1213
            "dummy argument"_err_en_US;
1214
    }
1215
  } else if (IsNamedConstant(symbol)) {
1216
    if (!isExplicit && !canBeImplied) {
1217
      msg = "Named constant '%s' array must have constant or"
1218
            " implied shape"_err_en_US;
1219
    }
1220
  } else if (!isExplicit &&
1221
      !(IsAllocatableOrPointer(symbol) || isCrayPointee)) {
1222
    if (symbol.owner().IsDerivedType()) { // C749
1223
      msg = "Component array '%s' without ALLOCATABLE or POINTER attribute must"
1224
            " have explicit shape"_err_en_US;
1225
    } else { // C816
1226
      msg = "Array '%s' without ALLOCATABLE or POINTER attribute must have"
1227
            " explicit shape"_err_en_US;
1228
    }
1229
  }
1230
  if (msg) {
1231
    context_.Say(std::move(*msg), symbol.name());
1232
  }
1233
}
1234

1235
void CheckHelper::CheckProcEntity(
1236
    const Symbol &symbol, const ProcEntityDetails &details) {
1237
  CheckSymbolType(symbol);
1238
  const Symbol *interface{details.procInterface()};
1239
  if (details.isDummy()) {
1240
    if (!symbol.attrs().test(Attr::POINTER) && // C843
1241
        symbol.attrs().HasAny(
1242
            {Attr::INTENT_IN, Attr::INTENT_OUT, Attr::INTENT_INOUT})) {
1243
      messages_.Say("A dummy procedure without the POINTER attribute"
1244
                    " may not have an INTENT attribute"_err_en_US);
1245
    }
1246
    if (InElemental()) { // C15100
1247
      messages_.Say(
1248
          "An ELEMENTAL subprogram may not have a dummy procedure"_err_en_US);
1249
    }
1250
    if (interface && IsElementalProcedure(*interface)) {
1251
      // There's no explicit constraint or "shall" that we can find in the
1252
      // standard for this check, but it seems to be implied in multiple
1253
      // sites, and ELEMENTAL non-intrinsic actual arguments *are*
1254
      // explicitly forbidden.  But we allow "PROCEDURE(SIN)::dummy"
1255
      // because it is explicitly legal to *pass* the specific intrinsic
1256
      // function SIN as an actual argument.
1257
      if (interface->attrs().test(Attr::INTRINSIC)) {
1258
        if (context_.ShouldWarn(common::UsageWarning::Portability)) {
1259
          messages_.Say(
1260
              "A dummy procedure should not have an ELEMENTAL intrinsic as its interface"_port_en_US);
1261
        }
1262
      } else {
1263
        messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
1264
      }
1265
    }
1266
  } else if (IsPointer(symbol)) {
1267
    CheckPointerInitialization(symbol);
1268
    if (interface) {
1269
      if (interface->attrs().test(Attr::INTRINSIC)) {
1270
        auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
1271
            interface->name().ToString())};
1272
        if (!intrinsic || intrinsic->isRestrictedSpecific) { // C1515
1273
          messages_.Say(
1274
              "Intrinsic procedure '%s' is not an unrestricted specific "
1275
              "intrinsic permitted for use as the definition of the interface "
1276
              "to procedure pointer '%s'"_err_en_US,
1277
              interface->name(), symbol.name());
1278
        } else if (IsElementalProcedure(*interface)) {
1279
          if (context_.ShouldWarn(common::UsageWarning::Portability)) {
1280
            messages_.Say(
1281
                "Procedure pointer '%s' should not have an ELEMENTAL intrinsic as its interface"_port_en_US,
1282
                symbol.name()); // C1517
1283
          }
1284
        }
1285
      } else if (IsElementalProcedure(*interface)) {
1286
        messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US,
1287
            symbol.name()); // C1517
1288
      }
1289
    }
1290
    if (symbol.owner().IsDerivedType()) {
1291
      CheckPassArg(symbol, interface, details);
1292
    }
1293
  } else if (symbol.owner().IsDerivedType()) {
1294
    const auto &name{symbol.name()};
1295
    messages_.Say(name,
1296
        "Procedure component '%s' must have POINTER attribute"_err_en_US, name);
1297
  }
1298
  CheckExternal(symbol);
1299
}
1300

1301
// When a module subprogram has the MODULE prefix the following must match
1302
// with the corresponding separate module procedure interface body:
1303
// - C1549: characteristics and dummy argument names
1304
// - C1550: binding label
1305
// - C1551: NON_RECURSIVE prefix
1306
class SubprogramMatchHelper {
1307
public:
1308
  explicit SubprogramMatchHelper(CheckHelper &checkHelper)
1309
      : checkHelper{checkHelper} {}
1310

1311
  void Check(const Symbol &, const Symbol &);
1312

1313
private:
1314
  SemanticsContext &context() { return checkHelper.context(); }
1315
  void CheckDummyArg(const Symbol &, const Symbol &, const DummyArgument &,
1316
      const DummyArgument &);
1317
  void CheckDummyDataObject(const Symbol &, const Symbol &,
1318
      const DummyDataObject &, const DummyDataObject &);
1319
  void CheckDummyProcedure(const Symbol &, const Symbol &,
1320
      const DummyProcedure &, const DummyProcedure &);
1321
  bool CheckSameIntent(
1322
      const Symbol &, const Symbol &, common::Intent, common::Intent);
1323
  template <typename... A>
1324
  void Say(
1325
      const Symbol &, const Symbol &, parser::MessageFixedText &&, A &&...);
1326
  template <typename ATTRS>
1327
  bool CheckSameAttrs(const Symbol &, const Symbol &, ATTRS, ATTRS);
1328
  bool ShapesAreCompatible(const DummyDataObject &, const DummyDataObject &);
1329
  evaluate::Shape FoldShape(const evaluate::Shape &);
1330
  std::optional<evaluate::Shape> FoldShape(
1331
      const std::optional<evaluate::Shape> &shape) {
1332
    if (shape) {
1333
      return FoldShape(*shape);
1334
    }
1335
    return std::nullopt;
1336
  }
1337
  std::string AsFortran(DummyDataObject::Attr attr) {
1338
    return parser::ToUpperCaseLetters(DummyDataObject::EnumToString(attr));
1339
  }
1340
  std::string AsFortran(DummyProcedure::Attr attr) {
1341
    return parser::ToUpperCaseLetters(DummyProcedure::EnumToString(attr));
1342
  }
1343

1344
  CheckHelper &checkHelper;
1345
};
1346

1347
// 15.6.2.6 para 3 - can the result of an ENTRY differ from its function?
1348
bool CheckHelper::IsResultOkToDiffer(const FunctionResult &result) {
1349
  if (result.attrs.test(FunctionResult::Attr::Allocatable) ||
1350
      result.attrs.test(FunctionResult::Attr::Pointer)) {
1351
    return false;
1352
  }
1353
  const auto *typeAndShape{result.GetTypeAndShape()};
1354
  if (!typeAndShape || typeAndShape->Rank() != 0) {
1355
    return false;
1356
  }
1357
  auto category{typeAndShape->type().category()};
1358
  if (category == TypeCategory::Character ||
1359
      category == TypeCategory::Derived) {
1360
    return false;
1361
  }
1362
  int kind{typeAndShape->type().kind()};
1363
  return kind == context_.GetDefaultKind(category) ||
1364
      (category == TypeCategory::Real &&
1365
          kind == context_.doublePrecisionKind());
1366
}
1367

1368
void CheckHelper::CheckSubprogram(
1369
    const Symbol &symbol, const SubprogramDetails &details) {
1370
  // Evaluate a procedure definition's characteristics to flush out
1371
  // any errors that analysis might expose, in case this subprogram hasn't
1372
  // had any calls in this compilation unit that would have validated them.
1373
  if (!context_.HasError(symbol) && !details.isDummy() &&
1374
      !details.isInterface() && !details.stmtFunction()) {
1375
    if (!Procedure::Characterize(symbol, foldingContext_)) {
1376
      context_.SetError(symbol);
1377
    }
1378
  }
1379
  if (const Symbol *iface{FindSeparateModuleSubprogramInterface(&symbol)}) {
1380
    SubprogramMatchHelper{*this}.Check(symbol, *iface);
1381
  }
1382
  if (const Scope *entryScope{details.entryScope()}) {
1383
    // ENTRY F'2023 15.6.2.6
1384
    std::optional<parser::MessageFixedText> error;
1385
    const Symbol *subprogram{entryScope->symbol()};
1386
    const SubprogramDetails *subprogramDetails{nullptr};
1387
    if (subprogram) {
1388
      subprogramDetails = subprogram->detailsIf<SubprogramDetails>();
1389
    }
1390
    if (!(entryScope->parent().IsGlobal() || entryScope->parent().IsModule() ||
1391
            entryScope->parent().IsSubmodule())) {
1392
      error = "ENTRY may not appear in an internal subprogram"_err_en_US;
1393
    } else if (subprogramDetails && details.isFunction() &&
1394
        subprogramDetails->isFunction() &&
1395
        !context_.HasError(details.result()) &&
1396
        !context_.HasError(subprogramDetails->result())) {
1397
      auto result{FunctionResult::Characterize(
1398
          details.result(), context_.foldingContext())};
1399
      auto subpResult{FunctionResult::Characterize(
1400
          subprogramDetails->result(), context_.foldingContext())};
1401
      if (result && subpResult && *result != *subpResult &&
1402
          (!IsResultOkToDiffer(*result) || !IsResultOkToDiffer(*subpResult))) {
1403
        error =
1404
            "Result of ENTRY is not compatible with result of containing function"_err_en_US;
1405
      }
1406
    }
1407
    if (error) {
1408
      if (auto *msg{messages_.Say(symbol.name(), *error)}) {
1409
        if (subprogram) {
1410
          msg->Attach(subprogram->name(), "Containing subprogram"_en_US);
1411
        }
1412
      }
1413
    }
1414
  }
1415
  if (details.isFunction() &&
1416
      details.result().name() != symbol.name()) { // F'2023 C1569 & C1583
1417
    if (auto iter{symbol.owner().find(details.result().name())};
1418
        iter != symbol.owner().end()) {
1419
      const Symbol &resNameSym{*iter->second};
1420
      if (const auto *resNameSubp{resNameSym.detailsIf<SubprogramDetails>()}) {
1421
        if (const Scope * resNameEntryScope{resNameSubp->entryScope()}) {
1422
          const Scope *myScope{
1423
              details.entryScope() ? details.entryScope() : symbol.scope()};
1424
          if (resNameEntryScope == myScope) {
1425
            if (auto *msg{messages_.Say(symbol.name(),
1426
                    "Explicit RESULT('%s') of function '%s' cannot have the same name as a distinct ENTRY into the same scope"_err_en_US,
1427
                    details.result().name(), symbol.name())}) {
1428
              msg->Attach(
1429
                  resNameSym.name(), "ENTRY with conflicting name"_en_US);
1430
            }
1431
          }
1432
        }
1433
      }
1434
    }
1435
  }
1436
  if (const MaybeExpr & stmtFunction{details.stmtFunction()}) {
1437
    if (auto msg{evaluate::CheckStatementFunction(
1438
            symbol, *stmtFunction, context_.foldingContext())}) {
1439
      SayWithDeclaration(symbol, std::move(*msg));
1440
    } else if (IsPointer(symbol)) {
1441
      SayWithDeclaration(symbol,
1442
          "A statement function must not have the POINTER attribute"_err_en_US);
1443
    } else if (details.result().flags().test(Symbol::Flag::Implicit)) {
1444
      // 15.6.4 p2 weird requirement
1445
      if (const Symbol *
1446
          host{symbol.owner().parent().FindSymbol(symbol.name())}) {
1447
        if (context_.ShouldWarn(
1448
                common::LanguageFeature::StatementFunctionExtensions)) {
1449
          evaluate::AttachDeclaration(
1450
              messages_.Say(symbol.name(),
1451
                  "An implicitly typed statement function should not appear when the same symbol is available in its host scope"_port_en_US),
1452
              *host);
1453
        }
1454
      }
1455
    }
1456
    if (GetProgramUnitOrBlockConstructContaining(symbol).kind() ==
1457
        Scope::Kind::BlockConstruct) { // C1107
1458
      messages_.Say(symbol.name(),
1459
          "A statement function definition may not appear in a BLOCK construct"_err_en_US);
1460
    }
1461
  }
1462
  if (IsElementalProcedure(symbol)) {
1463
    // See comment on the similar check in CheckProcEntity()
1464
    if (details.isDummy()) {
1465
      messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
1466
    } else {
1467
      for (const Symbol *dummy : details.dummyArgs()) {
1468
        if (!dummy) { // C15100
1469
          messages_.Say(
1470
              "An ELEMENTAL subroutine may not have an alternate return dummy argument"_err_en_US);
1471
        }
1472
      }
1473
    }
1474
  }
1475
  if (details.isInterface()) {
1476
    if (!details.isDummy() && details.isFunction() &&
1477
        IsAssumedLengthCharacter(details.result())) { // C721
1478
      messages_.Say(details.result().name(),
1479
          "A function interface may not declare an assumed-length CHARACTER(*) result"_err_en_US);
1480
    }
1481
  }
1482
  CheckExternal(symbol);
1483
  CheckModuleProcedureDef(symbol);
1484
  auto cudaAttrs{details.cudaSubprogramAttrs()};
1485
  if (cudaAttrs &&
1486
      (*cudaAttrs == common::CUDASubprogramAttrs::Global ||
1487
          *cudaAttrs == common::CUDASubprogramAttrs::Grid_Global) &&
1488
      details.isFunction()) {
1489
    messages_.Say(symbol.name(),
1490
        "A function may not have ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)"_err_en_US);
1491
  }
1492
  if (cudaAttrs &&
1493
      (*cudaAttrs == common::CUDASubprogramAttrs::Global ||
1494
          *cudaAttrs == common::CUDASubprogramAttrs::Grid_Global) &&
1495
      symbol.attrs().HasAny({Attr::RECURSIVE, Attr::PURE, Attr::ELEMENTAL})) {
1496
    messages_.Say(symbol.name(),
1497
        "A kernel subprogram may not be RECURSIVE, PURE, or ELEMENTAL"_err_en_US);
1498
  }
1499
  if (cudaAttrs && *cudaAttrs != common::CUDASubprogramAttrs::Host) {
1500
    // CUDA device subprogram checks
1501
    if (ClassifyProcedure(symbol) == ProcedureDefinitionClass::Internal) {
1502
      messages_.Say(symbol.name(),
1503
          "A device subprogram may not be an internal subprogram"_err_en_US);
1504
    }
1505
  }
1506
  if ((!details.cudaLaunchBounds().empty() ||
1507
          !details.cudaClusterDims().empty()) &&
1508
      !(cudaAttrs &&
1509
          (*cudaAttrs == common::CUDASubprogramAttrs::Global ||
1510
              *cudaAttrs == common::CUDASubprogramAttrs::Grid_Global))) {
1511
    messages_.Say(symbol.name(),
1512
        "A subroutine may not have LAUNCH_BOUNDS() or CLUSTER_DIMS() unless it has ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)"_err_en_US);
1513
  }
1514
  if (!IsStmtFunction(symbol)) {
1515
    if (const Scope * outerDevice{FindCUDADeviceContext(&symbol.owner())};
1516
        outerDevice && outerDevice->symbol()) {
1517
      if (auto *msg{messages_.Say(symbol.name(),
1518
              "'%s' may not be an internal procedure of CUDA device subprogram '%s'"_err_en_US,
1519
              symbol.name(), outerDevice->symbol()->name())}) {
1520
        msg->Attach(outerDevice->symbol()->name(),
1521
            "Containing CUDA device subprogram"_en_US);
1522
      }
1523
    }
1524
  }
1525
}
1526

1527
void CheckHelper::CheckExternal(const Symbol &symbol) {
1528
  if (IsExternal(symbol)) {
1529
    std::string interfaceName{symbol.name().ToString()};
1530
    if (const auto *bind{symbol.GetBindName()}) {
1531
      interfaceName = *bind;
1532
    }
1533
    if (const Symbol * global{FindGlobal(symbol)};
1534
        global && global != &symbol) {
1535
      std::string definitionName{global->name().ToString()};
1536
      if (const auto *bind{global->GetBindName()}) {
1537
        definitionName = *bind;
1538
      }
1539
      if (interfaceName == definitionName) {
1540
        parser::Message *msg{nullptr};
1541
        if (!IsProcedure(*global)) {
1542
          if ((symbol.flags().test(Symbol::Flag::Function) ||
1543
                  symbol.flags().test(Symbol::Flag::Subroutine)) &&
1544
              context_.ShouldWarn(common::UsageWarning::ExternalNameConflict)) {
1545
            msg = WarnIfNotInModuleFile(
1546
                "The global entity '%s' corresponding to the local procedure '%s' is not a callable subprogram"_warn_en_US,
1547
                global->name(), symbol.name());
1548
          }
1549
        } else if (auto chars{Characterize(symbol)}) {
1550
          if (auto globalChars{Characterize(*global)}) {
1551
            if (chars->HasExplicitInterface()) {
1552
              std::string whyNot;
1553
              if (!chars->IsCompatibleWith(*globalChars,
1554
                      /*ignoreImplicitVsExplicit=*/false, &whyNot) &&
1555
                  context_.ShouldWarn(
1556
                      common::UsageWarning::ExternalInterfaceMismatch)) {
1557
                msg = WarnIfNotInModuleFile(
1558
                    "The global subprogram '%s' is not compatible with its local procedure declaration (%s)"_warn_en_US,
1559
                    global->name(), whyNot);
1560
              }
1561
            } else if (!globalChars->CanBeCalledViaImplicitInterface() &&
1562
                context_.ShouldWarn(
1563
                    common::UsageWarning::ExternalInterfaceMismatch)) {
1564
              msg = messages_.Say(
1565
                  "The global subprogram '%s' may not be referenced via the implicit interface '%s'"_err_en_US,
1566
                  global->name(), symbol.name());
1567
            }
1568
          }
1569
        }
1570
        if (msg) {
1571
          if (msg->IsFatal()) {
1572
            context_.SetError(symbol);
1573
          }
1574
          evaluate::AttachDeclaration(msg, *global);
1575
          evaluate::AttachDeclaration(msg, symbol);
1576
        }
1577
      }
1578
    } else if (auto iter{externalNames_.find(interfaceName)};
1579
               iter != externalNames_.end()) {
1580
      const Symbol &previous{*iter->second};
1581
      if (auto chars{Characterize(symbol)}) {
1582
        if (auto previousChars{Characterize(previous)}) {
1583
          std::string whyNot;
1584
          if (!chars->IsCompatibleWith(*previousChars,
1585
                  /*ignoreImplicitVsExplicit=*/false, &whyNot) &&
1586
              context_.ShouldWarn(
1587
                  common::UsageWarning::ExternalInterfaceMismatch)) {
1588
            if (auto *msg{WarnIfNotInModuleFile(
1589
                    "The external interface '%s' is not compatible with an earlier definition (%s)"_warn_en_US,
1590
                    symbol.name(), whyNot)}) {
1591
              evaluate::AttachDeclaration(msg, previous);
1592
              evaluate::AttachDeclaration(msg, symbol);
1593
            }
1594
          }
1595
        }
1596
      }
1597
    } else {
1598
      externalNames_.emplace(interfaceName, symbol);
1599
    }
1600
  }
1601
}
1602

1603
void CheckHelper::CheckDerivedType(
1604
    const Symbol &derivedType, const DerivedTypeDetails &details) {
1605
  if (details.isForwardReferenced() && !context_.HasError(derivedType)) {
1606
    messages_.Say("The derived type '%s' has not been defined"_err_en_US,
1607
        derivedType.name());
1608
  }
1609
  const Scope *scope{derivedType.scope()};
1610
  if (!scope) {
1611
    CHECK(details.isForwardReferenced());
1612
    return;
1613
  }
1614
  CHECK(scope->symbol() == &derivedType);
1615
  CHECK(scope->IsDerivedType());
1616
  if (derivedType.attrs().test(Attr::ABSTRACT) && // C734
1617
      (derivedType.attrs().test(Attr::BIND_C) || details.sequence())) {
1618
    messages_.Say("An ABSTRACT derived type must be extensible"_err_en_US);
1619
  }
1620
  if (const DeclTypeSpec *parent{FindParentTypeSpec(derivedType)}) {
1621
    const DerivedTypeSpec *parentDerived{parent->AsDerived()};
1622
    if (!IsExtensibleType(parentDerived)) { // C705
1623
      messages_.Say("The parent type is not extensible"_err_en_US);
1624
    }
1625
    if (!derivedType.attrs().test(Attr::ABSTRACT) && parentDerived &&
1626
        parentDerived->typeSymbol().attrs().test(Attr::ABSTRACT)) {
1627
      ScopeComponentIterator components{*parentDerived};
1628
      for (const Symbol &component : components) {
1629
        if (component.attrs().test(Attr::DEFERRED)) {
1630
          if (scope->FindComponent(component.name()) == &component) {
1631
            SayWithDeclaration(component,
1632
                "Non-ABSTRACT extension of ABSTRACT derived type '%s' lacks a binding for DEFERRED procedure '%s'"_err_en_US,
1633
                parentDerived->typeSymbol().name(), component.name());
1634
          }
1635
        }
1636
      }
1637
    }
1638
    DerivedTypeSpec derived{derivedType.name(), derivedType};
1639
    derived.set_scope(*scope);
1640
    if (FindCoarrayUltimateComponent(derived) && // C736
1641
        !(parentDerived && FindCoarrayUltimateComponent(*parentDerived))) {
1642
      messages_.Say(
1643
          "Type '%s' has a coarray ultimate component so the type at the base "
1644
          "of its type extension chain ('%s') must be a type that has a "
1645
          "coarray ultimate component"_err_en_US,
1646
          derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name());
1647
    }
1648
    if (FindEventOrLockPotentialComponent(derived) && // C737
1649
        !(FindEventOrLockPotentialComponent(*parentDerived) ||
1650
            IsEventTypeOrLockType(parentDerived))) {
1651
      messages_.Say(
1652
          "Type '%s' has an EVENT_TYPE or LOCK_TYPE component, so the type "
1653
          "at the base of its type extension chain ('%s') must either have an "
1654
          "EVENT_TYPE or LOCK_TYPE component, or be EVENT_TYPE or "
1655
          "LOCK_TYPE"_err_en_US,
1656
          derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name());
1657
    }
1658
  }
1659
  if (HasIntrinsicTypeName(derivedType)) { // C729
1660
    messages_.Say("A derived type name cannot be the name of an intrinsic"
1661
                  " type"_err_en_US);
1662
  }
1663
  std::map<SourceName, SymbolRef> previous;
1664
  for (const auto &pair : details.finals()) {
1665
    SourceName source{pair.first};
1666
    const Symbol &ref{*pair.second};
1667
    if (CheckFinal(ref, source, derivedType) &&
1668
        std::all_of(previous.begin(), previous.end(),
1669
            [&](std::pair<SourceName, SymbolRef> prev) {
1670
              return CheckDistinguishableFinals(
1671
                  ref, source, *prev.second, prev.first, derivedType);
1672
            })) {
1673
      previous.emplace(source, ref);
1674
    }
1675
  }
1676
}
1677

1678
// C786
1679
bool CheckHelper::CheckFinal(
1680
    const Symbol &subroutine, SourceName finalName, const Symbol &derivedType) {
1681
  if (!IsModuleProcedure(subroutine)) {
1682
    SayWithDeclaration(subroutine, finalName,
1683
        "FINAL subroutine '%s' of derived type '%s' must be a module procedure"_err_en_US,
1684
        subroutine.name(), derivedType.name());
1685
    return false;
1686
  }
1687
  const Procedure *proc{Characterize(subroutine)};
1688
  if (!proc) {
1689
    return false; // error recovery
1690
  }
1691
  if (!proc->IsSubroutine()) {
1692
    SayWithDeclaration(subroutine, finalName,
1693
        "FINAL subroutine '%s' of derived type '%s' must be a subroutine"_err_en_US,
1694
        subroutine.name(), derivedType.name());
1695
    return false;
1696
  }
1697
  if (proc->dummyArguments.size() != 1) {
1698
    SayWithDeclaration(subroutine, finalName,
1699
        "FINAL subroutine '%s' of derived type '%s' must have a single dummy argument"_err_en_US,
1700
        subroutine.name(), derivedType.name());
1701
    return false;
1702
  }
1703
  const auto &arg{proc->dummyArguments[0]};
1704
  const Symbol *errSym{&subroutine};
1705
  if (const auto *details{subroutine.detailsIf<SubprogramDetails>()}) {
1706
    if (!details->dummyArgs().empty()) {
1707
      if (const Symbol *argSym{details->dummyArgs()[0]}) {
1708
        errSym = argSym;
1709
      }
1710
    }
1711
  }
1712
  const auto *ddo{std::get_if<DummyDataObject>(&arg.u)};
1713
  if (!ddo) {
1714
    SayWithDeclaration(subroutine, finalName,
1715
        "FINAL subroutine '%s' of derived type '%s' must have a single dummy argument that is a data object"_err_en_US,
1716
        subroutine.name(), derivedType.name());
1717
    return false;
1718
  }
1719
  bool ok{true};
1720
  if (arg.IsOptional()) {
1721
    SayWithDeclaration(*errSym, finalName,
1722
        "FINAL subroutine '%s' of derived type '%s' must not have an OPTIONAL dummy argument"_err_en_US,
1723
        subroutine.name(), derivedType.name());
1724
    ok = false;
1725
  }
1726
  if (ddo->attrs.test(DummyDataObject::Attr::Allocatable)) {
1727
    SayWithDeclaration(*errSym, finalName,
1728
        "FINAL subroutine '%s' of derived type '%s' must not have an ALLOCATABLE dummy argument"_err_en_US,
1729
        subroutine.name(), derivedType.name());
1730
    ok = false;
1731
  }
1732
  if (ddo->attrs.test(DummyDataObject::Attr::Pointer)) {
1733
    SayWithDeclaration(*errSym, finalName,
1734
        "FINAL subroutine '%s' of derived type '%s' must not have a POINTER dummy argument"_err_en_US,
1735
        subroutine.name(), derivedType.name());
1736
    ok = false;
1737
  }
1738
  if (ddo->intent == common::Intent::Out) {
1739
    SayWithDeclaration(*errSym, finalName,
1740
        "FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with INTENT(OUT)"_err_en_US,
1741
        subroutine.name(), derivedType.name());
1742
    ok = false;
1743
  }
1744
  if (ddo->attrs.test(DummyDataObject::Attr::Value)) {
1745
    SayWithDeclaration(*errSym, finalName,
1746
        "FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with the VALUE attribute"_err_en_US,
1747
        subroutine.name(), derivedType.name());
1748
    ok = false;
1749
  }
1750
  if (ddo->type.corank() > 0) {
1751
    SayWithDeclaration(*errSym, finalName,
1752
        "FINAL subroutine '%s' of derived type '%s' must not have a coarray dummy argument"_err_en_US,
1753
        subroutine.name(), derivedType.name());
1754
    ok = false;
1755
  }
1756
  if (ddo->type.type().IsPolymorphic()) {
1757
    SayWithDeclaration(*errSym, finalName,
1758
        "FINAL subroutine '%s' of derived type '%s' must not have a polymorphic dummy argument"_err_en_US,
1759
        subroutine.name(), derivedType.name());
1760
    ok = false;
1761
  } else if (ddo->type.type().category() != TypeCategory::Derived ||
1762
      &ddo->type.type().GetDerivedTypeSpec().typeSymbol() != &derivedType) {
1763
    SayWithDeclaration(*errSym, finalName,
1764
        "FINAL subroutine '%s' of derived type '%s' must have a TYPE(%s) dummy argument"_err_en_US,
1765
        subroutine.name(), derivedType.name(), derivedType.name());
1766
    ok = false;
1767
  } else { // check that all LEN type parameters are assumed
1768
    for (auto ref : OrderParameterDeclarations(derivedType)) {
1769
      if (IsLenTypeParameter(*ref)) {
1770
        const auto *value{
1771
            ddo->type.type().GetDerivedTypeSpec().FindParameter(ref->name())};
1772
        if (!value || !value->isAssumed()) {
1773
          SayWithDeclaration(*errSym, finalName,
1774
              "FINAL subroutine '%s' of derived type '%s' must have a dummy argument with an assumed LEN type parameter '%s=*'"_err_en_US,
1775
              subroutine.name(), derivedType.name(), ref->name());
1776
          ok = false;
1777
        }
1778
      }
1779
    }
1780
  }
1781
  return ok;
1782
}
1783

1784
bool CheckHelper::CheckDistinguishableFinals(const Symbol &f1,
1785
    SourceName f1Name, const Symbol &f2, SourceName f2Name,
1786
    const Symbol &derivedType) {
1787
  const Procedure *p1{Characterize(f1)};
1788
  const Procedure *p2{Characterize(f2)};
1789
  if (p1 && p2) {
1790
    std::optional<bool> areDistinct{characteristics::Distinguishable(
1791
        context_.languageFeatures(), *p1, *p2)};
1792
    if (areDistinct.value_or(false)) {
1793
      return true;
1794
    }
1795
    if (auto *msg{messages_.Say(f1Name,
1796
            "FINAL subroutines '%s' and '%s' of derived type '%s' cannot be distinguished by rank or KIND type parameter value"_err_en_US,
1797
            f1Name, f2Name, derivedType.name())}) {
1798
      msg->Attach(f2Name, "FINAL declaration of '%s'"_en_US, f2.name())
1799
          .Attach(f1.name(), "Definition of '%s'"_en_US, f1Name)
1800
          .Attach(f2.name(), "Definition of '%s'"_en_US, f2Name);
1801
    }
1802
  }
1803
  return false;
1804
}
1805

1806
void CheckHelper::CheckHostAssoc(
1807
    const Symbol &symbol, const HostAssocDetails &details) {
1808
  const Symbol &hostSymbol{details.symbol()};
1809
  if (hostSymbol.test(Symbol::Flag::ImplicitOrError)) {
1810
    if (details.implicitOrSpecExprError) {
1811
      messages_.Say("Implicitly typed local entity '%s' not allowed in"
1812
                    " specification expression"_err_en_US,
1813
          symbol.name());
1814
    } else if (details.implicitOrExplicitTypeError) {
1815
      messages_.Say(
1816
          "No explicit type declared for '%s'"_err_en_US, symbol.name());
1817
    }
1818
  }
1819
}
1820

1821
void CheckHelper::CheckGeneric(
1822
    const Symbol &symbol, const GenericDetails &details) {
1823
  CheckSpecifics(symbol, details);
1824
  common::visit(common::visitors{
1825
                    [&](const common::DefinedIo &io) {
1826
                      CheckDefinedIoProc(symbol, details, io);
1827
                    },
1828
                    [&](const GenericKind::OtherKind &other) {
1829
                      if (other == GenericKind::OtherKind::Name) {
1830
                        CheckGenericVsIntrinsic(symbol, details);
1831
                      }
1832
                    },
1833
                    [](const auto &) {},
1834
                },
1835
      details.kind().u);
1836
  // Ensure that shadowed symbols are checked
1837
  if (details.specific()) {
1838
    Check(*details.specific());
1839
  }
1840
  if (details.derivedType()) {
1841
    Check(*details.derivedType());
1842
  }
1843
}
1844

1845
// Check that the specifics of this generic are distinguishable from each other
1846
void CheckHelper::CheckSpecifics(
1847
    const Symbol &generic, const GenericDetails &details) {
1848
  GenericKind kind{details.kind()};
1849
  DistinguishabilityHelper helper{context_};
1850
  for (const Symbol &specific : details.specificProcs()) {
1851
    if (specific.attrs().test(Attr::ABSTRACT)) {
1852
      if (auto *msg{messages_.Say(generic.name(),
1853
              "Generic interface '%s' must not use abstract interface '%s' as a specific procedure"_err_en_US,
1854
              generic.name(), specific.name())}) {
1855
        msg->Attach(
1856
            specific.name(), "Definition of '%s'"_en_US, specific.name());
1857
      }
1858
      continue;
1859
    }
1860
    if (specific.attrs().test(Attr::INTRINSIC)) {
1861
      // GNU Fortran allows INTRINSIC procedures in generics.
1862
      auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
1863
          specific.name().ToString())};
1864
      if (intrinsic && !intrinsic->isRestrictedSpecific) {
1865
        if (context_.ShouldWarn(common::LanguageFeature::IntrinsicAsSpecific)) {
1866
          if (auto *msg{messages_.Say(specific.name(),
1867
                  "Specific procedure '%s' of generic interface '%s' should not be INTRINSIC"_port_en_US,
1868
                  specific.name(), generic.name())}) {
1869
            msg->Attach(
1870
                generic.name(), "Definition of '%s'"_en_US, generic.name());
1871
          }
1872
        }
1873
      } else {
1874
        if (context_.ShouldWarn(common::LanguageFeature::IntrinsicAsSpecific)) {
1875
          if (auto *msg{messages_.Say(specific.name(),
1876
                  "Procedure '%s' of generic interface '%s' is INTRINSIC but not an unrestricted specific intrinsic function"_port_en_US,
1877
                  specific.name(), generic.name())}) {
1878
            msg->Attach(
1879
                generic.name(), "Definition of '%s'"_en_US, generic.name());
1880
          }
1881
        }
1882
        continue;
1883
      }
1884
    }
1885
    if (IsStmtFunction(specific)) {
1886
      if (auto *msg{messages_.Say(specific.name(),
1887
              "Specific procedure '%s' of generic interface '%s' may not be a statement function"_err_en_US,
1888
              specific.name(), generic.name())}) {
1889
        msg->Attach(generic.name(), "Definition of '%s'"_en_US, generic.name());
1890
      }
1891
      continue;
1892
    }
1893
    if (const Procedure *procedure{Characterize(specific)}) {
1894
      if (procedure->HasExplicitInterface()) {
1895
        helper.Add(generic, kind, specific, *procedure);
1896
      } else {
1897
        if (auto *msg{messages_.Say(specific.name(),
1898
                "Specific procedure '%s' of generic interface '%s' must have an explicit interface"_err_en_US,
1899
                specific.name(), generic.name())}) {
1900
          msg->Attach(
1901
              generic.name(), "Definition of '%s'"_en_US, generic.name());
1902
        }
1903
      }
1904
    }
1905
  }
1906
  helper.Check(generic.owner());
1907
}
1908

1909
static bool CUDAHostDeviceDiffer(
1910
    const Procedure &proc, const DummyDataObject &arg) {
1911
  auto procCUDA{
1912
      proc.cudaSubprogramAttrs.value_or(common::CUDASubprogramAttrs::Host)};
1913
  bool procIsHostOnly{procCUDA == common::CUDASubprogramAttrs::Host};
1914
  bool procIsDeviceOnly{
1915
      !procIsHostOnly && procCUDA != common::CUDASubprogramAttrs::HostDevice};
1916
  const auto &argCUDA{arg.cudaDataAttr};
1917
  bool argIsHostOnly{!argCUDA || *argCUDA == common::CUDADataAttr::Pinned};
1918
  bool argIsDeviceOnly{(!argCUDA && procIsDeviceOnly) ||
1919
      (argCUDA &&
1920
          (*argCUDA != common::CUDADataAttr::Managed &&
1921
              *argCUDA != common::CUDADataAttr::Pinned &&
1922
              *argCUDA != common::CUDADataAttr::Unified))};
1923
  return (procIsHostOnly && argIsDeviceOnly) ||
1924
      (procIsDeviceOnly && argIsHostOnly);
1925
}
1926

1927
static bool ConflictsWithIntrinsicAssignment(const Procedure &proc) {
1928
  const auto &lhsData{std::get<DummyDataObject>(proc.dummyArguments[0].u)};
1929
  const auto &lhsTnS{lhsData.type};
1930
  const auto &rhsData{std::get<DummyDataObject>(proc.dummyArguments[1].u)};
1931
  const auto &rhsTnS{rhsData.type};
1932
  return !CUDAHostDeviceDiffer(proc, lhsData) &&
1933
      !CUDAHostDeviceDiffer(proc, rhsData) &&
1934
      Tristate::No ==
1935
      IsDefinedAssignment(
1936
          lhsTnS.type(), lhsTnS.Rank(), rhsTnS.type(), rhsTnS.Rank());
1937
}
1938

1939
static bool ConflictsWithIntrinsicOperator(
1940
    const GenericKind &kind, const Procedure &proc) {
1941
  if (!kind.IsIntrinsicOperator()) {
1942
    return false;
1943
  }
1944
  const auto &arg0Data{std::get<DummyDataObject>(proc.dummyArguments[0].u)};
1945
  if (CUDAHostDeviceDiffer(proc, arg0Data)) {
1946
    return false;
1947
  }
1948
  const auto &arg0TnS{arg0Data.type};
1949
  auto type0{arg0TnS.type()};
1950
  if (proc.dummyArguments.size() == 1) { // unary
1951
    return common::visit(
1952
        common::visitors{
1953
            [&](common::NumericOperator) { return IsIntrinsicNumeric(type0); },
1954
            [&](common::LogicalOperator) { return IsIntrinsicLogical(type0); },
1955
            [](const auto &) -> bool { DIE("bad generic kind"); },
1956
        },
1957
        kind.u);
1958
  } else { // binary
1959
    int rank0{arg0TnS.Rank()};
1960
    const auto &arg1Data{std::get<DummyDataObject>(proc.dummyArguments[1].u)};
1961
    if (CUDAHostDeviceDiffer(proc, arg1Data)) {
1962
      return false;
1963
    }
1964
    const auto &arg1TnS{arg1Data.type};
1965
    auto type1{arg1TnS.type()};
1966
    int rank1{arg1TnS.Rank()};
1967
    return common::visit(
1968
        common::visitors{
1969
            [&](common::NumericOperator) {
1970
              return IsIntrinsicNumeric(type0, rank0, type1, rank1);
1971
            },
1972
            [&](common::LogicalOperator) {
1973
              return IsIntrinsicLogical(type0, rank0, type1, rank1);
1974
            },
1975
            [&](common::RelationalOperator opr) {
1976
              return IsIntrinsicRelational(opr, type0, rank0, type1, rank1);
1977
            },
1978
            [&](GenericKind::OtherKind x) {
1979
              CHECK(x == GenericKind::OtherKind::Concat);
1980
              return IsIntrinsicConcat(type0, rank0, type1, rank1);
1981
            },
1982
            [](const auto &) -> bool { DIE("bad generic kind"); },
1983
        },
1984
        kind.u);
1985
  }
1986
}
1987

1988
// Check if this procedure can be used for defined operators (see 15.4.3.4.2).
1989
bool CheckHelper::CheckDefinedOperator(SourceName opName, GenericKind kind,
1990
    const Symbol &specific, const Procedure &proc) {
1991
  if (context_.HasError(specific)) {
1992
    return false;
1993
  }
1994
  std::optional<parser::MessageFixedText> msg;
1995
  auto checkDefinedOperatorArgs{
1996
      [&](SourceName opName, const Symbol &specific, const Procedure &proc) {
1997
        bool arg0Defined{CheckDefinedOperatorArg(opName, specific, proc, 0)};
1998
        bool arg1Defined{CheckDefinedOperatorArg(opName, specific, proc, 1)};
1999
        return arg0Defined && arg1Defined;
2000
      }};
2001
  if (specific.attrs().test(Attr::NOPASS)) { // C774
2002
    msg = "%s procedure '%s' may not have NOPASS attribute"_err_en_US;
2003
  } else if (!proc.functionResult.has_value()) {
2004
    msg = "%s procedure '%s' must be a function"_err_en_US;
2005
  } else if (proc.functionResult->IsAssumedLengthCharacter()) {
2006
    const auto *subpDetails{specific.detailsIf<SubprogramDetails>()};
2007
    if (subpDetails && !subpDetails->isDummy() && subpDetails->isInterface()) {
2008
      // Error is caught by more general test for interfaces with
2009
      // assumed-length character function results
2010
      return true;
2011
    }
2012
    msg = "%s function '%s' may not have assumed-length CHARACTER(*)"
2013
          " result"_err_en_US;
2014
  } else if (auto m{CheckNumberOfArgs(kind, proc.dummyArguments.size())}) {
2015
    msg = std::move(m);
2016
  } else if (!checkDefinedOperatorArgs(opName, specific, proc)) {
2017
    return false; // error was reported
2018
  } else if (ConflictsWithIntrinsicOperator(kind, proc)) {
2019
    msg = "%s function '%s' conflicts with intrinsic operator"_err_en_US;
2020
  } else {
2021
    return true; // OK
2022
  }
2023
  bool isFatal{msg->IsFatal()};
2024
  if (isFatal || !FindModuleFileContaining(specific.owner())) {
2025
    SayWithDeclaration(
2026
        specific, std::move(*msg), MakeOpName(opName), specific.name());
2027
  }
2028
  if (isFatal) {
2029
    context_.SetError(specific);
2030
  }
2031
  return !isFatal;
2032
}
2033

2034
// If the number of arguments is wrong for this intrinsic operator, return
2035
// false and return the error message in msg.
2036
std::optional<parser::MessageFixedText> CheckHelper::CheckNumberOfArgs(
2037
    const GenericKind &kind, std::size_t nargs) {
2038
  if (!kind.IsIntrinsicOperator()) {
2039
    if (nargs < 1 || nargs > 2) {
2040
      if (context_.ShouldWarn(common::UsageWarning::DefinedOperatorArgs)) {
2041
        return "%s function '%s' should have 1 or 2 dummy arguments"_warn_en_US;
2042
      }
2043
    }
2044
    return std::nullopt;
2045
  }
2046
  std::size_t min{2}, max{2}; // allowed number of args; default is binary
2047
  common::visit(common::visitors{
2048
                    [&](const common::NumericOperator &x) {
2049
                      if (x == common::NumericOperator::Add ||
2050
                          x == common::NumericOperator::Subtract) {
2051
                        min = 1; // + and - are unary or binary
2052
                      }
2053
                    },
2054
                    [&](const common::LogicalOperator &x) {
2055
                      if (x == common::LogicalOperator::Not) {
2056
                        min = 1; // .NOT. is unary
2057
                        max = 1;
2058
                      }
2059
                    },
2060
                    [](const common::RelationalOperator &) {
2061
                      // all are binary
2062
                    },
2063
                    [](const GenericKind::OtherKind &x) {
2064
                      CHECK(x == GenericKind::OtherKind::Concat);
2065
                    },
2066
                    [](const auto &) { DIE("expected intrinsic operator"); },
2067
                },
2068
      kind.u);
2069
  if (nargs >= min && nargs <= max) {
2070
    return std::nullopt;
2071
  } else if (max == 1) {
2072
    return "%s function '%s' must have one dummy argument"_err_en_US;
2073
  } else if (min == 2) {
2074
    return "%s function '%s' must have two dummy arguments"_err_en_US;
2075
  } else {
2076
    return "%s function '%s' must have one or two dummy arguments"_err_en_US;
2077
  }
2078
}
2079

2080
bool CheckHelper::CheckDefinedOperatorArg(const SourceName &opName,
2081
    const Symbol &symbol, const Procedure &proc, std::size_t pos) {
2082
  if (pos >= proc.dummyArguments.size()) {
2083
    return true;
2084
  }
2085
  auto &arg{proc.dummyArguments.at(pos)};
2086
  std::optional<parser::MessageFixedText> msg;
2087
  if (arg.IsOptional()) {
2088
    msg = "In %s function '%s', dummy argument '%s' may not be"
2089
          " OPTIONAL"_err_en_US;
2090
  } else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)};
2091
             dataObject == nullptr) {
2092
    msg = "In %s function '%s', dummy argument '%s' must be a"
2093
          " data object"_err_en_US;
2094
  } else if (dataObject->intent == common::Intent::Out) {
2095
    msg =
2096
        "In %s function '%s', dummy argument '%s' may not be INTENT(OUT)"_err_en_US;
2097
  } else if (dataObject->intent != common::Intent::In &&
2098
      !dataObject->attrs.test(DummyDataObject::Attr::Value)) {
2099
    if (context_.ShouldWarn(common::UsageWarning::DefinedOperatorArgs)) {
2100
      msg =
2101
          "In %s function '%s', dummy argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US;
2102
    }
2103
  }
2104
  if (msg) {
2105
    bool isFatal{msg->IsFatal()};
2106
    if (isFatal || !FindModuleFileContaining(symbol.owner())) {
2107
      SayWithDeclaration(symbol, std::move(*msg),
2108
          parser::ToUpperCaseLetters(opName.ToString()), symbol.name(),
2109
          arg.name);
2110
    }
2111
    if (isFatal) {
2112
      return false;
2113
    }
2114
  }
2115
  return true;
2116
}
2117

2118
// Check if this procedure can be used for defined assignment (see 15.4.3.4.3).
2119
bool CheckHelper::CheckDefinedAssignment(
2120
    const Symbol &specific, const Procedure &proc) {
2121
  if (context_.HasError(specific)) {
2122
    return false;
2123
  }
2124
  std::optional<parser::MessageFixedText> msg;
2125
  if (specific.attrs().test(Attr::NOPASS)) { // C774
2126
    msg = "Defined assignment procedure '%s' may not have"
2127
          " NOPASS attribute"_err_en_US;
2128
  } else if (!proc.IsSubroutine()) {
2129
    msg = "Defined assignment procedure '%s' must be a subroutine"_err_en_US;
2130
  } else if (proc.dummyArguments.size() != 2) {
2131
    msg = "Defined assignment subroutine '%s' must have"
2132
          " two dummy arguments"_err_en_US;
2133
  } else {
2134
    // Check both arguments even if the first has an error.
2135
    bool ok0{CheckDefinedAssignmentArg(specific, proc.dummyArguments[0], 0)};
2136
    bool ok1{CheckDefinedAssignmentArg(specific, proc.dummyArguments[1], 1)};
2137
    if (!(ok0 && ok1)) {
2138
      return false; // error was reported
2139
    } else if (ConflictsWithIntrinsicAssignment(proc)) {
2140
      msg =
2141
          "Defined assignment subroutine '%s' conflicts with intrinsic assignment"_err_en_US;
2142
    } else {
2143
      return true; // OK
2144
    }
2145
  }
2146
  SayWithDeclaration(specific, std::move(msg.value()), specific.name());
2147
  context_.SetError(specific);
2148
  return false;
2149
}
2150

2151
bool CheckHelper::CheckDefinedAssignmentArg(
2152
    const Symbol &symbol, const DummyArgument &arg, int pos) {
2153
  std::optional<parser::MessageFixedText> msg;
2154
  if (arg.IsOptional()) {
2155
    msg = "In defined assignment subroutine '%s', dummy argument '%s'"
2156
          " may not be OPTIONAL"_err_en_US;
2157
  } else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)}) {
2158
    if (pos == 0) {
2159
      if (dataObject->intent == common::Intent::In) {
2160
        msg = "In defined assignment subroutine '%s', first dummy argument '%s'"
2161
              " may not have INTENT(IN)"_err_en_US;
2162
      } else if (dataObject->intent != common::Intent::Out &&
2163
          dataObject->intent != common::Intent::InOut) {
2164
        if (context_.ShouldWarn(common::UsageWarning::DefinedOperatorArgs)) {
2165
          msg =
2166
              "In defined assignment subroutine '%s', first dummy argument '%s' should have INTENT(OUT) or INTENT(INOUT)"_warn_en_US;
2167
        }
2168
      }
2169
    } else if (pos == 1) {
2170
      if (dataObject->intent == common::Intent::Out) {
2171
        msg = "In defined assignment subroutine '%s', second dummy"
2172
              " argument '%s' may not have INTENT(OUT)"_err_en_US;
2173
      } else if (dataObject->intent != common::Intent::In &&
2174
          !dataObject->attrs.test(DummyDataObject::Attr::Value)) {
2175
        if (context_.ShouldWarn(common::UsageWarning::DefinedOperatorArgs)) {
2176
          msg =
2177
              "In defined assignment subroutine '%s', second dummy argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US;
2178
        }
2179
      } else if (dataObject->attrs.test(DummyDataObject::Attr::Pointer)) {
2180
        msg =
2181
            "In defined assignment subroutine '%s', second dummy argument '%s' must not be a pointer"_err_en_US;
2182
      } else if (dataObject->attrs.test(DummyDataObject::Attr::Allocatable)) {
2183
        msg =
2184
            "In defined assignment subroutine '%s', second dummy argument '%s' must not be an allocatable"_err_en_US;
2185
      }
2186
    } else {
2187
      DIE("pos must be 0 or 1");
2188
    }
2189
  } else {
2190
    msg = "In defined assignment subroutine '%s', dummy argument '%s'"
2191
          " must be a data object"_err_en_US;
2192
  }
2193
  if (msg) {
2194
    bool isFatal{msg->IsFatal()};
2195
    if (isFatal || !FindModuleFileContaining(symbol.owner())) {
2196
      SayWithDeclaration(symbol, std::move(*msg), symbol.name(), arg.name);
2197
    }
2198
    if (isFatal) {
2199
      context_.SetError(symbol);
2200
      return false;
2201
    }
2202
  }
2203
  return true;
2204
}
2205

2206
// Report a conflicting attribute error if symbol has both of these attributes
2207
bool CheckHelper::CheckConflicting(const Symbol &symbol, Attr a1, Attr a2) {
2208
  if (symbol.attrs().test(a1) && symbol.attrs().test(a2)) {
2209
    messages_.Say("'%s' may not have both the %s and %s attributes"_err_en_US,
2210
        symbol.name(), AttrToString(a1), AttrToString(a2));
2211
    return true;
2212
  } else {
2213
    return false;
2214
  }
2215
}
2216

2217
void CheckHelper::WarnMissingFinal(const Symbol &symbol) {
2218
  const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
2219
  if (!object || object->IsAssumedRank() ||
2220
      (!IsAutomaticallyDestroyed(symbol) &&
2221
          symbol.owner().kind() != Scope::Kind::DerivedType)) {
2222
    return;
2223
  }
2224
  const DeclTypeSpec *type{object->type()};
2225
  const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
2226
  const Symbol *derivedSym{derived ? &derived->typeSymbol() : nullptr};
2227
  int rank{object->shape().Rank()};
2228
  const Symbol *initialDerivedSym{derivedSym};
2229
  while (const auto *derivedDetails{
2230
      derivedSym ? derivedSym->detailsIf<DerivedTypeDetails>() : nullptr}) {
2231
    if (!derivedDetails->finals().empty() &&
2232
        !derivedDetails->GetFinalForRank(rank) &&
2233
        context_.ShouldWarn(common::UsageWarning::Final)) {
2234
      if (auto *msg{derivedSym == initialDerivedSym
2235
                  ? WarnIfNotInModuleFile(symbol.name(),
2236
                        "'%s' of derived type '%s' does not have a FINAL subroutine for its rank (%d)"_warn_en_US,
2237
                        symbol.name(), derivedSym->name(), rank)
2238
                  : WarnIfNotInModuleFile(symbol.name(),
2239
                        "'%s' of derived type '%s' extended from '%s' does not have a FINAL subroutine for its rank (%d)"_warn_en_US,
2240
                        symbol.name(), initialDerivedSym->name(),
2241
                        derivedSym->name(), rank)}) {
2242
        msg->Attach(derivedSym->name(),
2243
            "Declaration of derived type '%s'"_en_US, derivedSym->name());
2244
      }
2245
      return;
2246
    }
2247
    derived = derivedSym->GetParentTypeSpec();
2248
    derivedSym = derived ? &derived->typeSymbol() : nullptr;
2249
  }
2250
}
2251

2252
const Procedure *CheckHelper::Characterize(const Symbol &symbol) {
2253
  auto it{characterizeCache_.find(symbol)};
2254
  if (it == characterizeCache_.end()) {
2255
    auto pair{characterizeCache_.emplace(SymbolRef{symbol},
2256
        Procedure::Characterize(symbol, context_.foldingContext()))};
2257
    it = pair.first;
2258
  }
2259
  return common::GetPtrFromOptional(it->second);
2260
}
2261

2262
void CheckHelper::CheckVolatile(const Symbol &symbol,
2263
    const DerivedTypeSpec *derived) { // C866 - C868
2264
  if (IsIntentIn(symbol)) {
2265
    messages_.Say(
2266
        "VOLATILE attribute may not apply to an INTENT(IN) argument"_err_en_US);
2267
  }
2268
  if (IsProcedure(symbol)) {
2269
    messages_.Say("VOLATILE attribute may apply only to a variable"_err_en_US);
2270
  }
2271
  if (symbol.has<UseDetails>() || symbol.has<HostAssocDetails>()) {
2272
    const Symbol &ultimate{symbol.GetUltimate()};
2273
    if (evaluate::IsCoarray(ultimate)) {
2274
      messages_.Say(
2275
          "VOLATILE attribute may not apply to a coarray accessed by USE or host association"_err_en_US);
2276
    }
2277
    if (derived) {
2278
      if (FindCoarrayUltimateComponent(*derived)) {
2279
        messages_.Say(
2280
            "VOLATILE attribute may not apply to a type with a coarray ultimate component accessed by USE or host association"_err_en_US);
2281
      }
2282
    }
2283
  }
2284
}
2285

2286
void CheckHelper::CheckContiguous(const Symbol &symbol) {
2287
  if (evaluate::IsVariable(symbol) &&
2288
      ((IsPointer(symbol) && symbol.Rank() > 0) || IsAssumedShape(symbol) ||
2289
          evaluate::IsAssumedRank(symbol))) {
2290
  } else if (!context_.IsEnabled(
2291
                 common::LanguageFeature::RedundantContiguous) ||
2292
      context_.ShouldWarn(common::LanguageFeature::RedundantContiguous)) {
2293
    parser::MessageFixedText msg{symbol.owner().IsDerivedType()
2294
            ? "CONTIGUOUS component '%s' should be an array with the POINTER attribute"_port_en_US
2295
            : "CONTIGUOUS entity '%s' should be an array pointer, assumed-shape, or assumed-rank"_port_en_US};
2296
    if (!context_.IsEnabled(common::LanguageFeature::RedundantContiguous)) {
2297
      msg.set_severity(parser::Severity::Error);
2298
    }
2299
    messages_.Say(std::move(msg), symbol.name());
2300
  }
2301
}
2302

2303
void CheckHelper::CheckPointer(const Symbol &symbol) { // C852
2304
  CheckConflicting(symbol, Attr::POINTER, Attr::TARGET);
2305
  CheckConflicting(symbol, Attr::POINTER, Attr::ALLOCATABLE); // C751
2306
  CheckConflicting(symbol, Attr::POINTER, Attr::INTRINSIC);
2307
  // Prohibit constant pointers.  The standard does not explicitly prohibit
2308
  // them, but the PARAMETER attribute requires a entity-decl to have an
2309
  // initialization that is a constant-expr, and the only form of
2310
  // initialization that allows a constant-expr is the one that's not a "=>"
2311
  // pointer initialization.  See C811, C807, and section 8.5.13.
2312
  CheckConflicting(symbol, Attr::POINTER, Attr::PARAMETER);
2313
  if (symbol.Corank() > 0) {
2314
    messages_.Say(
2315
        "'%s' may not have the POINTER attribute because it is a coarray"_err_en_US,
2316
        symbol.name());
2317
  }
2318
}
2319

2320
// C760 constraints on the passed-object dummy argument
2321
// C757 constraints on procedure pointer components
2322
void CheckHelper::CheckPassArg(
2323
    const Symbol &proc, const Symbol *interface0, const WithPassArg &details) {
2324
  if (proc.attrs().test(Attr::NOPASS)) {
2325
    return;
2326
  }
2327
  const auto &name{proc.name()};
2328
  const Symbol *interface {
2329
    interface0 ? FindInterface(*interface0) : nullptr
2330
  };
2331
  if (!interface) {
2332
    messages_.Say(name,
2333
        "Procedure component '%s' must have NOPASS attribute or explicit interface"_err_en_US,
2334
        name);
2335
    return;
2336
  }
2337
  const auto *subprogram{interface->detailsIf<SubprogramDetails>()};
2338
  if (!subprogram) {
2339
    messages_.Say(name,
2340
        "Procedure component '%s' has invalid interface '%s'"_err_en_US, name,
2341
        interface->name());
2342
    return;
2343
  }
2344
  std::optional<SourceName> passName{details.passName()};
2345
  const auto &dummyArgs{subprogram->dummyArgs()};
2346
  if (!passName) {
2347
    if (dummyArgs.empty()) {
2348
      messages_.Say(name,
2349
          proc.has<ProcEntityDetails>()
2350
              ? "Procedure component '%s' with no dummy arguments"
2351
                " must have NOPASS attribute"_err_en_US
2352
              : "Procedure binding '%s' with no dummy arguments"
2353
                " must have NOPASS attribute"_err_en_US,
2354
          name);
2355
      context_.SetError(*interface);
2356
      return;
2357
    }
2358
    Symbol *argSym{dummyArgs[0]};
2359
    if (!argSym) {
2360
      messages_.Say(interface->name(),
2361
          "Cannot use an alternate return as the passed-object dummy "
2362
          "argument"_err_en_US);
2363
      return;
2364
    }
2365
    passName = dummyArgs[0]->name();
2366
  }
2367
  std::optional<int> passArgIndex{};
2368
  for (std::size_t i{0}; i < dummyArgs.size(); ++i) {
2369
    if (dummyArgs[i] && dummyArgs[i]->name() == *passName) {
2370
      passArgIndex = i;
2371
      break;
2372
    }
2373
  }
2374
  if (!passArgIndex) { // C758
2375
    messages_.Say(*passName,
2376
        "'%s' is not a dummy argument of procedure interface '%s'"_err_en_US,
2377
        *passName, interface->name());
2378
    return;
2379
  }
2380
  const Symbol &passArg{*dummyArgs[*passArgIndex]};
2381
  std::optional<parser::MessageFixedText> msg;
2382
  if (!passArg.has<ObjectEntityDetails>()) {
2383
    msg = "Passed-object dummy argument '%s' of procedure '%s'"
2384
          " must be a data object"_err_en_US;
2385
  } else if (passArg.attrs().test(Attr::POINTER)) {
2386
    msg = "Passed-object dummy argument '%s' of procedure '%s'"
2387
          " may not have the POINTER attribute"_err_en_US;
2388
  } else if (passArg.attrs().test(Attr::ALLOCATABLE)) {
2389
    msg = "Passed-object dummy argument '%s' of procedure '%s'"
2390
          " may not have the ALLOCATABLE attribute"_err_en_US;
2391
  } else if (passArg.attrs().test(Attr::VALUE)) {
2392
    msg = "Passed-object dummy argument '%s' of procedure '%s'"
2393
          " may not have the VALUE attribute"_err_en_US;
2394
  } else if (passArg.Rank() > 0) {
2395
    msg = "Passed-object dummy argument '%s' of procedure '%s'"
2396
          " must be scalar"_err_en_US;
2397
  }
2398
  if (msg) {
2399
    messages_.Say(name, std::move(*msg), passName.value(), name);
2400
    return;
2401
  }
2402
  const DeclTypeSpec *type{passArg.GetType()};
2403
  if (!type) {
2404
    return; // an error already occurred
2405
  }
2406
  const Symbol &typeSymbol{*proc.owner().GetSymbol()};
2407
  const DerivedTypeSpec *derived{type->AsDerived()};
2408
  if (!derived || derived->typeSymbol() != typeSymbol) {
2409
    messages_.Say(name,
2410
        "Passed-object dummy argument '%s' of procedure '%s'"
2411
        " must be of type '%s' but is '%s'"_err_en_US,
2412
        passName.value(), name, typeSymbol.name(), type->AsFortran());
2413
    return;
2414
  }
2415
  if (IsExtensibleType(derived) != type->IsPolymorphic()) {
2416
    messages_.Say(name,
2417
        type->IsPolymorphic()
2418
            ? "Passed-object dummy argument '%s' of procedure '%s'"
2419
              " may not be polymorphic because '%s' is not extensible"_err_en_US
2420
            : "Passed-object dummy argument '%s' of procedure '%s'"
2421
              " must be polymorphic because '%s' is extensible"_err_en_US,
2422
        passName.value(), name, typeSymbol.name());
2423
    return;
2424
  }
2425
  for (const auto &[paramName, paramValue] : derived->parameters()) {
2426
    if (paramValue.isLen() && !paramValue.isAssumed()) {
2427
      messages_.Say(name,
2428
          "Passed-object dummy argument '%s' of procedure '%s'"
2429
          " has non-assumed length parameter '%s'"_err_en_US,
2430
          passName.value(), name, paramName);
2431
    }
2432
  }
2433
}
2434

2435
void CheckHelper::CheckProcBinding(
2436
    const Symbol &symbol, const ProcBindingDetails &binding) {
2437
  const Scope &dtScope{symbol.owner()};
2438
  CHECK(dtScope.kind() == Scope::Kind::DerivedType);
2439
  if (symbol.attrs().test(Attr::DEFERRED)) {
2440
    if (const Symbol *dtSymbol{dtScope.symbol()}) {
2441
      if (!dtSymbol->attrs().test(Attr::ABSTRACT)) { // C733
2442
        SayWithDeclaration(*dtSymbol,
2443
            "Procedure bound to non-ABSTRACT derived type '%s' may not be DEFERRED"_err_en_US,
2444
            dtSymbol->name());
2445
      }
2446
    }
2447
    if (symbol.attrs().test(Attr::NON_OVERRIDABLE)) {
2448
      messages_.Say(
2449
          "Type-bound procedure '%s' may not be both DEFERRED and NON_OVERRIDABLE"_err_en_US,
2450
          symbol.name());
2451
    }
2452
  }
2453
  if (binding.symbol().attrs().test(Attr::INTRINSIC) &&
2454
      !context_.intrinsics().IsSpecificIntrinsicFunction(
2455
          binding.symbol().name().ToString())) {
2456
    messages_.Say(
2457
        "Intrinsic procedure '%s' is not a specific intrinsic permitted for use in the definition of binding '%s'"_err_en_US,
2458
        binding.symbol().name(), symbol.name());
2459
  }
2460
  bool isInaccessibleDeferred{false};
2461
  if (const Symbol *
2462
      overridden{FindOverriddenBinding(symbol, isInaccessibleDeferred)}) {
2463
    if (isInaccessibleDeferred) {
2464
      SayWithDeclaration(*overridden,
2465
          "Override of PRIVATE DEFERRED '%s' must appear in its module"_err_en_US,
2466
          symbol.name());
2467
    }
2468
    if (overridden->attrs().test(Attr::NON_OVERRIDABLE)) {
2469
      SayWithDeclaration(*overridden,
2470
          "Override of NON_OVERRIDABLE '%s' is not permitted"_err_en_US,
2471
          symbol.name());
2472
    }
2473
    if (const auto *overriddenBinding{
2474
            overridden->detailsIf<ProcBindingDetails>()}) {
2475
      if (!IsPureProcedure(symbol) && IsPureProcedure(*overridden)) {
2476
        SayWithDeclaration(*overridden,
2477
            "An overridden pure type-bound procedure binding must also be pure"_err_en_US);
2478
        return;
2479
      }
2480
      if (!IsElementalProcedure(binding.symbol()) &&
2481
          IsElementalProcedure(*overridden)) {
2482
        SayWithDeclaration(*overridden,
2483
            "A type-bound procedure and its override must both, or neither, be ELEMENTAL"_err_en_US);
2484
        return;
2485
      }
2486
      bool isNopass{symbol.attrs().test(Attr::NOPASS)};
2487
      if (isNopass != overridden->attrs().test(Attr::NOPASS)) {
2488
        SayWithDeclaration(*overridden,
2489
            isNopass
2490
                ? "A NOPASS type-bound procedure may not override a passed-argument procedure"_err_en_US
2491
                : "A passed-argument type-bound procedure may not override a NOPASS procedure"_err_en_US);
2492
      } else {
2493
        const auto *bindingChars{Characterize(binding.symbol())};
2494
        const auto *overriddenChars{Characterize(*overridden)};
2495
        if (bindingChars && overriddenChars) {
2496
          if (isNopass) {
2497
            if (!bindingChars->CanOverride(*overriddenChars, std::nullopt)) {
2498
              SayWithDeclaration(*overridden,
2499
                  "A NOPASS type-bound procedure and its override must have identical interfaces"_err_en_US);
2500
            }
2501
          } else if (!context_.HasError(binding.symbol())) {
2502
            auto passIndex{bindingChars->FindPassIndex(binding.passName())};
2503
            auto overriddenPassIndex{
2504
                overriddenChars->FindPassIndex(overriddenBinding->passName())};
2505
            if (passIndex && overriddenPassIndex) {
2506
              if (*passIndex != *overriddenPassIndex) {
2507
                SayWithDeclaration(*overridden,
2508
                    "A type-bound procedure and its override must use the same PASS argument"_err_en_US);
2509
              } else if (!bindingChars->CanOverride(
2510
                             *overriddenChars, passIndex)) {
2511
                SayWithDeclaration(*overridden,
2512
                    "A type-bound procedure and its override must have compatible interfaces"_err_en_US);
2513
              }
2514
            }
2515
          }
2516
        }
2517
      }
2518
      if (symbol.attrs().test(Attr::PRIVATE)) {
2519
        if (FindModuleContaining(dtScope) ==
2520
            FindModuleContaining(overridden->owner())) {
2521
          // types declared in same madule
2522
          if (!overridden->attrs().test(Attr::PRIVATE)) {
2523
            SayWithDeclaration(*overridden,
2524
                "A PRIVATE procedure may not override a PUBLIC procedure"_err_en_US);
2525
          }
2526
        } else { // types declared in distinct madules
2527
          if (!CheckAccessibleSymbol(dtScope.parent(), *overridden)) {
2528
            SayWithDeclaration(*overridden,
2529
                "A PRIVATE procedure may not override an accessible procedure"_err_en_US);
2530
          }
2531
        }
2532
      }
2533
    } else {
2534
      SayWithDeclaration(*overridden,
2535
          "A type-bound procedure binding may not have the same name as a parent component"_err_en_US);
2536
    }
2537
  }
2538
  CheckPassArg(symbol, &binding.symbol(), binding);
2539
}
2540

2541
void CheckHelper::Check(const Scope &scope) {
2542
  scope_ = &scope;
2543
  common::Restorer<const Symbol *> restorer{innermostSymbol_, innermostSymbol_};
2544
  if (const Symbol *symbol{scope.symbol()}) {
2545
    innermostSymbol_ = symbol;
2546
  }
2547
  if (scope.IsParameterizedDerivedTypeInstantiation()) {
2548
    auto restorer{common::ScopedSet(scopeIsUninstantiatedPDT_, false)};
2549
    auto restorer2{context_.foldingContext().messages().SetContext(
2550
        scope.instantiationContext().get())};
2551
    for (const auto &pair : scope) {
2552
      CheckPointerInitialization(*pair.second);
2553
    }
2554
  } else {
2555
    auto restorer{common::ScopedSet(
2556
        scopeIsUninstantiatedPDT_, scope.IsParameterizedDerivedType())};
2557
    for (const auto &set : scope.equivalenceSets()) {
2558
      CheckEquivalenceSet(set);
2559
    }
2560
    for (const auto &pair : scope) {
2561
      Check(*pair.second);
2562
    }
2563
    if (scope.IsSubmodule() && scope.symbol()) {
2564
      // Submodule names are not in their parent's scopes
2565
      Check(*scope.symbol());
2566
    }
2567
    for (const auto &pair : scope.commonBlocks()) {
2568
      CheckCommonBlock(*pair.second);
2569
    }
2570
    int mainProgCnt{0};
2571
    for (const Scope &child : scope.children()) {
2572
      Check(child);
2573
      // A program shall consist of exactly one main program (5.2.2).
2574
      if (child.kind() == Scope::Kind::MainProgram) {
2575
        ++mainProgCnt;
2576
        if (mainProgCnt > 1) {
2577
          messages_.Say(child.sourceRange(),
2578
              "A source file cannot contain more than one main program"_err_en_US);
2579
        }
2580
      }
2581
    }
2582
    if (scope.kind() == Scope::Kind::BlockData) {
2583
      CheckBlockData(scope);
2584
    }
2585
    if (auto name{scope.GetName()}) {
2586
      auto iter{scope.find(*name)};
2587
      if (iter != scope.end()) {
2588
        const char *kind{nullptr};
2589
        if (context_.ShouldWarn(common::LanguageFeature::BenignNameClash)) {
2590
          switch (scope.kind()) {
2591
          case Scope::Kind::Module:
2592
            kind = scope.symbol()->get<ModuleDetails>().isSubmodule()
2593
                ? "submodule"
2594
                : "module";
2595
            break;
2596
          case Scope::Kind::MainProgram:
2597
            kind = "main program";
2598
            break;
2599
          case Scope::Kind::BlockData:
2600
            kind = "BLOCK DATA subprogram";
2601
            break;
2602
          default:;
2603
          }
2604
          if (kind) {
2605
            messages_.Say(iter->second->name(),
2606
                "Name '%s' declared in a %s should not have the same name as the %s"_port_en_US,
2607
                *name, kind, kind);
2608
          }
2609
        }
2610
      }
2611
    }
2612
    CheckGenericOps(scope);
2613
  }
2614
}
2615

2616
void CheckHelper::CheckEquivalenceSet(const EquivalenceSet &set) {
2617
  auto iter{
2618
      std::find_if(set.begin(), set.end(), [](const EquivalenceObject &object) {
2619
        return FindCommonBlockContaining(object.symbol) != nullptr;
2620
      })};
2621
  if (iter != set.end()) {
2622
    const Symbol &commonBlock{DEREF(FindCommonBlockContaining(iter->symbol))};
2623
    for (auto &object : set) {
2624
      if (&object != &*iter) {
2625
        if (auto *details{object.symbol.detailsIf<ObjectEntityDetails>()}) {
2626
          if (details->commonBlock()) {
2627
            if (details->commonBlock() != &commonBlock) { // 8.10.3 paragraph 1
2628
              if (auto *msg{messages_.Say(object.symbol.name(),
2629
                      "Two objects in the same EQUIVALENCE set may not be members of distinct COMMON blocks"_err_en_US)}) {
2630
                msg->Attach(iter->symbol.name(),
2631
                       "Other object in EQUIVALENCE set"_en_US)
2632
                    .Attach(details->commonBlock()->name(),
2633
                        "COMMON block containing '%s'"_en_US,
2634
                        object.symbol.name())
2635
                    .Attach(commonBlock.name(),
2636
                        "COMMON block containing '%s'"_en_US,
2637
                        iter->symbol.name());
2638
              }
2639
            }
2640
          } else {
2641
            // Mark all symbols in the equivalence set with the same COMMON
2642
            // block to prevent spurious error messages about initialization
2643
            // in BLOCK DATA outside COMMON
2644
            details->set_commonBlock(commonBlock);
2645
          }
2646
        }
2647
      }
2648
    }
2649
  }
2650
  for (const EquivalenceObject &object : set) {
2651
    CheckEquivalenceObject(object);
2652
  }
2653
}
2654

2655
static bool InCommonWithBind(const Symbol &symbol) {
2656
  if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
2657
    const Symbol *commonBlock{details->commonBlock()};
2658
    return commonBlock && commonBlock->attrs().test(Attr::BIND_C);
2659
  } else {
2660
    return false;
2661
  }
2662
}
2663

2664
void CheckHelper::CheckEquivalenceObject(const EquivalenceObject &object) {
2665
  parser::MessageFixedText msg;
2666
  const Symbol &symbol{object.symbol};
2667
  if (symbol.owner().IsDerivedType()) {
2668
    msg =
2669
        "Derived type component '%s' is not allowed in an equivalence set"_err_en_US;
2670
  } else if (IsDummy(symbol)) {
2671
    msg = "Dummy argument '%s' is not allowed in an equivalence set"_err_en_US;
2672
  } else if (symbol.IsFuncResult()) {
2673
    msg = "Function result '%s' is not allow in an equivalence set"_err_en_US;
2674
  } else if (IsPointer(symbol)) {
2675
    msg = "Pointer '%s' is not allowed in an equivalence set"_err_en_US;
2676
  } else if (IsAllocatable(symbol)) {
2677
    msg =
2678
        "Allocatable variable '%s' is not allowed in an equivalence set"_err_en_US;
2679
  } else if (symbol.Corank() > 0) {
2680
    msg = "Coarray '%s' is not allowed in an equivalence set"_err_en_US;
2681
  } else if (symbol.has<UseDetails>()) {
2682
    msg =
2683
        "Use-associated variable '%s' is not allowed in an equivalence set"_err_en_US;
2684
  } else if (symbol.attrs().test(Attr::BIND_C)) {
2685
    msg =
2686
        "Variable '%s' with BIND attribute is not allowed in an equivalence set"_err_en_US;
2687
  } else if (symbol.attrs().test(Attr::TARGET)) {
2688
    msg =
2689
        "Variable '%s' with TARGET attribute is not allowed in an equivalence set"_err_en_US;
2690
  } else if (IsNamedConstant(symbol)) {
2691
    msg = "Named constant '%s' is not allowed in an equivalence set"_err_en_US;
2692
  } else if (InCommonWithBind(symbol)) {
2693
    msg =
2694
        "Variable '%s' in common block with BIND attribute is not allowed in an equivalence set"_err_en_US;
2695
  } else if (!symbol.has<ObjectEntityDetails>()) {
2696
    msg = "'%s' in equivalence set is not a data object"_err_en_US;
2697
  } else if (const auto *type{symbol.GetType()}) {
2698
    const auto *derived{type->AsDerived()};
2699
    if (derived && !derived->IsVectorType()) {
2700
      if (const auto *comp{
2701
              FindUltimateComponent(*derived, IsAllocatableOrPointer)}) {
2702
        msg = IsPointer(*comp)
2703
            ? "Derived type object '%s' with pointer ultimate component is not allowed in an equivalence set"_err_en_US
2704
            : "Derived type object '%s' with allocatable ultimate component is not allowed in an equivalence set"_err_en_US;
2705
      } else if (!derived->typeSymbol().get<DerivedTypeDetails>().sequence()) {
2706
        msg =
2707
            "Nonsequence derived type object '%s' is not allowed in an equivalence set"_err_en_US;
2708
      }
2709
    } else if (IsAutomatic(symbol)) {
2710
      msg =
2711
          "Automatic object '%s' is not allowed in an equivalence set"_err_en_US;
2712
    } else if (symbol.test(Symbol::Flag::CrayPointee)) {
2713
      messages_.Say(object.symbol.name(),
2714
          "Cray pointee '%s' may not be a member of an EQUIVALENCE group"_err_en_US,
2715
          object.symbol.name());
2716
    }
2717
  }
2718
  if (!msg.text().empty()) {
2719
    context_.Say(object.source, std::move(msg), symbol.name());
2720
  }
2721
}
2722

2723
void CheckHelper::CheckBlockData(const Scope &scope) {
2724
  // BLOCK DATA subprograms should contain only named common blocks.
2725
  // C1415 presents a list of statements that shouldn't appear in
2726
  // BLOCK DATA, but so long as the subprogram contains no executable
2727
  // code and allocates no storage outside named COMMON, we're happy
2728
  // (e.g., an ENUM is strictly not allowed).
2729
  for (const auto &pair : scope) {
2730
    const Symbol &symbol{*pair.second};
2731
    if (!(symbol.has<CommonBlockDetails>() || symbol.has<UseDetails>() ||
2732
            symbol.has<UseErrorDetails>() || symbol.has<DerivedTypeDetails>() ||
2733
            symbol.has<SubprogramDetails>() ||
2734
            symbol.has<ObjectEntityDetails>() ||
2735
            (symbol.has<ProcEntityDetails>() &&
2736
                !symbol.attrs().test(Attr::POINTER)))) {
2737
      messages_.Say(symbol.name(),
2738
          "'%s' may not appear in a BLOCK DATA subprogram"_err_en_US,
2739
          symbol.name());
2740
    }
2741
  }
2742
}
2743

2744
// Check distinguishability of generic assignment and operators.
2745
// For these, generics and generic bindings must be considered together.
2746
void CheckHelper::CheckGenericOps(const Scope &scope) {
2747
  DistinguishabilityHelper helper{context_};
2748
  auto addSpecifics{[&](const Symbol &generic) {
2749
    const auto *details{generic.GetUltimate().detailsIf<GenericDetails>()};
2750
    if (!details) {
2751
      // Not a generic; ensure characteristics are defined if a function.
2752
      auto restorer{messages_.SetLocation(generic.name())};
2753
      if (IsFunction(generic) && !context_.HasError(generic)) {
2754
        if (const Symbol *result{FindFunctionResult(generic)};
2755
            result && !context_.HasError(*result)) {
2756
          Characterize(generic);
2757
        }
2758
      }
2759
      return;
2760
    }
2761
    GenericKind kind{details->kind()};
2762
    if (!kind.IsAssignment() && !kind.IsOperator()) {
2763
      return;
2764
    }
2765
    const SymbolVector &specifics{details->specificProcs()};
2766
    const std::vector<SourceName> &bindingNames{details->bindingNames()};
2767
    for (std::size_t i{0}; i < specifics.size(); ++i) {
2768
      const Symbol &specific{*specifics[i]};
2769
      auto restorer{messages_.SetLocation(bindingNames[i])};
2770
      if (const Procedure *proc{Characterize(specific)}) {
2771
        if (kind.IsAssignment()) {
2772
          if (!CheckDefinedAssignment(specific, *proc)) {
2773
            continue;
2774
          }
2775
        } else {
2776
          if (!CheckDefinedOperator(generic.name(), kind, specific, *proc)) {
2777
            continue;
2778
          }
2779
        }
2780
        helper.Add(generic, kind, specific, *proc);
2781
      }
2782
    }
2783
  }};
2784
  for (const auto &pair : scope) {
2785
    const Symbol &symbol{*pair.second};
2786
    addSpecifics(symbol);
2787
    const Symbol &ultimate{symbol.GetUltimate()};
2788
    if (ultimate.has<DerivedTypeDetails>()) {
2789
      if (const Scope *typeScope{ultimate.scope()}) {
2790
        for (const auto &pair2 : *typeScope) {
2791
          addSpecifics(*pair2.second);
2792
        }
2793
      }
2794
    }
2795
  }
2796
  helper.Check(scope);
2797
}
2798

2799
static bool IsSubprogramDefinition(const Symbol &symbol) {
2800
  const auto *subp{symbol.detailsIf<SubprogramDetails>()};
2801
  return subp && !subp->isInterface() && symbol.scope() &&
2802
      symbol.scope()->kind() == Scope::Kind::Subprogram;
2803
}
2804

2805
static bool IsBlockData(const Symbol &symbol) {
2806
  return symbol.scope() && symbol.scope()->kind() == Scope::Kind::BlockData;
2807
}
2808

2809
static bool IsExternalProcedureDefinition(const Symbol &symbol) {
2810
  return IsBlockData(symbol) ||
2811
      (IsSubprogramDefinition(symbol) &&
2812
          (IsExternal(symbol) || symbol.GetBindName()));
2813
}
2814

2815
static std::optional<std::string> DefinesGlobalName(const Symbol &symbol) {
2816
  if (const auto *module{symbol.detailsIf<ModuleDetails>()}) {
2817
    if (!module->isSubmodule() && !symbol.owner().IsIntrinsicModules()) {
2818
      return symbol.name().ToString();
2819
    }
2820
  } else if (IsBlockData(symbol)) {
2821
    return symbol.name().ToString();
2822
  } else {
2823
    const std::string *bindC{symbol.GetBindName()};
2824
    if (symbol.has<CommonBlockDetails>() ||
2825
        IsExternalProcedureDefinition(symbol) ||
2826
        (symbol.owner().IsGlobal() && IsExternal(symbol))) {
2827
      return bindC ? *bindC : symbol.name().ToString();
2828
    } else if (bindC &&
2829
        (symbol.has<ObjectEntityDetails>() || IsModuleProcedure(symbol))) {
2830
      return *bindC;
2831
    }
2832
  }
2833
  return std::nullopt;
2834
}
2835

2836
// 19.2 p2
2837
void CheckHelper::CheckGlobalName(const Symbol &symbol) {
2838
  if (auto global{DefinesGlobalName(symbol)}) {
2839
    auto pair{globalNames_.emplace(std::move(*global), symbol)};
2840
    if (!pair.second) {
2841
      const Symbol &other{*pair.first->second};
2842
      if (context_.HasError(symbol) || context_.HasError(other)) {
2843
        // don't pile on
2844
      } else if (symbol.has<CommonBlockDetails>() &&
2845
          other.has<CommonBlockDetails>() && symbol.name() == other.name()) {
2846
        // Two common blocks can have the same global name so long as
2847
        // they're not in the same scope.
2848
      } else if ((IsProcedure(symbol) || IsBlockData(symbol)) &&
2849
          (IsProcedure(other) || IsBlockData(other)) &&
2850
          (!IsExternalProcedureDefinition(symbol) ||
2851
              !IsExternalProcedureDefinition(other))) {
2852
        // both are procedures/BLOCK DATA, not both definitions
2853
      } else if (symbol.has<ModuleDetails>()) {
2854
        if (context_.ShouldWarn(common::LanguageFeature::BenignNameClash)) {
2855
          messages_.Say(symbol.name(),
2856
              "Module '%s' conflicts with a global name"_port_en_US,
2857
              pair.first->first);
2858
        }
2859
      } else if (other.has<ModuleDetails>()) {
2860
        if (context_.ShouldWarn(common::LanguageFeature::BenignNameClash)) {
2861
          messages_.Say(symbol.name(),
2862
              "Global name '%s' conflicts with a module"_port_en_US,
2863
              pair.first->first);
2864
        }
2865
      } else if (auto *msg{messages_.Say(symbol.name(),
2866
                     "Two entities have the same global name '%s'"_err_en_US,
2867
                     pair.first->first)}) {
2868
        msg->Attach(other.name(), "Conflicting declaration"_en_US);
2869
        context_.SetError(symbol);
2870
        context_.SetError(other);
2871
      }
2872
    }
2873
  }
2874
}
2875

2876
void CheckHelper::CheckProcedureAssemblyName(const Symbol &symbol) {
2877
  if (!IsProcedure(symbol) || symbol != symbol.GetUltimate())
2878
    return;
2879
  const std::string *bindName{symbol.GetBindName()};
2880
  const bool hasExplicitBindingLabel{
2881
      symbol.GetIsExplicitBindName() && bindName};
2882
  if (hasExplicitBindingLabel || IsExternal(symbol)) {
2883
    const std::string assemblyName{hasExplicitBindingLabel
2884
            ? *bindName
2885
            : common::GetExternalAssemblyName(
2886
                  symbol.name().ToString(), context_.underscoring())};
2887
    auto pair{procedureAssemblyNames_.emplace(std::move(assemblyName), symbol)};
2888
    if (!pair.second) {
2889
      const Symbol &other{*pair.first->second};
2890
      const bool otherHasExplicitBindingLabel{
2891
          other.GetIsExplicitBindName() && other.GetBindName()};
2892
      if (otherHasExplicitBindingLabel != hasExplicitBindingLabel) {
2893
        // The BIND(C,NAME="...") binding label is the same as the name that
2894
        // will be used in LLVM IR for an external procedure declared without
2895
        // BIND(C) in the same file. While this is not forbidden by the
2896
        // standard, this name collision would lead to a crash when producing
2897
        // the IR.
2898
        if (auto *msg{messages_.Say(symbol.name(),
2899
                "%s procedure assembly name conflicts with %s procedure assembly name"_err_en_US,
2900
                hasExplicitBindingLabel ? "BIND(C)" : "Non BIND(C)",
2901
                hasExplicitBindingLabel ? "non BIND(C)" : "BIND(C)")}) {
2902
          msg->Attach(other.name(), "Conflicting declaration"_en_US);
2903
        }
2904
        context_.SetError(symbol);
2905
        context_.SetError(other);
2906
      }
2907
      // Otherwise, the global names also match and the conflict is analyzed
2908
      // by CheckGlobalName.
2909
    }
2910
  }
2911
}
2912

2913
parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
2914
    const Symbol &symbol) {
2915
  parser::Messages msgs;
2916
  if (examinedByWhyNotInteroperable_.find(symbol) !=
2917
      examinedByWhyNotInteroperable_.end()) {
2918
    return msgs;
2919
  }
2920
  examinedByWhyNotInteroperable_.insert(symbol);
2921
  if (const auto *derived{symbol.detailsIf<DerivedTypeDetails>()}) {
2922
    if (derived->sequence()) { // C1801
2923
      msgs.Say(symbol.name(),
2924
          "An interoperable derived type cannot have the SEQUENCE attribute"_err_en_US);
2925
    } else if (!derived->paramDecls().empty()) { // C1802
2926
      msgs.Say(symbol.name(),
2927
          "An interoperable derived type cannot have a type parameter"_err_en_US);
2928
    } else if (const auto *parent{
2929
                   symbol.scope()->GetDerivedTypeParent()}) { // C1803
2930
      if (symbol.attrs().test(Attr::BIND_C)) {
2931
        msgs.Say(symbol.name(),
2932
            "A derived type with the BIND attribute cannot be an extended derived type"_err_en_US);
2933
      } else {
2934
        bool interoperableParent{true};
2935
        if (parent->symbol()) {
2936
          auto bad{WhyNotInteroperableDerivedType(*parent->symbol())};
2937
          if (bad.AnyFatalError()) {
2938
            auto &msg{msgs.Say(symbol.name(),
2939
                "The parent of an interoperable type is not interoperable"_err_en_US)};
2940
            bad.AttachTo(msg, parser::Severity::None);
2941
            interoperableParent = false;
2942
          }
2943
        }
2944
        if (interoperableParent) {
2945
          msgs.Say(symbol.name(),
2946
              "An interoperable type should not be an extended derived type"_warn_en_US);
2947
        }
2948
      }
2949
    }
2950
    const Symbol *parentComponent{symbol.scope()
2951
            ? derived->GetParentComponent(*symbol.scope())
2952
            : nullptr};
2953
    for (const auto &pair : *symbol.scope()) {
2954
      const Symbol &component{*pair.second};
2955
      if (&component == parentComponent) {
2956
        continue; // was checked above
2957
      }
2958
      if (IsProcedure(component)) { // C1804
2959
        msgs.Say(component.name(),
2960
            "An interoperable derived type cannot have a type bound procedure"_err_en_US);
2961
      } else if (IsAllocatableOrPointer(component)) { // C1806
2962
        msgs.Say(component.name(),
2963
            "An interoperable derived type cannot have a pointer or allocatable component"_err_en_US);
2964
      } else if (const auto *type{component.GetType()}) {
2965
        if (const auto *derived{type->AsDerived()}) {
2966
          auto bad{WhyNotInteroperableDerivedType(derived->typeSymbol())};
2967
          if (bad.AnyFatalError()) {
2968
            auto &msg{msgs.Say(component.name(),
2969
                "Component '%s' of an interoperable derived type must have an interoperable type but does not"_err_en_US,
2970
                component.name())};
2971
            bad.AttachTo(msg, parser::Severity::None);
2972
          } else if (!derived->typeSymbol().GetUltimate().attrs().test(
2973
                         Attr::BIND_C)) {
2974
            auto &msg{
2975
                msgs.Say(component.name(),
2976
                        "Derived type of component '%s' of an interoperable derived type should have the BIND attribute"_warn_en_US,
2977
                        component.name())
2978
                    .Attach(derived->typeSymbol().name(),
2979
                        "Non-BIND(C) component type"_en_US)};
2980
            bad.AttachTo(msg, parser::Severity::None);
2981
          } else {
2982
            msgs.Annex(std::move(bad));
2983
          }
2984
        } else if (!IsInteroperableIntrinsicType(
2985
                       *type, context_.languageFeatures())) {
2986
          auto maybeDyType{evaluate::DynamicType::From(*type)};
2987
          if (type->category() == DeclTypeSpec::Logical) {
2988
            if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {
2989
              msgs.Say(component.name(),
2990
                  "A LOGICAL component of an interoperable type should have the interoperable KIND=C_BOOL"_port_en_US);
2991
            }
2992
          } else if (type->category() == DeclTypeSpec::Character &&
2993
              maybeDyType && maybeDyType->kind() == 1) {
2994
            if (context_.ShouldWarn(common::UsageWarning::BindCCharLength)) {
2995
              msgs.Say(component.name(),
2996
                  "A CHARACTER component of an interoperable type should have length 1"_port_en_US);
2997
            }
2998
          } else {
2999
            msgs.Say(component.name(),
3000
                "Each component of an interoperable derived type must have an interoperable type"_err_en_US);
3001
          }
3002
        }
3003
      }
3004
      if (auto extents{
3005
              evaluate::GetConstantExtents(foldingContext_, &component)};
3006
          extents && evaluate::GetSize(*extents) == 0) {
3007
        msgs.Say(component.name(),
3008
            "An array component of an interoperable type must have at least one element"_err_en_US);
3009
      }
3010
    }
3011
    if (derived->componentNames().empty()) { // F'2023 C1805
3012
      if (context_.ShouldWarn(common::LanguageFeature::EmptyBindCDerivedType)) {
3013
        msgs.Say(symbol.name(),
3014
            "A derived type with the BIND attribute should not be empty"_warn_en_US);
3015
      }
3016
    }
3017
  }
3018
  if (msgs.AnyFatalError()) {
3019
    examinedByWhyNotInteroperable_.erase(symbol);
3020
  }
3021
  return msgs;
3022
}
3023

3024
parser::Messages CheckHelper::WhyNotInteroperableObject(const Symbol &symbol) {
3025
  parser::Messages msgs;
3026
  if (examinedByWhyNotInteroperable_.find(symbol) !=
3027
      examinedByWhyNotInteroperable_.end()) {
3028
    return msgs;
3029
  }
3030
  bool isExplicitBindC{symbol.attrs().test(Attr::BIND_C)};
3031
  examinedByWhyNotInteroperable_.insert(symbol);
3032
  CHECK(symbol.has<ObjectEntityDetails>());
3033
  if (isExplicitBindC && !symbol.owner().IsModule()) {
3034
    msgs.Say(symbol.name(),
3035
        "A variable with BIND(C) attribute may only appear in the specification part of a module"_err_en_US);
3036
  }
3037
  auto shape{evaluate::GetShape(foldingContext_, symbol)};
3038
  if (shape) {
3039
    if (evaluate::GetRank(*shape) == 0) { // 18.3.4
3040
      if (IsAllocatableOrPointer(symbol) && !IsDummy(symbol)) {
3041
        msgs.Say(symbol.name(),
3042
            "A scalar interoperable variable may not be ALLOCATABLE or POINTER"_err_en_US);
3043
      }
3044
    } else if (auto extents{
3045
                   evaluate::AsConstantExtents(foldingContext_, *shape)}) {
3046
      if (evaluate::GetSize(*extents) == 0) {
3047
        msgs.Say(symbol.name(),
3048
            "Interoperable array must have at least one element"_err_en_US);
3049
      }
3050
    } else if (!evaluate::IsExplicitShape(symbol) &&
3051
        !IsAssumedSizeArray(symbol) &&
3052
        !(IsDummy(symbol) && !symbol.attrs().test(Attr::VALUE))) {
3053
      msgs.Say(symbol.name(),
3054
          "BIND(C) array must have explicit shape or be assumed-size unless a dummy argument without the VALUE attribute"_err_en_US);
3055
    }
3056
  }
3057
  if (const auto *type{symbol.GetType()}) {
3058
    const auto *derived{type->AsDerived()};
3059
    if (derived && !derived->typeSymbol().attrs().test(Attr::BIND_C)) {
3060
      if (!context_.IsEnabled(
3061
              common::LanguageFeature::NonBindCInteroperability)) {
3062
        msgs.Say(symbol.name(),
3063
                "The derived type of an interoperable object must be BIND(C)"_err_en_US)
3064
            .Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);
3065
      } else if (auto bad{
3066
                     WhyNotInteroperableDerivedType(derived->typeSymbol())};
3067
                 bad.AnyFatalError()) {
3068
        bad.AttachTo(
3069
            msgs.Say(symbol.name(),
3070
                    "The derived type of an interoperable object must be interoperable, but is not"_err_en_US)
3071
                .Attach(derived->typeSymbol().name(),
3072
                    "Non-interoperable type"_en_US),
3073
            parser::Severity::None);
3074
      } else {
3075
        msgs.Say(symbol.name(),
3076
                "The derived type of an interoperable object should be BIND(C)"_warn_en_US)
3077
            .Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);
3078
      }
3079
    }
3080
    if (type->IsAssumedType()) { // ok
3081
    } else if (IsAssumedLengthCharacter(symbol)) {
3082
    } else if (IsAllocatableOrPointer(symbol) &&
3083
        type->category() == DeclTypeSpec::Character &&
3084
        type->characterTypeSpec().length().isDeferred()) {
3085
      // ok; F'2023 18.3.7 p2(6)
3086
    } else if (derived ||
3087
        IsInteroperableIntrinsicType(*type, context_.languageFeatures())) {
3088
      // F'2023 18.3.7 p2(4,5)
3089
    } else if (type->category() == DeclTypeSpec::Logical) {
3090
      if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool) &&
3091
          !InModuleFile()) {
3092
        if (IsDummy(symbol)) {
3093
          msgs.Say(symbol.name(),
3094
              "A BIND(C) LOGICAL dummy argument should have the interoperable KIND=C_BOOL"_port_en_US);
3095
        } else {
3096
          msgs.Say(symbol.name(),
3097
              "A BIND(C) LOGICAL object should have the interoperable KIND=C_BOOL"_port_en_US);
3098
        }
3099
      }
3100
    } else if (symbol.attrs().test(Attr::VALUE)) {
3101
      msgs.Say(symbol.name(),
3102
          "A BIND(C) VALUE dummy argument must have an interoperable type"_err_en_US);
3103
    } else {
3104
      msgs.Say(symbol.name(),
3105
          "A BIND(C) object must have an interoperable type"_err_en_US);
3106
    }
3107
  }
3108
  if (IsOptional(symbol) && !symbol.attrs().test(Attr::VALUE)) {
3109
    msgs.Say(symbol.name(),
3110
        "An interoperable procedure with an OPTIONAL dummy argument might not be portable"_port_en_US);
3111
  }
3112
  if (IsDescriptor(symbol) && IsPointer(symbol) &&
3113
      symbol.attrs().test(Attr::CONTIGUOUS)) {
3114
    msgs.Say(symbol.name(),
3115
        "An interoperable pointer must not be CONTIGUOUS"_err_en_US);
3116
  }
3117
  if (msgs.AnyFatalError()) {
3118
    examinedByWhyNotInteroperable_.erase(symbol);
3119
  }
3120
  return msgs;
3121
}
3122

3123
parser::Messages CheckHelper::WhyNotInteroperableFunctionResult(
3124
    const Symbol &symbol) {
3125
  parser::Messages msgs;
3126
  if (IsPointer(symbol) || IsAllocatable(symbol)) {
3127
    msgs.Say(symbol.name(),
3128
        "Interoperable function result may not have ALLOCATABLE or POINTER attribute"_err_en_US);
3129
  }
3130
  if (const DeclTypeSpec * type{symbol.GetType()};
3131
      type && type->category() == DeclTypeSpec::Character) {
3132
    bool isConstOne{false}; // 18.3.1(1)
3133
    if (const auto &len{type->characterTypeSpec().length().GetExplicit()}) {
3134
      if (auto constLen{evaluate::ToInt64(*len)}) {
3135
        isConstOne = constLen == 1;
3136
      }
3137
    }
3138
    if (!isConstOne) {
3139
      msgs.Say(symbol.name(),
3140
          "Interoperable character function result must have length one"_err_en_US);
3141
    }
3142
  }
3143
  if (symbol.Rank() > 0) {
3144
    msgs.Say(symbol.name(),
3145
        "Interoperable function result must be scalar"_err_en_US);
3146
  }
3147
  if (symbol.Corank()) {
3148
    msgs.Say(symbol.name(),
3149
        "Interoperable function result may not be a coarray"_err_en_US);
3150
  }
3151
  return msgs;
3152
}
3153

3154
parser::Messages CheckHelper::WhyNotInteroperableProcedure(
3155
    const Symbol &symbol, bool isError) {
3156
  parser::Messages msgs;
3157
  if (examinedByWhyNotInteroperable_.find(symbol) !=
3158
      examinedByWhyNotInteroperable_.end()) {
3159
    return msgs;
3160
  }
3161
  isError |= symbol.attrs().test(Attr::BIND_C);
3162
  examinedByWhyNotInteroperable_.insert(symbol);
3163
  if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
3164
    if (isError) {
3165
      if (!proc->procInterface() ||
3166
          !proc->procInterface()->attrs().test(Attr::BIND_C)) {
3167
        msgs.Say(symbol.name(),
3168
            "An interface name with the BIND attribute must appear if the BIND attribute appears in a procedure declaration"_err_en_US);
3169
      }
3170
    } else if (!proc->procInterface()) {
3171
      msgs.Say(symbol.name(),
3172
          "An interoperable procedure should have an interface"_port_en_US);
3173
    } else if (!proc->procInterface()->attrs().test(Attr::BIND_C)) {
3174
      auto bad{WhyNotInteroperableProcedure(
3175
          *proc->procInterface(), /*isError=*/false)};
3176
      if (bad.AnyFatalError()) {
3177
        bad.AttachTo(msgs.Say(symbol.name(),
3178
            "An interoperable procedure must have an interoperable interface"_err_en_US));
3179
      } else {
3180
        msgs.Say(symbol.name(),
3181
            "An interoperable procedure should have an interface with the BIND attribute"_warn_en_US);
3182
      }
3183
    }
3184
  } else if (const auto *subp{symbol.detailsIf<SubprogramDetails>()}) {
3185
    for (const Symbol *dummy : subp->dummyArgs()) {
3186
      if (dummy) {
3187
        parser::Messages dummyMsgs;
3188
        if (dummy->has<ProcEntityDetails>() ||
3189
            dummy->has<SubprogramDetails>()) {
3190
          dummyMsgs = WhyNotInteroperableProcedure(*dummy, /*isError=*/false);
3191
          if (dummyMsgs.empty() && !dummy->attrs().test(Attr::BIND_C)) {
3192
            dummyMsgs.Say(dummy->name(),
3193
                "A dummy procedure of an interoperable procedure should be BIND(C)"_warn_en_US);
3194
          }
3195
        } else if (dummy->has<ObjectEntityDetails>()) {
3196
          dummyMsgs = WhyNotInteroperableObject(*dummy);
3197
        } else {
3198
          CheckBindC(*dummy);
3199
        }
3200
        msgs.Annex(std::move(dummyMsgs));
3201
      } else {
3202
        msgs.Say(symbol.name(),
3203
            "A subprogram interface with the BIND attribute may not have an alternate return argument"_err_en_US);
3204
      }
3205
    }
3206
    if (subp->isFunction()) {
3207
      if (subp->result().has<ObjectEntityDetails>()) {
3208
        msgs.Annex(WhyNotInteroperableFunctionResult(subp->result()));
3209
      } else {
3210
        msgs.Say(subp->result().name(),
3211
            "The result of an interoperable function must be a data object"_err_en_US);
3212
      }
3213
    }
3214
  }
3215
  if (msgs.AnyFatalError()) {
3216
    examinedByWhyNotInteroperable_.erase(symbol);
3217
  }
3218
  return msgs;
3219
}
3220

3221
void CheckHelper::CheckBindC(const Symbol &symbol) {
3222
  bool isExplicitBindC{symbol.attrs().test(Attr::BIND_C)};
3223
  if (isExplicitBindC) {
3224
    CheckConflicting(symbol, Attr::BIND_C, Attr::ELEMENTAL);
3225
    CheckConflicting(symbol, Attr::BIND_C, Attr::INTRINSIC);
3226
    CheckConflicting(symbol, Attr::BIND_C, Attr::PARAMETER);
3227
  } else {
3228
    // symbol must be interoperable (e.g., dummy argument of interoperable
3229
    // procedure interface) but is not itself BIND(C).
3230
  }
3231
  parser::Messages whyNot;
3232
  if (const std::string * bindName{symbol.GetBindName()};
3233
      bindName) { // has a binding name
3234
    if (!bindName->empty()) {
3235
      bool ok{bindName->front() == '_' || parser::IsLetter(bindName->front())};
3236
      for (char ch : *bindName) {
3237
        ok &= ch == '_' || parser::IsLetter(ch) || parser::IsDecimalDigit(ch);
3238
      }
3239
      if (!ok) {
3240
        messages_.Say(symbol.name(),
3241
            "Symbol has a BIND(C) name that is not a valid C language identifier"_err_en_US);
3242
        context_.SetError(symbol);
3243
      }
3244
    }
3245
  }
3246
  if (symbol.GetIsExplicitBindName()) { // BIND(C,NAME=...); C1552, C1529
3247
    auto defClass{ClassifyProcedure(symbol)};
3248
    if (IsProcedurePointer(symbol)) {
3249
      messages_.Say(symbol.name(),
3250
          "A procedure pointer may not have a BIND attribute with a name"_err_en_US);
3251
      context_.SetError(symbol);
3252
    } else if (defClass == ProcedureDefinitionClass::None ||
3253
        IsExternal(symbol)) {
3254
    } else if (symbol.attrs().test(Attr::ABSTRACT)) {
3255
      messages_.Say(symbol.name(),
3256
          "An ABSTRACT interface may not have a BIND attribute with a name"_err_en_US);
3257
      context_.SetError(symbol);
3258
    } else if (defClass == ProcedureDefinitionClass::Internal ||
3259
        defClass == ProcedureDefinitionClass::Dummy) {
3260
      messages_.Say(symbol.name(),
3261
          "An internal or dummy procedure may not have a BIND(C,NAME=) binding label"_err_en_US);
3262
      context_.SetError(symbol);
3263
    }
3264
  }
3265
  if (symbol.has<ObjectEntityDetails>()) {
3266
    whyNot = WhyNotInteroperableObject(symbol);
3267
  } else if (symbol.has<ProcEntityDetails>() ||
3268
      symbol.has<SubprogramDetails>()) {
3269
    whyNot = WhyNotInteroperableProcedure(symbol, /*isError=*/isExplicitBindC);
3270
  } else if (symbol.has<DerivedTypeDetails>()) {
3271
    whyNot = WhyNotInteroperableDerivedType(symbol);
3272
  }
3273
  if (!whyNot.empty()) {
3274
    bool anyFatal{whyNot.AnyFatalError()};
3275
    if (anyFatal ||
3276
        (!InModuleFile() &&
3277
            context_.ShouldWarn(
3278
                common::LanguageFeature::NonBindCInteroperability))) {
3279
      context_.messages().Annex(std::move(whyNot));
3280
    }
3281
    if (anyFatal) {
3282
      context_.SetError(symbol);
3283
    }
3284
  }
3285
}
3286

3287
bool CheckHelper::CheckDioDummyIsData(
3288
    const Symbol &subp, const Symbol *arg, std::size_t position) {
3289
  if (arg && arg->detailsIf<ObjectEntityDetails>()) {
3290
    return true;
3291
  } else {
3292
    if (arg) {
3293
      messages_.Say(arg->name(),
3294
          "Dummy argument '%s' must be a data object"_err_en_US, arg->name());
3295
    } else {
3296
      messages_.Say(subp.name(),
3297
          "Dummy argument %d of '%s' must be a data object"_err_en_US, position,
3298
          subp.name());
3299
    }
3300
    return false;
3301
  }
3302
}
3303

3304
void CheckHelper::CheckAlreadySeenDefinedIo(const DerivedTypeSpec &derivedType,
3305
    common::DefinedIo ioKind, const Symbol &proc, const Symbol &generic) {
3306
  // Check for conflict between non-type-bound defined I/O and type-bound
3307
  // generics. It's okay to have two or more distinct defined I/O procedures for
3308
  // the same type if they're coming from distinct non-type-bound interfaces.
3309
  // (The non-type-bound interfaces would have been merged into a single generic
3310
  //  -- with errors where indistinguishable --  when both were visible from the
3311
  // same scope.)
3312
  if (generic.owner().IsDerivedType()) {
3313
    return;
3314
  }
3315
  if (const Scope * dtScope{derivedType.scope()}) {
3316
    if (auto iter{dtScope->find(generic.name())}; iter != dtScope->end()) {
3317
      for (auto specRef : iter->second->get<GenericDetails>().specificProcs()) {
3318
        const Symbol &specific{specRef->get<ProcBindingDetails>().symbol()};
3319
        if (specific == proc) { // unambiguous, accept
3320
          continue;
3321
        }
3322
        if (const auto *specDT{GetDtvArgDerivedType(specific)};
3323
            specDT && evaluate::AreSameDerivedType(derivedType, *specDT)) {
3324
          SayWithDeclaration(*specRef, proc.name(),
3325
              "Derived type '%s' has conflicting type-bound input/output procedure '%s'"_err_en_US,
3326
              derivedType.name(), GenericKind::AsFortran(ioKind));
3327
          return;
3328
        }
3329
      }
3330
    }
3331
  }
3332
}
3333

3334
void CheckHelper::CheckDioDummyIsDerived(const Symbol &subp, const Symbol &arg,
3335
    common::DefinedIo ioKind, const Symbol &generic) {
3336
  if (const DeclTypeSpec *type{arg.GetType()}) {
3337
    if (const DerivedTypeSpec *derivedType{type->AsDerived()}) {
3338
      CheckAlreadySeenDefinedIo(*derivedType, ioKind, subp, generic);
3339
      bool isPolymorphic{type->IsPolymorphic()};
3340
      if (isPolymorphic != IsExtensibleType(derivedType)) {
3341
        messages_.Say(arg.name(),
3342
            "Dummy argument '%s' of a defined input/output procedure must be %s when the derived type is %s"_err_en_US,
3343
            arg.name(), isPolymorphic ? "TYPE()" : "CLASS()",
3344
            isPolymorphic ? "not extensible" : "extensible");
3345
      }
3346
    } else {
3347
      messages_.Say(arg.name(),
3348
          "Dummy argument '%s' of a defined input/output procedure must have a"
3349
          " derived type"_err_en_US,
3350
          arg.name());
3351
    }
3352
  }
3353
}
3354

3355
void CheckHelper::CheckDioDummyIsDefaultInteger(
3356
    const Symbol &subp, const Symbol &arg) {
3357
  if (const DeclTypeSpec *type{arg.GetType()};
3358
      type && type->IsNumeric(TypeCategory::Integer)) {
3359
    if (const auto kind{evaluate::ToInt64(type->numericTypeSpec().kind())};
3360
        kind && *kind == context_.GetDefaultKind(TypeCategory::Integer)) {
3361
      return;
3362
    }
3363
  }
3364
  messages_.Say(arg.name(),
3365
      "Dummy argument '%s' of a defined input/output procedure"
3366
      " must be an INTEGER of default KIND"_err_en_US,
3367
      arg.name());
3368
}
3369

3370
void CheckHelper::CheckDioDummyIsScalar(const Symbol &subp, const Symbol &arg) {
3371
  if (arg.Rank() > 0 || arg.Corank() > 0) {
3372
    messages_.Say(arg.name(),
3373
        "Dummy argument '%s' of a defined input/output procedure"
3374
        " must be a scalar"_err_en_US,
3375
        arg.name());
3376
  }
3377
}
3378

3379
void CheckHelper::CheckDioDtvArg(const Symbol &subp, const Symbol *arg,
3380
    common::DefinedIo ioKind, const Symbol &generic) {
3381
  // Dtv argument looks like: dtv-type-spec, INTENT(INOUT) :: dtv
3382
  if (CheckDioDummyIsData(subp, arg, 0)) {
3383
    CheckDioDummyIsDerived(subp, *arg, ioKind, generic);
3384
    CheckDioDummyAttrs(subp, *arg,
3385
        ioKind == common::DefinedIo::ReadFormatted ||
3386
                ioKind == common::DefinedIo::ReadUnformatted
3387
            ? Attr::INTENT_INOUT
3388
            : Attr::INTENT_IN);
3389
  }
3390
}
3391

3392
// If an explicit INTRINSIC name is a function, so must all the specifics be,
3393
// and similarly for subroutines
3394
void CheckHelper::CheckGenericVsIntrinsic(
3395
    const Symbol &symbol, const GenericDetails &generic) {
3396
  if (symbol.attrs().test(Attr::INTRINSIC)) {
3397
    const evaluate::IntrinsicProcTable &table{
3398
        context_.foldingContext().intrinsics()};
3399
    bool isSubroutine{table.IsIntrinsicSubroutine(symbol.name().ToString())};
3400
    if (isSubroutine || table.IsIntrinsicFunction(symbol.name().ToString())) {
3401
      for (const SymbolRef &ref : generic.specificProcs()) {
3402
        const Symbol &ultimate{ref->GetUltimate()};
3403
        bool specificFunc{ultimate.test(Symbol::Flag::Function)};
3404
        bool specificSubr{ultimate.test(Symbol::Flag::Subroutine)};
3405
        if (!specificFunc && !specificSubr) {
3406
          if (const auto *proc{ultimate.detailsIf<SubprogramDetails>()}) {
3407
            if (proc->isFunction()) {
3408
              specificFunc = true;
3409
            } else {
3410
              specificSubr = true;
3411
            }
3412
          }
3413
        }
3414
        if ((specificFunc || specificSubr) &&
3415
            isSubroutine != specificSubr) { // C848
3416
          messages_.Say(symbol.name(),
3417
              "Generic interface '%s' with explicit intrinsic %s of the same name may not have specific procedure '%s' that is a %s"_err_en_US,
3418
              symbol.name(), isSubroutine ? "subroutine" : "function",
3419
              ref->name(), isSubroutine ? "function" : "subroutine");
3420
        }
3421
      }
3422
    }
3423
  }
3424
}
3425

3426
void CheckHelper::CheckDefaultIntegerArg(
3427
    const Symbol &subp, const Symbol *arg, Attr intent) {
3428
  // Argument looks like: INTEGER, INTENT(intent) :: arg
3429
  if (CheckDioDummyIsData(subp, arg, 1)) {
3430
    CheckDioDummyIsDefaultInteger(subp, *arg);
3431
    CheckDioDummyIsScalar(subp, *arg);
3432
    CheckDioDummyAttrs(subp, *arg, intent);
3433
  }
3434
}
3435

3436
void CheckHelper::CheckDioAssumedLenCharacterArg(const Symbol &subp,
3437
    const Symbol *arg, std::size_t argPosition, Attr intent) {
3438
  // Argument looks like: CHARACTER (LEN=*), INTENT(intent) :: (iotype OR iomsg)
3439
  if (CheckDioDummyIsData(subp, arg, argPosition)) {
3440
    CheckDioDummyAttrs(subp, *arg, intent);
3441
    const DeclTypeSpec *type{arg ? arg->GetType() : nullptr};
3442
    const IntrinsicTypeSpec *intrinsic{type ? type->AsIntrinsic() : nullptr};
3443
    const auto kind{
3444
        intrinsic ? evaluate::ToInt64(intrinsic->kind()) : std::nullopt};
3445
    if (!IsAssumedLengthCharacter(*arg) ||
3446
        (!kind ||
3447
            *kind !=
3448
                context_.defaultKinds().GetDefaultKind(
3449
                    TypeCategory::Character))) {
3450
      messages_.Say(arg->name(),
3451
          "Dummy argument '%s' of a defined input/output procedure"
3452
          " must be assumed-length CHARACTER of default kind"_err_en_US,
3453
          arg->name());
3454
    }
3455
  }
3456
}
3457

3458
void CheckHelper::CheckDioVlistArg(
3459
    const Symbol &subp, const Symbol *arg, std::size_t argPosition) {
3460
  // Vlist argument looks like: INTEGER, INTENT(IN) :: v_list(:)
3461
  if (CheckDioDummyIsData(subp, arg, argPosition)) {
3462
    CheckDioDummyIsDefaultInteger(subp, *arg);
3463
    CheckDioDummyAttrs(subp, *arg, Attr::INTENT_IN);
3464
    const auto *objectDetails{arg->detailsIf<ObjectEntityDetails>()};
3465
    if (!objectDetails || !objectDetails->shape().CanBeDeferredShape()) {
3466
      messages_.Say(arg->name(),
3467
          "Dummy argument '%s' of a defined input/output procedure must be"
3468
          " deferred shape"_err_en_US,
3469
          arg->name());
3470
    }
3471
  }
3472
}
3473

3474
void CheckHelper::CheckDioArgCount(
3475
    const Symbol &subp, common::DefinedIo ioKind, std::size_t argCount) {
3476
  const std::size_t requiredArgCount{
3477
      (std::size_t)(ioKind == common::DefinedIo::ReadFormatted ||
3478
                  ioKind == common::DefinedIo::WriteFormatted
3479
              ? 6
3480
              : 4)};
3481
  if (argCount != requiredArgCount) {
3482
    SayWithDeclaration(subp,
3483
        "Defined input/output procedure '%s' must have"
3484
        " %d dummy arguments rather than %d"_err_en_US,
3485
        subp.name(), requiredArgCount, argCount);
3486
    context_.SetError(subp);
3487
  }
3488
}
3489

3490
void CheckHelper::CheckDioDummyAttrs(
3491
    const Symbol &subp, const Symbol &arg, Attr goodIntent) {
3492
  // Defined I/O procedures can't have attributes other than INTENT
3493
  Attrs attrs{arg.attrs()};
3494
  if (!attrs.test(goodIntent)) {
3495
    messages_.Say(arg.name(),
3496
        "Dummy argument '%s' of a defined input/output procedure"
3497
        " must have intent '%s'"_err_en_US,
3498
        arg.name(), AttrToString(goodIntent));
3499
  }
3500
  attrs = attrs - Attr::INTENT_IN - Attr::INTENT_OUT - Attr::INTENT_INOUT;
3501
  if (!attrs.empty()) {
3502
    messages_.Say(arg.name(),
3503
        "Dummy argument '%s' of a defined input/output procedure may not have"
3504
        " any attributes"_err_en_US,
3505
        arg.name());
3506
  }
3507
}
3508

3509
// Enforce semantics for defined input/output procedures (12.6.4.8.2) and C777
3510
void CheckHelper::CheckDefinedIoProc(const Symbol &symbol,
3511
    const GenericDetails &details, common::DefinedIo ioKind) {
3512
  for (auto ref : details.specificProcs()) {
3513
    const Symbol &ultimate{ref->GetUltimate()};
3514
    const auto *binding{ultimate.detailsIf<ProcBindingDetails>()};
3515
    const Symbol &specific{*(binding ? &binding->symbol() : &ultimate)};
3516
    if (ultimate.attrs().test(Attr::NOPASS)) { // C774
3517
      messages_.Say("Defined input/output procedure '%s' may not have NOPASS "
3518
                    "attribute"_err_en_US,
3519
          ultimate.name());
3520
      context_.SetError(ultimate);
3521
    }
3522
    if (const auto *subpDetails{specific.detailsIf<SubprogramDetails>()}) {
3523
      const std::vector<Symbol *> &dummyArgs{subpDetails->dummyArgs()};
3524
      CheckDioArgCount(specific, ioKind, dummyArgs.size());
3525
      int argCount{0};
3526
      for (auto *arg : dummyArgs) {
3527
        switch (argCount++) {
3528
        case 0:
3529
          // dtv-type-spec, INTENT(INOUT) :: dtv
3530
          CheckDioDtvArg(specific, arg, ioKind, symbol);
3531
          break;
3532
        case 1:
3533
          // INTEGER, INTENT(IN) :: unit
3534
          CheckDefaultIntegerArg(specific, arg, Attr::INTENT_IN);
3535
          break;
3536
        case 2:
3537
          if (ioKind == common::DefinedIo::ReadFormatted ||
3538
              ioKind == common::DefinedIo::WriteFormatted) {
3539
            // CHARACTER (LEN=*), INTENT(IN) :: iotype
3540
            CheckDioAssumedLenCharacterArg(
3541
                specific, arg, argCount, Attr::INTENT_IN);
3542
          } else {
3543
            // INTEGER, INTENT(OUT) :: iostat
3544
            CheckDefaultIntegerArg(specific, arg, Attr::INTENT_OUT);
3545
          }
3546
          break;
3547
        case 3:
3548
          if (ioKind == common::DefinedIo::ReadFormatted ||
3549
              ioKind == common::DefinedIo::WriteFormatted) {
3550
            // INTEGER, INTENT(IN) :: v_list(:)
3551
            CheckDioVlistArg(specific, arg, argCount);
3552
          } else {
3553
            // CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
3554
            CheckDioAssumedLenCharacterArg(
3555
                specific, arg, argCount, Attr::INTENT_INOUT);
3556
          }
3557
          break;
3558
        case 4:
3559
          // INTEGER, INTENT(OUT) :: iostat
3560
          CheckDefaultIntegerArg(specific, arg, Attr::INTENT_OUT);
3561
          break;
3562
        case 5:
3563
          // CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
3564
          CheckDioAssumedLenCharacterArg(
3565
              specific, arg, argCount, Attr::INTENT_INOUT);
3566
          break;
3567
        default:;
3568
        }
3569
      }
3570
    }
3571
  }
3572
}
3573

3574
void CheckHelper::CheckSymbolType(const Symbol &symbol) {
3575
  const Symbol *result{FindFunctionResult(symbol)};
3576
  const Symbol &relevant{result ? *result : symbol};
3577
  if (IsAllocatable(relevant)) { // always ok
3578
  } else if (IsProcedurePointer(symbol) && result && IsPointer(*result)) {
3579
    // procedure pointer returning allocatable or pointer: ok
3580
  } else if (IsPointer(relevant) && !IsProcedure(relevant)) {
3581
    // object pointers are always ok
3582
  } else if (auto dyType{evaluate::DynamicType::From(relevant)}) {
3583
    if (dyType->IsPolymorphic() && !dyType->IsAssumedType() &&
3584
        !(IsDummy(symbol) && !IsProcedure(relevant))) { // C708
3585
      messages_.Say(
3586
          "CLASS entity '%s' must be a dummy argument, allocatable, or object pointer"_err_en_US,
3587
          symbol.name());
3588
    }
3589
    if (dyType->HasDeferredTypeParameter()) { // C702
3590
      messages_.Say(
3591
          "'%s' has a type %s with a deferred type parameter but is neither an allocatable nor an object pointer"_err_en_US,
3592
          symbol.name(), dyType->AsFortran());
3593
    }
3594
  }
3595
}
3596

3597
void CheckHelper::CheckModuleProcedureDef(const Symbol &symbol) {
3598
  auto procClass{ClassifyProcedure(symbol)};
3599
  if (const auto *subprogram{symbol.detailsIf<SubprogramDetails>()};
3600
      subprogram &&
3601
      (procClass == ProcedureDefinitionClass::Module &&
3602
          symbol.attrs().test(Attr::MODULE)) &&
3603
      !subprogram->bindName() && !subprogram->isInterface()) {
3604
    const Symbol &interface {
3605
      subprogram->moduleInterface() ? *subprogram->moduleInterface() : symbol
3606
    };
3607
    if (const Symbol *
3608
            module{interface.owner().kind() == Scope::Kind::Module
3609
                    ? interface.owner().symbol()
3610
                    : nullptr};
3611
        module && module->has<ModuleDetails>()) {
3612
      std::pair<SourceName, const Symbol *> key{symbol.name(), module};
3613
      auto iter{moduleProcs_.find(key)};
3614
      if (iter == moduleProcs_.end()) {
3615
        moduleProcs_.emplace(std::move(key), symbol);
3616
      } else if (
3617
          auto *msg{messages_.Say(symbol.name(),
3618
              "Module procedure '%s' in '%s' has multiple definitions"_err_en_US,
3619
              symbol.name(), GetModuleOrSubmoduleName(*module))}) {
3620
        msg->Attach(iter->second->name(), "Previous definition of '%s'"_en_US,
3621
            symbol.name());
3622
      }
3623
    }
3624
  }
3625
}
3626

3627
void SubprogramMatchHelper::Check(
3628
    const Symbol &symbol1, const Symbol &symbol2) {
3629
  const auto details1{symbol1.get<SubprogramDetails>()};
3630
  const auto details2{symbol2.get<SubprogramDetails>()};
3631
  if (details1.isFunction() != details2.isFunction()) {
3632
    Say(symbol1, symbol2,
3633
        details1.isFunction()
3634
            ? "Module function '%s' was declared as a subroutine in the"
3635
              " corresponding interface body"_err_en_US
3636
            : "Module subroutine '%s' was declared as a function in the"
3637
              " corresponding interface body"_err_en_US);
3638
    return;
3639
  }
3640
  const auto &args1{details1.dummyArgs()};
3641
  const auto &args2{details2.dummyArgs()};
3642
  int nargs1{static_cast<int>(args1.size())};
3643
  int nargs2{static_cast<int>(args2.size())};
3644
  if (nargs1 != nargs2) {
3645
    Say(symbol1, symbol2,
3646
        "Module subprogram '%s' has %d args but the corresponding interface"
3647
        " body has %d"_err_en_US,
3648
        nargs1, nargs2);
3649
    return;
3650
  }
3651
  bool nonRecursive1{symbol1.attrs().test(Attr::NON_RECURSIVE)};
3652
  if (nonRecursive1 != symbol2.attrs().test(Attr::NON_RECURSIVE)) { // C1551
3653
    Say(symbol1, symbol2,
3654
        nonRecursive1
3655
            ? "Module subprogram '%s' has NON_RECURSIVE prefix but"
3656
              " the corresponding interface body does not"_err_en_US
3657
            : "Module subprogram '%s' does not have NON_RECURSIVE prefix but "
3658
              "the corresponding interface body does"_err_en_US);
3659
  }
3660
  const std::string *bindName1{details1.bindName()};
3661
  const std::string *bindName2{details2.bindName()};
3662
  if (!bindName1 && !bindName2) {
3663
    // OK - neither has a binding label
3664
  } else if (!bindName1) {
3665
    Say(symbol1, symbol2,
3666
        "Module subprogram '%s' does not have a binding label but the"
3667
        " corresponding interface body does"_err_en_US);
3668
  } else if (!bindName2) {
3669
    Say(symbol1, symbol2,
3670
        "Module subprogram '%s' has a binding label but the"
3671
        " corresponding interface body does not"_err_en_US);
3672
  } else if (*bindName1 != *bindName2) {
3673
    Say(symbol1, symbol2,
3674
        "Module subprogram '%s' has binding label '%s' but the corresponding"
3675
        " interface body has '%s'"_err_en_US,
3676
        *details1.bindName(), *details2.bindName());
3677
  }
3678
  const Procedure *proc1{checkHelper.Characterize(symbol1)};
3679
  const Procedure *proc2{checkHelper.Characterize(symbol2)};
3680
  if (!proc1 || !proc2) {
3681
    return;
3682
  }
3683
  if (proc1->attrs.test(Procedure::Attr::Pure) !=
3684
      proc2->attrs.test(Procedure::Attr::Pure)) {
3685
    Say(symbol1, symbol2,
3686
        "Module subprogram '%s' and its corresponding interface body are not both PURE"_err_en_US);
3687
  }
3688
  if (proc1->attrs.test(Procedure::Attr::Elemental) !=
3689
      proc2->attrs.test(Procedure::Attr::Elemental)) {
3690
    Say(symbol1, symbol2,
3691
        "Module subprogram '%s' and its corresponding interface body are not both ELEMENTAL"_err_en_US);
3692
  }
3693
  if (proc1->attrs.test(Procedure::Attr::BindC) !=
3694
      proc2->attrs.test(Procedure::Attr::BindC)) {
3695
    Say(symbol1, symbol2,
3696
        "Module subprogram '%s' and its corresponding interface body are not both BIND(C)"_err_en_US);
3697
  }
3698
  if (proc1->functionResult && proc2->functionResult) {
3699
    std::string whyNot;
3700
    if (!proc1->functionResult->IsCompatibleWith(
3701
            *proc2->functionResult, &whyNot)) {
3702
      Say(symbol1, symbol2,
3703
          "Result of function '%s' is not compatible with the result of the corresponding interface body: %s"_err_en_US,
3704
          whyNot);
3705
    }
3706
  }
3707
  for (int i{0}; i < nargs1; ++i) {
3708
    const Symbol *arg1{args1[i]};
3709
    const Symbol *arg2{args2[i]};
3710
    if (arg1 && !arg2) {
3711
      Say(symbol1, symbol2,
3712
          "Dummy argument %2$d of '%1$s' is not an alternate return indicator"
3713
          " but the corresponding argument in the interface body is"_err_en_US,
3714
          i + 1);
3715
    } else if (!arg1 && arg2) {
3716
      Say(symbol1, symbol2,
3717
          "Dummy argument %2$d of '%1$s' is an alternate return indicator but"
3718
          " the corresponding argument in the interface body is not"_err_en_US,
3719
          i + 1);
3720
    } else if (arg1 && arg2) {
3721
      SourceName name1{arg1->name()};
3722
      SourceName name2{arg2->name()};
3723
      if (name1 != name2) {
3724
        Say(*arg1, *arg2,
3725
            "Dummy argument name '%s' does not match corresponding name '%s'"
3726
            " in interface body"_err_en_US,
3727
            name2);
3728
      } else {
3729
        CheckDummyArg(
3730
            *arg1, *arg2, proc1->dummyArguments[i], proc2->dummyArguments[i]);
3731
      }
3732
    }
3733
  }
3734
}
3735

3736
void SubprogramMatchHelper::CheckDummyArg(const Symbol &symbol1,
3737
    const Symbol &symbol2, const DummyArgument &arg1,
3738
    const DummyArgument &arg2) {
3739
  common::visit(
3740
      common::visitors{
3741
          [&](const DummyDataObject &obj1, const DummyDataObject &obj2) {
3742
            CheckDummyDataObject(symbol1, symbol2, obj1, obj2);
3743
          },
3744
          [&](const DummyProcedure &proc1, const DummyProcedure &proc2) {
3745
            CheckDummyProcedure(symbol1, symbol2, proc1, proc2);
3746
          },
3747
          [&](const DummyDataObject &, const auto &) {
3748
            Say(symbol1, symbol2,
3749
                "Dummy argument '%s' is a data object; the corresponding"
3750
                " argument in the interface body is not"_err_en_US);
3751
          },
3752
          [&](const DummyProcedure &, const auto &) {
3753
            Say(symbol1, symbol2,
3754
                "Dummy argument '%s' is a procedure; the corresponding"
3755
                " argument in the interface body is not"_err_en_US);
3756
          },
3757
          [&](const auto &, const auto &) {
3758
            llvm_unreachable("Dummy arguments are not data objects or"
3759
                             "procedures");
3760
          },
3761
      },
3762
      arg1.u, arg2.u);
3763
}
3764

3765
void SubprogramMatchHelper::CheckDummyDataObject(const Symbol &symbol1,
3766
    const Symbol &symbol2, const DummyDataObject &obj1,
3767
    const DummyDataObject &obj2) {
3768
  if (!CheckSameIntent(symbol1, symbol2, obj1.intent, obj2.intent)) {
3769
  } else if (!CheckSameAttrs(symbol1, symbol2, obj1.attrs, obj2.attrs)) {
3770
  } else if (!obj1.type.type().IsEquivalentTo(obj2.type.type())) {
3771
    Say(symbol1, symbol2,
3772
        "Dummy argument '%s' has type %s; the corresponding argument in the interface body has distinct type %s"_err_en_US,
3773
        obj1.type.type().AsFortran(), obj2.type.type().AsFortran());
3774
  } else if (!ShapesAreCompatible(obj1, obj2)) {
3775
    Say(symbol1, symbol2,
3776
        "The shape of dummy argument '%s' does not match the shape of the"
3777
        " corresponding argument in the interface body"_err_en_US);
3778
  }
3779
  // TODO: coshape
3780
}
3781

3782
void SubprogramMatchHelper::CheckDummyProcedure(const Symbol &symbol1,
3783
    const Symbol &symbol2, const DummyProcedure &proc1,
3784
    const DummyProcedure &proc2) {
3785
  if (!CheckSameIntent(symbol1, symbol2, proc1.intent, proc2.intent)) {
3786
  } else if (!CheckSameAttrs(symbol1, symbol2, proc1.attrs, proc2.attrs)) {
3787
  } else if (proc1 != proc2) {
3788
    Say(symbol1, symbol2,
3789
        "Dummy procedure '%s' does not match the corresponding argument in"
3790
        " the interface body"_err_en_US);
3791
  }
3792
}
3793

3794
bool SubprogramMatchHelper::CheckSameIntent(const Symbol &symbol1,
3795
    const Symbol &symbol2, common::Intent intent1, common::Intent intent2) {
3796
  if (intent1 == intent2) {
3797
    return true;
3798
  } else {
3799
    Say(symbol1, symbol2,
3800
        "The intent of dummy argument '%s' does not match the intent"
3801
        " of the corresponding argument in the interface body"_err_en_US);
3802
    return false;
3803
  }
3804
}
3805

3806
// Report an error referring to first symbol with declaration of second symbol
3807
template <typename... A>
3808
void SubprogramMatchHelper::Say(const Symbol &symbol1, const Symbol &symbol2,
3809
    parser::MessageFixedText &&text, A &&...args) {
3810
  auto &message{context().Say(symbol1.name(), std::move(text), symbol1.name(),
3811
      std::forward<A>(args)...)};
3812
  evaluate::AttachDeclaration(message, symbol2);
3813
}
3814

3815
template <typename ATTRS>
3816
bool SubprogramMatchHelper::CheckSameAttrs(
3817
    const Symbol &symbol1, const Symbol &symbol2, ATTRS attrs1, ATTRS attrs2) {
3818
  if (attrs1 == attrs2) {
3819
    return true;
3820
  }
3821
  attrs1.IterateOverMembers([&](auto attr) {
3822
    if (!attrs2.test(attr)) {
3823
      Say(symbol1, symbol2,
3824
          "Dummy argument '%s' has the %s attribute; the corresponding"
3825
          " argument in the interface body does not"_err_en_US,
3826
          AsFortran(attr));
3827
    }
3828
  });
3829
  attrs2.IterateOverMembers([&](auto attr) {
3830
    if (!attrs1.test(attr)) {
3831
      Say(symbol1, symbol2,
3832
          "Dummy argument '%s' does not have the %s attribute; the"
3833
          " corresponding argument in the interface body does"_err_en_US,
3834
          AsFortran(attr));
3835
    }
3836
  });
3837
  return false;
3838
}
3839

3840
bool SubprogramMatchHelper::ShapesAreCompatible(
3841
    const DummyDataObject &obj1, const DummyDataObject &obj2) {
3842
  return characteristics::ShapesAreCompatible(
3843
      FoldShape(obj1.type.shape()), FoldShape(obj2.type.shape()));
3844
}
3845

3846
evaluate::Shape SubprogramMatchHelper::FoldShape(const evaluate::Shape &shape) {
3847
  evaluate::Shape result;
3848
  for (const auto &extent : shape) {
3849
    result.emplace_back(
3850
        evaluate::Fold(context().foldingContext(), common::Clone(extent)));
3851
  }
3852
  return result;
3853
}
3854

3855
void DistinguishabilityHelper::Add(const Symbol &generic, GenericKind kind,
3856
    const Symbol &ultimateSpecific, const Procedure &procedure) {
3857
  if (!context_.HasError(ultimateSpecific)) {
3858
    nameToSpecifics_[generic.name()].emplace(
3859
        &ultimateSpecific, ProcedureInfo{kind, procedure});
3860
  }
3861
}
3862

3863
void DistinguishabilityHelper::Check(const Scope &scope) {
3864
  if (FindModuleFileContaining(scope)) {
3865
    // Distinguishability was checked when the module was created;
3866
    // don't let optional warnings then become errors now.
3867
    return;
3868
  }
3869
  for (const auto &[name, info] : nameToSpecifics_) {
3870
    for (auto iter1{info.begin()}; iter1 != info.end(); ++iter1) {
3871
      const auto &[ultimate, procInfo]{*iter1};
3872
      const auto &[kind, proc]{procInfo};
3873
      for (auto iter2{iter1}; ++iter2 != info.end();) {
3874
        auto distinguishable{kind.IsName()
3875
                ? evaluate::characteristics::Distinguishable
3876
                : evaluate::characteristics::DistinguishableOpOrAssign};
3877
        std::optional<bool> distinct{distinguishable(
3878
            context_.languageFeatures(), proc, iter2->second.procedure)};
3879
        if (!distinct.value_or(false)) {
3880
          SayNotDistinguishable(GetTopLevelUnitContaining(scope), name, kind,
3881
              *ultimate, *iter2->first, distinct.has_value());
3882
        }
3883
      }
3884
    }
3885
  }
3886
}
3887

3888
void DistinguishabilityHelper::SayNotDistinguishable(const Scope &scope,
3889
    const SourceName &name, GenericKind kind, const Symbol &proc1,
3890
    const Symbol &proc2, bool isHardConflict) {
3891
  bool isUseAssociated{!scope.sourceRange().Contains(name)};
3892
  // The rules for distinguishing specific procedures (F'2023 15.4.3.4.5)
3893
  // are inadequate for some real-world cases like pFUnit.
3894
  // When there are optional dummy arguments or unlimited polymorphic
3895
  // dummy data object arguments, the best that we can do is emit an optional
3896
  // portability warning.  Also, named generics created by USE association
3897
  // merging shouldn't receive hard errors for ambiguity.
3898
  // (Non-named generics might be defined I/O procedures or defined
3899
  // assignments that need to be used by the runtime.)
3900
  bool isWarning{!isHardConflict || (isUseAssociated && kind.IsName())};
3901
  if (isWarning &&
3902
      (!context_.ShouldWarn(
3903
           common::LanguageFeature::IndistinguishableSpecifics) ||
3904
          FindModuleFileContaining(scope))) {
3905
    return;
3906
  }
3907
  std::string name1{proc1.name().ToString()};
3908
  std::string name2{proc2.name().ToString()};
3909
  if (kind.IsOperator() || kind.IsAssignment()) {
3910
    // proc1 and proc2 may come from different scopes so qualify their names
3911
    if (proc1.owner().IsDerivedType()) {
3912
      name1 = proc1.owner().GetName()->ToString() + '%' + name1;
3913
    }
3914
    if (proc2.owner().IsDerivedType()) {
3915
      name2 = proc2.owner().GetName()->ToString() + '%' + name2;
3916
    }
3917
  }
3918
  parser::Message *msg;
3919
  if (!isUseAssociated) {
3920
    CHECK(isWarning == !isHardConflict);
3921
    msg = &context_.Say(name,
3922
        isHardConflict
3923
            ? "Generic '%s' may not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_err_en_US
3924
            : "Generic '%s' should not have specific procedures '%s' and '%s' as their interfaces are not distinguishable by the rules in the standard"_port_en_US,
3925
        MakeOpName(name), name1, name2);
3926
  } else {
3927
    msg = &context_.Say(*GetTopLevelUnitContaining(proc1).GetName(),
3928
        isHardConflict
3929
            ? (isWarning
3930
                      ? "USE-associated generic '%s' should not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_warn_en_US
3931
                      : "USE-associated generic '%s' may not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_err_en_US)
3932
            : "USE-associated generic '%s' should not have specific procedures '%s' and '%s' as their interfaces are not distinguishable by the rules in the standard"_port_en_US,
3933
        MakeOpName(name), name1, name2);
3934
  }
3935
  AttachDeclaration(*msg, scope, proc1);
3936
  AttachDeclaration(*msg, scope, proc2);
3937
}
3938

3939
// `evaluate::AttachDeclaration` doesn't handle the generic case where `proc`
3940
// comes from a different module but is not necessarily use-associated.
3941
void DistinguishabilityHelper::AttachDeclaration(
3942
    parser::Message &msg, const Scope &scope, const Symbol &proc) {
3943
  const Scope &unit{GetTopLevelUnitContaining(proc)};
3944
  if (unit == scope) {
3945
    evaluate::AttachDeclaration(msg, proc);
3946
  } else {
3947
    msg.Attach(unit.GetName().value(),
3948
        "'%s' is USE-associated from module '%s'"_en_US, proc.name(),
3949
        unit.GetName().value());
3950
  }
3951
}
3952

3953
void CheckDeclarations(SemanticsContext &context) {
3954
  CheckHelper{context}.Check();
3955
}
3956
} // namespace Fortran::semantics
3957