flang/lib/Semantics/check-declarations.cpp

   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 FeatureOrUsageWarning, typename... A>
 128   parser::Message *Warn(FeatureOrUsageWarning warning, A &&...x) {
 129     if (!context_.ShouldWarn(warning) || InModuleFile()) {
 130       return nullptr;
 131     } else {
 132       return messages_.Say(warning, std::forward<A>(x)...);
 133     }
 134   }
 135   template <typename FeatureOrUsageWarning, typename... A>
 136   parser::Message *Warn(
 137       FeatureOrUsageWarning warning, parser::CharBlock source, A &&...x) {
 138     if (!context_.ShouldWarn(warning) ||
 139         FindModuleFileContaining(context_.FindScope(source))) {
 140       return nullptr;
 141     } else {
 142       return messages_.Say(warning, source, std::forward<A>(x)...);
 143     }
 144   }
 145   bool IsResultOkToDiffer(const FunctionResult &);
 146   void CheckGlobalName(const Symbol &);
 147   void CheckProcedureAssemblyName(const Symbol &symbol);
 148   void CheckExplicitSave(const Symbol &);
 149   parser::Messages WhyNotInteroperableDerivedType(const Symbol &);
 150   parser::Messages WhyNotInteroperableObject(
 151       const Symbol &, bool allowNonInteroperableType = false);
 152   parser::Messages WhyNotInteroperableFunctionResult(const Symbol &);
 153   parser::Messages WhyNotInteroperableProcedure(const Symbol &, bool isError);
 154   void CheckBindC(const Symbol &);
 155   // Check functions for defined I/O procedures
 156   void CheckDefinedIoProc(
 157       const Symbol &, const GenericDetails &, common::DefinedIo);
 158   bool CheckDioDummyIsData(const Symbol &, const Symbol *, std::size_t);
 159   void CheckDioDummyIsDerived(
 160       const Symbol &, const Symbol &, common::DefinedIo ioKind, const Symbol &);
 161   void CheckDioDummyIsDefaultInteger(const Symbol &, const Symbol &);
 162   void CheckDioDummyIsScalar(const Symbol &, const Symbol &);
 163   void CheckDioDummyAttrs(const Symbol &, const Symbol &, Attr);
 164   void CheckDioDtvArg(
 165       const Symbol &, const Symbol *, common::DefinedIo, const Symbol &);
 166   void CheckGenericVsIntrinsic(const Symbol &, const GenericDetails &);
 167   void CheckDefaultIntegerArg(const Symbol &, const Symbol *, Attr);
 168   void CheckDioAssumedLenCharacterArg(
 169       const Symbol &, const Symbol *, std::size_t, Attr);
 170   void CheckDioVlistArg(const Symbol &, const Symbol *, std::size_t);
 171   void CheckDioArgCount(const Symbol &, common::DefinedIo ioKind, std::size_t);
 172   struct TypeWithDefinedIo {
 173     const DerivedTypeSpec &type;
 174     common::DefinedIo ioKind;
 175     const Symbol &proc;
 176     const Symbol &generic;
 177   };
 178   void CheckAlreadySeenDefinedIo(const DerivedTypeSpec &, common::DefinedIo,
 179       const Symbol &, const Symbol &generic);
 180   void CheckModuleProcedureDef(const Symbol &);
 181
 182   SemanticsContext &context_;
 183   evaluate::FoldingContext &foldingContext_{context_.foldingContext()};
 184   parser::ContextualMessages &messages_{foldingContext_.messages()};
 185   const Scope *scope_{nullptr};
 186   bool scopeIsUninstantiatedPDT_{false};
 187   // This symbol is the one attached to the innermost enclosing scope
 188   // that has a symbol.
 189   const Symbol *innermostSymbol_{nullptr};
 190   // Cache of calls to Procedure::Characterize(Symbol)
 191   std::map<SymbolRef, std::optional<Procedure>, SymbolAddressCompare>
 192       characterizeCache_;
 193   // Collection of module procedure symbols with non-BIND(C)
 194   // global names, qualified by their module.
 195   std::map<std::pair<SourceName, const Symbol *>, SymbolRef> moduleProcs_;
 196   // Collection of symbols with global names, BIND(C) or otherwise
 197   std::map<std::string, SymbolRef> globalNames_;
 198   // Collection of external procedures without global definitions
 199   std::map<std::string, SymbolRef> externalNames_;
 200   // Collection of target dependent assembly names of external and BIND(C)
 201   // procedures.
 202   std::map<std::string, SymbolRef> procedureAssemblyNames_;
 203   // Derived types that have been examined by WhyNotInteroperable_XXX
 204   UnorderedSymbolSet examinedByWhyNotInteroperable_;
 205 };
 206
 207 class DistinguishabilityHelper {
 208 public:
 209   DistinguishabilityHelper(SemanticsContext &context) : context_{context} {}
 210   void Add(const Symbol &, GenericKind, const Symbol &, const Procedure &);
 211   void Check(const Scope &);
 212
 213 private:
 214   void SayNotDistinguishable(const Scope &, const SourceName &, GenericKind,
 215       const Symbol &, const Symbol &, bool isHardConflict);
 216   void AttachDeclaration(parser::Message &, const Scope &, const Symbol &);
 217
 218   SemanticsContext &context_;
 219   struct ProcedureInfo {
 220     GenericKind kind;
 221     const Procedure &procedure;
 222   };
 223   std::map<SourceName, std::map<const Symbol *, ProcedureInfo>>
 224       nameToSpecifics_;
 225 };
 226
 227 void CheckHelper::Check(const ParamValue &value, bool canBeAssumed) {
 228   if (value.isAssumed()) {
 229     if (!canBeAssumed) { // C795, C721, C726
 230       messages_.Say(
 231           "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);
 232     }
 233   } else {
 234     CheckSpecExpr(value.GetExplicit(), /*forElementalFunctionResult=*/false);
 235   }
 236 }
 237
 238 void CheckHelper::Check(const ArraySpec &shape) {
 239   for (const auto &spec : shape) {
 240     Check(spec);
 241   }
 242 }
 243
 244 void CheckHelper::Check(
 245     const DeclTypeSpec &type, bool canHaveAssumedTypeParameters) {
 246   if (type.category() == DeclTypeSpec::Character) {
 247     Check(type.characterTypeSpec().length(), canHaveAssumedTypeParameters);
 248   } else if (const DerivedTypeSpec *derived{type.AsDerived()}) {
 249     for (auto &parm : derived->parameters()) {
 250       Check(parm.second, canHaveAssumedTypeParameters);
 251     }
 252   }
 253 }
 254
 255 static bool IsBlockData(const Scope &scope) {
 256   return scope.kind() == Scope::Kind::BlockData;
 257 }
 258
 259 static bool IsBlockData(const Symbol &symbol) {
 260   return symbol.scope() && IsBlockData(*symbol.scope());
 261 }
 262
 263 void CheckHelper::Check(const Symbol &symbol) {
 264   if (symbol.has<UseErrorDetails>()) {
 265     return;
 266   }
 267   if (symbol.name().size() > common::maxNameLen &&
 268       &symbol == &symbol.GetUltimate()) {
 269     Warn(common::LanguageFeature::LongNames, symbol.name(),
 270         "%s has length %d, which is greater than the maximum name length %d"_port_en_US,
 271         symbol.name(), symbol.name().size(), common::maxNameLen);
 272   }
 273   if (context_.HasError(symbol)) {
 274     return;
 275   }
 276   auto restorer{messages_.SetLocation(symbol.name())};
 277   context_.set_location(symbol.name());
 278   const DeclTypeSpec *type{symbol.GetType()};
 279   const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
 280   bool isDone{false};
 281   common::visit(
 282       common::visitors{
 283           [&](const UseDetails &x) { isDone = true; },
 284           [&](const HostAssocDetails &x) {
 285             CheckHostAssoc(symbol, x);
 286             isDone = true;
 287           },
 288           [&](const ProcBindingDetails &x) {
 289             CheckProcBinding(symbol, x);
 290             isDone = true;
 291           },
 292           [&](const ObjectEntityDetails &x) { CheckObjectEntity(symbol, x); },
 293           [&](const ProcEntityDetails &x) { CheckProcEntity(symbol, x); },
 294           [&](const SubprogramDetails &x) { CheckSubprogram(symbol, x); },
 295           [&](const DerivedTypeDetails &x) { CheckDerivedType(symbol, x); },
 296           [&](const GenericDetails &x) { CheckGeneric(symbol, x); },
 297           [](const auto &) {},
 298       },
 299       symbol.details());
 300   if (symbol.attrs().test(Attr::VOLATILE)) {
 301     CheckVolatile(symbol, derived);
 302   }
 303   if (symbol.attrs().test(Attr::BIND_C)) {
 304     CheckBindC(symbol);
 305   }
 306   if (symbol.attrs().test(Attr::SAVE) &&
 307       !symbol.implicitAttrs().test(Attr::SAVE)) {
 308     CheckExplicitSave(symbol);
 309   }
 310   if (symbol.attrs().test(Attr::CONTIGUOUS)) {
 311     CheckContiguous(symbol);
 312   }
 313   CheckGlobalName(symbol);
 314   CheckProcedureAssemblyName(symbol);
 315   if (symbol.attrs().test(Attr::ASYNCHRONOUS) &&
 316       !evaluate::IsVariable(symbol)) {
 317     messages_.Say(
 318         "An entity may not have the ASYNCHRONOUS attribute unless it is a variable"_err_en_US);
 319   }
 320   if (symbol.attrs().HasAny({Attr::INTENT_IN, Attr::INTENT_INOUT,
 321           Attr::INTENT_OUT, Attr::OPTIONAL, Attr::VALUE}) &&
 322       !IsDummy(symbol)) {
 323     if (context_.IsEnabled(
 324             common::LanguageFeature::IgnoreIrrelevantAttributes)) {
 325       context_.Warn(common::LanguageFeature::IgnoreIrrelevantAttributes,
 326           "Only a dummy argument should have an INTENT, VALUE, or OPTIONAL attribute"_warn_en_US);
 327     } else {
 328       messages_.Say(
 329           "Only a dummy argument may have an INTENT, VALUE, or OPTIONAL attribute"_err_en_US);
 330     }
 331   } else if (symbol.attrs().test(Attr::VALUE)) {
 332     CheckValue(symbol, derived);
 333   }
 334
 335   if (isDone) {
 336     return; // following checks do not apply
 337   }
 338
 339   if (symbol.attrs().test(Attr::PROTECTED)) {
 340     if (symbol.owner().kind() != Scope::Kind::Module) { // C854
 341       messages_.Say(
 342           "A PROTECTED entity must be in the specification part of a module"_err_en_US);
 343     }
 344     if (!evaluate::IsVariable(symbol) && !IsProcedurePointer(symbol)) { // C855
 345       messages_.Say(
 346           "A PROTECTED entity must be a variable or pointer"_err_en_US);
 347     }
 348     if (FindCommonBlockContaining(symbol)) { // C856
 349       messages_.Say(
 350           "A PROTECTED entity may not be in a common block"_err_en_US);
 351     }
 352   }
 353   if (IsPointer(symbol)) {
 354     CheckPointer(symbol);
 355   }
 356   if (InPure()) {
 357     if (InInterface()) {
 358       // Declarations in interface definitions "have no effect" if they
 359       // are not pertinent to the characteristics of the procedure.
 360       // Restrictions on entities in pure procedure interfaces don't need
 361       // enforcement.
 362     } else if (!FindCommonBlockContaining(symbol) && IsSaved(symbol)) {
 363       if (IsInitialized(symbol)) {
 364         messages_.Say(
 365             "A pure subprogram may not initialize a variable"_err_en_US);
 366       } else {
 367         messages_.Say(
 368             "A pure subprogram may not have a variable with the SAVE attribute"_err_en_US);
 369       }
 370     }
 371     if (symbol.attrs().test(Attr::VOLATILE) &&
 372         (IsDummy(symbol) || !InInterface())) {
 373       messages_.Say(
 374           "A pure subprogram may not have a variable with the VOLATILE attribute"_err_en_US);
 375     }
 376     if (innermostSymbol_ && innermostSymbol_->name() == "__builtin_c_funloc") {
 377       // The intrinsic procedure C_FUNLOC() gets a pass on this check.
 378     } else if (IsProcedure(symbol) && !IsPureProcedure(symbol) &&
 379         IsDummy(symbol)) {
 380       messages_.Say(
 381           "A dummy procedure of a pure subprogram must be pure"_err_en_US);
 382     }
 383   }
 384   const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
 385   if (type) { // Section 7.2, paragraph 7; C795
 386     bool isChar{type->category() == DeclTypeSpec::Character};
 387     bool canHaveAssumedParameter{(isChar && IsNamedConstant(symbol)) ||
 388         (IsAssumedLengthCharacter(symbol) && // C722
 389             (IsExternal(symbol) ||
 390                 ClassifyProcedure(symbol) ==
 391                     ProcedureDefinitionClass::Dummy)) ||
 392         symbol.test(Symbol::Flag::ParentComp)};
 393     if (!IsStmtFunctionDummy(symbol)) { // C726
 394       if (object) {
 395         canHaveAssumedParameter |= object->isDummy() ||
 396             (isChar && object->isFuncResult()) ||
 397             IsStmtFunctionResult(symbol); // Avoids multiple messages
 398       } else {
 399         canHaveAssumedParameter |= symbol.has<AssocEntityDetails>();
 400       }
 401     }
 402     if (IsProcedurePointer(symbol) && symbol.HasExplicitInterface()) {
 403       // Don't check function result types here
 404     } else {
 405       Check(*type, canHaveAssumedParameter);
 406     }
 407     if (InFunction() && IsFunctionResult(symbol)) {
 408       if (InPure()) {
 409         if (type->IsPolymorphic() && IsAllocatable(symbol)) { // C1585
 410           messages_.Say(
 411               "Result of pure function may not be both polymorphic and ALLOCATABLE"_err_en_US);
 412         }
 413         if (derived) {
 414           // These cases would be caught be the general validation of local
 415           // variables in a pure context, but these messages are more specific.
 416           if (HasImpureFinal(symbol)) { // C1584
 417             messages_.Say(
 418                 "Result of pure function may not have an impure FINAL subroutine"_err_en_US);
 419           }
 420           if (auto bad{
 421                   FindPolymorphicAllocatablePotentialComponent(*derived)}) {
 422             SayWithDeclaration(*bad,
 423                 "Result of pure function may not have polymorphic ALLOCATABLE potential component '%s'"_err_en_US,
 424                 bad.BuildResultDesignatorName());
 425           }
 426         }
 427       }
 428       if (InElemental() && isChar) { // F'2023 C15121
 429         CheckSpecExpr(type->characterTypeSpec().length().GetExplicit(),
 430             /*forElementalFunctionResult=*/true);
 431         // TODO: check PDT LEN parameters
 432       }
 433     }
 434   }
 435   if (IsAssumedLengthCharacter(symbol) && IsFunction(symbol)) { // C723
 436     if (symbol.attrs().test(Attr::RECURSIVE)) {
 437       messages_.Say(
 438           "An assumed-length CHARACTER(*) function cannot be RECURSIVE"_err_en_US);
 439     }
 440     if (symbol.Rank() > 0) {
 441       messages_.Say(
 442           "An assumed-length CHARACTER(*) function cannot return an array"_err_en_US);
 443     }
 444     if (!IsStmtFunction(symbol)) {
 445       if (IsElementalProcedure(symbol)) {
 446         messages_.Say(
 447             "An assumed-length CHARACTER(*) function cannot be ELEMENTAL"_err_en_US);
 448       } else if (IsPureProcedure(symbol)) {
 449         messages_.Say(
 450             "An assumed-length CHARACTER(*) function cannot be PURE"_err_en_US);
 451       }
 452     }
 453     if (const Symbol *result{FindFunctionResult(symbol)}) {
 454       if (IsPointer(*result)) {
 455         messages_.Say(
 456             "An assumed-length CHARACTER(*) function cannot return a POINTER"_err_en_US);
 457       }
 458     }
 459     if (IsProcedurePointer(symbol) && IsDummy(symbol)) {
 460       Warn(common::UsageWarning::Portability,
 461           "A dummy procedure pointer should not have assumed-length CHARACTER(*) result type"_port_en_US);
 462       // The non-dummy case is a hard error that's caught elsewhere.
 463     }
 464   }
 465   if (IsDummy(symbol)) {
 466     if (IsNamedConstant(symbol)) {
 467       messages_.Say(
 468           "A dummy argument may not also be a named constant"_err_en_US);
 469     }
 470   } else if (IsFunctionResult(symbol)) {
 471     if (IsNamedConstant(symbol)) {
 472       messages_.Say(
 473           "A function result may not also be a named constant"_err_en_US);
 474     }
 475   }
 476   if (IsAutomatic(symbol)) {
 477     if (const Symbol * common{FindCommonBlockContaining(symbol)}) {
 478       messages_.Say(
 479           "Automatic data object '%s' may not appear in COMMON block /%s/"_err_en_US,
 480           symbol.name(), common->name());
 481     } else if (symbol.owner().IsModule()) {
 482       messages_.Say(
 483           "Automatic data object '%s' may not appear in a module"_err_en_US,
 484           symbol.name());
 485     } else if (IsBlockData(symbol.owner())) {
 486       messages_.Say(
 487           "Automatic data object '%s' may not appear in a BLOCK DATA subprogram"_err_en_US,
 488           symbol.name());
 489     } else if (symbol.owner().kind() == Scope::Kind::MainProgram) {
 490       if (context_.IsEnabled(common::LanguageFeature::AutomaticInMainProgram)) {
 491         Warn(common::LanguageFeature::AutomaticInMainProgram,
 492             "Automatic data object '%s' should not appear in the specification part of a main program"_port_en_US,
 493             symbol.name());
 494       } else {
 495         messages_.Say(
 496             "Automatic data object '%s' may not appear in the specification part of a main program"_err_en_US,
 497             symbol.name());
 498       }
 499     }
 500   }
 501   if (IsProcedure(symbol)) {
 502     if (IsAllocatable(symbol)) {
 503       messages_.Say(
 504           "Procedure '%s' may not be ALLOCATABLE"_err_en_US, symbol.name());
 505     }
 506     if (!symbol.HasExplicitInterface() && symbol.Rank() > 0) {
 507       messages_.Say(
 508           "Procedure '%s' may not be an array without an explicit interface"_err_en_US,
 509           symbol.name());
 510     }
 511   }
 512 }
 513
 514 void CheckHelper::CheckCommonBlock(const Symbol &symbol) {
 515   CheckGlobalName(symbol);
 516   if (symbol.attrs().test(Attr::BIND_C)) {
 517     CheckBindC(symbol);
 518   }
 519   for (MutableSymbolRef ref : symbol.get<CommonBlockDetails>().objects()) {
 520     if (ref->test(Symbol::Flag::CrayPointee)) {
 521       messages_.Say(ref->name(),
 522           "Cray pointee '%s' may not be a member of a COMMON block"_err_en_US,
 523           ref->name());
 524     }
 525   }
 526 }
 527
 528 // C859, C860
 529 void CheckHelper::CheckExplicitSave(const Symbol &symbol) {
 530   const Symbol &ultimate{symbol.GetUltimate()};
 531   if (ultimate.test(Symbol::Flag::InDataStmt)) {
 532     // checked elsewhere
 533   } else if (symbol.has<UseDetails>()) {
 534     messages_.Say(
 535         "The USE-associated name '%s' may not have an explicit SAVE attribute"_err_en_US,
 536         symbol.name());
 537   } else if (IsDummy(ultimate)) {
 538     messages_.Say(
 539         "The dummy argument '%s' may not have an explicit SAVE attribute"_err_en_US,
 540         symbol.name());
 541   } else if (IsFunctionResult(ultimate)) {
 542     messages_.Say(
 543         "The function result variable '%s' may not have an explicit SAVE attribute"_err_en_US,
 544         symbol.name());
 545   } else if (const Symbol * common{FindCommonBlockContaining(ultimate)}) {
 546     messages_.Say(
 547         "The entity '%s' in COMMON block /%s/ may not have an explicit SAVE attribute"_err_en_US,
 548         symbol.name(), common->name());
 549   } else if (IsAutomatic(ultimate)) {
 550     messages_.Say(
 551         "The automatic object '%s' may not have an explicit SAVE attribute"_err_en_US,
 552         symbol.name());
 553   } else if (!evaluate::IsVariable(ultimate) && !IsProcedurePointer(ultimate)) {
 554     messages_.Say(
 555         "The entity '%s' with an explicit SAVE attribute must be a variable, procedure pointer, or COMMON block"_err_en_US,
 556         symbol.name());
 557   }
 558 }
 559
 560 void CheckHelper::CheckValue(
 561     const Symbol &symbol, const DerivedTypeSpec *derived) { // C863 - C865
 562   if (IsProcedure(symbol)) {
 563     messages_.Say(
 564         "VALUE attribute may apply only to a dummy data object"_err_en_US);
 565     return; // don't pile on
 566   }
 567   if (IsAssumedSizeArray(symbol)) {
 568     messages_.Say(
 569         "VALUE attribute may not apply to an assumed-size array"_err_en_US);
 570   }
 571   if (evaluate::IsCoarray(symbol)) {
 572     messages_.Say("VALUE attribute may not apply to a coarray"_err_en_US);
 573   }
 574   if (IsAllocatable(symbol)) {
 575     messages_.Say("VALUE attribute may not apply to an ALLOCATABLE"_err_en_US);
 576   } else if (IsPointer(symbol)) {
 577     messages_.Say("VALUE attribute may not apply to a POINTER"_err_en_US);
 578   }
 579   if (IsIntentInOut(symbol)) {
 580     messages_.Say(
 581         "VALUE attribute may not apply to an INTENT(IN OUT) argument"_err_en_US);
 582   } else if (IsIntentOut(symbol)) {
 583     messages_.Say(
 584         "VALUE attribute may not apply to an INTENT(OUT) argument"_err_en_US);
 585   }
 586   if (symbol.attrs().test(Attr::VOLATILE)) {
 587     messages_.Say("VALUE attribute may not apply to a VOLATILE"_err_en_US);
 588   }
 589   if (innermostSymbol_ && IsBindCProcedure(*innermostSymbol_)) {
 590     if (IsOptional(symbol)) {
 591       messages_.Say(
 592           "VALUE attribute may not apply to an OPTIONAL in a BIND(C) procedure"_err_en_US);
 593     }
 594     if (symbol.Rank() > 0) {
 595       messages_.Say(
 596           "VALUE attribute may not apply to an array in a BIND(C) procedure"_err_en_US);
 597     }
 598   }
 599   if (derived) {
 600     if (FindCoarrayUltimateComponent(*derived)) {
 601       messages_.Say(
 602           "VALUE attribute may not apply to a type with a coarray ultimate component"_err_en_US);
 603     }
 604   }
 605   if (evaluate::IsAssumedRank(symbol)) {
 606     messages_.Say(
 607         "VALUE attribute may not apply to an assumed-rank array"_err_en_US);
 608   }
 609   if (IsAssumedLengthCharacter(symbol)) {
 610     // F'2008 feature not widely implemented
 611     Warn(common::UsageWarning::Portability,
 612         "VALUE attribute on assumed-length CHARACTER may not be portable"_port_en_US);
 613   }
 614 }
 615
 616 void CheckHelper::CheckAssumedTypeEntity( // C709
 617     const Symbol &symbol, const ObjectEntityDetails &details) {
 618   if (const DeclTypeSpec *type{symbol.GetType()};
 619       type && type->category() == DeclTypeSpec::TypeStar) {
 620     if (!IsDummy(symbol)) {
 621       messages_.Say(
 622           "Assumed-type entity '%s' must be a dummy argument"_err_en_US,
 623           symbol.name());
 624     } else {
 625       if (symbol.attrs().test(Attr::ALLOCATABLE)) {
 626         messages_.Say("Assumed-type argument '%s' cannot have the ALLOCATABLE"
 627                       " attribute"_err_en_US,
 628             symbol.name());
 629       }
 630       if (symbol.attrs().test(Attr::POINTER)) {
 631         messages_.Say("Assumed-type argument '%s' cannot have the POINTER"
 632                       " attribute"_err_en_US,
 633             symbol.name());
 634       }
 635       if (symbol.attrs().test(Attr::VALUE)) {
 636         messages_.Say("Assumed-type argument '%s' cannot have the VALUE"
 637                       " attribute"_err_en_US,
 638             symbol.name());
 639       }
 640       if (symbol.attrs().test(Attr::INTENT_OUT)) {
 641         messages_.Say(
 642             "Assumed-type argument '%s' cannot be INTENT(OUT)"_err_en_US,
 643             symbol.name());
 644       }
 645       if (evaluate::IsCoarray(symbol)) {
 646         messages_.Say(
 647             "Assumed-type argument '%s' cannot be a coarray"_err_en_US,
 648             symbol.name());
 649       }
 650       if (details.IsArray() && details.shape().IsExplicitShape()) {
 651         messages_.Say("Assumed-type array argument '%s' must be assumed shape,"
 652                       " assumed size, or assumed rank"_err_en_US,
 653             symbol.name());
 654       }
 655     }
 656   }
 657 }
 658
 659 void CheckHelper::CheckObjectEntity(
 660     const Symbol &symbol, const ObjectEntityDetails &details) {
 661   CheckSymbolType(symbol);
 662   CheckArraySpec(symbol, details.shape());
 663   CheckConflicting(symbol, Attr::ALLOCATABLE, Attr::PARAMETER);
 664   CheckConflicting(symbol, Attr::ASYNCHRONOUS, Attr::PARAMETER);
 665   CheckConflicting(symbol, Attr::SAVE, Attr::PARAMETER);
 666   CheckConflicting(symbol, Attr::TARGET, Attr::PARAMETER);
 667   CheckConflicting(symbol, Attr::VOLATILE, Attr::PARAMETER);
 668   Check(details.shape());
 669   Check(details.coshape());
 670   if (details.shape().Rank() > common::maxRank) {
 671     messages_.Say(
 672         "'%s' has rank %d, which is greater than the maximum supported rank %d"_err_en_US,
 673         symbol.name(), details.shape().Rank(), common::maxRank);
 674   } else if (details.shape().Rank() + details.coshape().Rank() >
 675       common::maxRank) {
 676     messages_.Say(
 677         "'%s' has rank %d and corank %d, whose sum is greater than the maximum supported rank %d"_err_en_US,
 678         symbol.name(), details.shape().Rank(), details.coshape().Rank(),
 679         common::maxRank);
 680   }
 681   CheckAssumedTypeEntity(symbol, details);
 682   WarnMissingFinal(symbol);
 683   const DeclTypeSpec *type{details.type()};
 684   const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
 685   bool isComponent{symbol.owner().IsDerivedType()};
 686   if (details.coshape().empty()) { // not a coarray
 687     if (!isComponent && !IsPointer(symbol) && derived) {
 688       if (IsEventTypeOrLockType(derived)) {
 689         messages_.Say(
 690             "Variable '%s' with EVENT_TYPE or LOCK_TYPE must be a coarray"_err_en_US,
 691             symbol.name());
 692       } else if (auto component{FindEventOrLockPotentialComponent(
 693                      *derived, /*ignoreCoarrays=*/true)}) {
 694         messages_.Say(
 695             "Variable '%s' with EVENT_TYPE or LOCK_TYPE potential component '%s' must be a coarray"_err_en_US,
 696             symbol.name(), component.BuildResultDesignatorName());
 697       }
 698     }
 699   } else { // it's a coarray
 700     bool isDeferredCoshape{details.coshape().CanBeDeferredShape()};
 701     if (IsAllocatable(symbol)) {
 702       if (!isDeferredCoshape) { // C827
 703         messages_.Say("'%s' is an ALLOCATABLE coarray and must have a deferred"
 704                       " coshape"_err_en_US,
 705             symbol.name());
 706       }
 707     } else if (isComponent) { // C746
 708       std::string deferredMsg{
 709           isDeferredCoshape ? "" : " and have a deferred coshape"};
 710       messages_.Say("Component '%s' is a coarray and must have the ALLOCATABLE"
 711                     " attribute%s"_err_en_US,
 712           symbol.name(), deferredMsg);
 713     } else {
 714       if (!details.coshape().CanBeAssumedSize()) { // C828
 715         messages_.Say(
 716             "'%s' is a non-ALLOCATABLE coarray and must have an explicit coshape"_err_en_US,
 717             symbol.name());
 718       }
 719     }
 720     if (IsBadCoarrayType(derived)) { // C747 & C824
 721       messages_.Say(
 722           "Coarray '%s' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR"_err_en_US,
 723           symbol.name());
 724     }
 725     if (evaluate::IsAssumedRank(symbol)) {
 726       messages_.Say("Coarray '%s' may not be an assumed-rank array"_err_en_US,
 727           symbol.name());
 728     }
 729   }
 730   if (details.isDummy()) {
 731     if (IsIntentOut(symbol)) {
 732       // Some of these errors would also be caught by the general check
 733       // for definability of automatically deallocated local variables,
 734       // but these messages are more specific.
 735       if (FindUltimateComponent(symbol, [](const Symbol &x) {
 736             return evaluate::IsCoarray(x) && IsAllocatable(x);
 737           })) { // C846
 738         messages_.Say(
 739             "An INTENT(OUT) dummy argument may not be, or contain, an ALLOCATABLE coarray"_err_en_US);
 740       }
 741       if (IsOrContainsEventOrLockComponent(symbol)) { // C847
 742         messages_.Say(
 743             "An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE"_err_en_US);
 744       }
 745       if (IsAssumedSizeArray(symbol)) { // C834
 746         if (type && type->IsPolymorphic()) {
 747           messages_.Say(
 748               "An INTENT(OUT) assumed-size dummy argument array may not be polymorphic"_err_en_US);
 749         }
 750         if (derived) {
 751           if (derived->HasDefaultInitialization()) {
 752             messages_.Say(
 753                 "An INTENT(OUT) assumed-size dummy argument array may not have a derived type with any default component initialization"_err_en_US);
 754           }
 755           if (IsFinalizable(*derived)) {
 756             messages_.Say(
 757                 "An INTENT(OUT) assumed-size dummy argument array may not be finalizable"_err_en_US);
 758           }
 759         }
 760       }
 761     }
 762     if (InPure() && !IsStmtFunction(DEREF(innermostSymbol_)) &&
 763         !IsPointer(symbol) && !IsIntentIn(symbol) &&
 764         !symbol.attrs().test(Attr::VALUE)) {
 765       const char *what{InFunction() ? "function" : "subroutine"};
 766       bool ok{true};
 767       if (IsIntentOut(symbol)) {
 768         if (type && type->IsPolymorphic()) { // C1588
 769           messages_.Say(
 770               "An INTENT(OUT) dummy argument of a pure %s may not be polymorphic"_err_en_US,
 771               what);
 772           ok = false;
 773         } else if (derived) {
 774           if (FindUltimateComponent(*derived, [](const Symbol &x) {
 775                 const DeclTypeSpec *type{x.GetType()};
 776                 return type && type->IsPolymorphic();
 777               })) { // C1588
 778             messages_.Say(
 779                 "An INTENT(OUT) dummy argument of a pure %s may not have a polymorphic ultimate component"_err_en_US,
 780                 what);
 781             ok = false;
 782           }
 783           if (HasImpureFinal(symbol)) { // C1587
 784             messages_.Say(
 785                 "An INTENT(OUT) dummy argument of a pure %s may not have an impure FINAL subroutine"_err_en_US,
 786                 what);
 787             ok = false;
 788           }
 789         }
 790       } else if (!IsIntentInOut(symbol)) { // C1586
 791         messages_.Say(
 792             "non-POINTER dummy argument of pure %s must have INTENT() or VALUE attribute"_err_en_US,
 793             what);
 794         ok = false;
 795       }
 796       if (ok && InFunction() && !InModuleFile() && !InElemental()) {
 797         if (context_.IsEnabled(common::LanguageFeature::RelaxedPureDummy)) {
 798           Warn(common::LanguageFeature::RelaxedPureDummy,
 799               "non-POINTER dummy argument of pure function should be INTENT(IN) or VALUE"_warn_en_US);
 800         } else {
 801           messages_.Say(
 802               "non-POINTER dummy argument of pure function must be INTENT(IN) or VALUE"_err_en_US);
 803         }
 804       }
 805     }
 806     if (auto ignoreTKR{GetIgnoreTKR(symbol)}; !ignoreTKR.empty()) {
 807       const Symbol *ownerSymbol{symbol.owner().symbol()};
 808       bool inModuleProc{ownerSymbol && IsModuleProcedure(*ownerSymbol)};
 809       bool inExplicitExternalInterface{
 810           InInterface() && !IsSeparateModuleProcedureInterface(ownerSymbol)};
 811       if (!InInterface() && !inModuleProc) {
 812         messages_.Say(
 813             "!DIR$ IGNORE_TKR may apply only in an interface or a module procedure"_err_en_US);
 814       }
 815       if (ownerSymbol && ownerSymbol->attrs().test(Attr::ELEMENTAL) &&
 816           details.ignoreTKR().test(common::IgnoreTKR::Rank)) {
 817         messages_.Say(
 818             "!DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure"_err_en_US);
 819       }
 820       if (IsPassedViaDescriptor(symbol)) {
 821         if (IsAllocatableOrObjectPointer(&symbol)) {
 822           if (inExplicitExternalInterface) {
 823             Warn(common::UsageWarning::IgnoreTKRUsage,
 824                 "!DIR$ IGNORE_TKR should not apply to an allocatable or pointer"_warn_en_US);
 825           } else {
 826             messages_.Say(
 827                 "!DIR$ IGNORE_TKR may not apply to an allocatable or pointer"_err_en_US);
 828           }
 829         } else if (ignoreTKR.test(common::IgnoreTKR::Rank)) {
 830           if (ignoreTKR.count() == 1 && evaluate::IsAssumedRank(symbol)) {
 831             Warn(common::UsageWarning::IgnoreTKRUsage,
 832                 "!DIR$ IGNORE_TKR(R) is not meaningful for an assumed-rank array"_warn_en_US);
 833           } else if (inExplicitExternalInterface) {
 834             Warn(common::UsageWarning::IgnoreTKRUsage,
 835                 "!DIR$ IGNORE_TKR(R) should not apply to a dummy argument passed via descriptor"_warn_en_US);
 836           } else {
 837             messages_.Say(
 838                 "!DIR$ IGNORE_TKR(R) may not apply to a dummy argument passed via descriptor"_err_en_US);
 839           }
 840         }
 841       }
 842     }
 843   } else if (!details.ignoreTKR().empty()) {
 844     messages_.Say(
 845         "!DIR$ IGNORE_TKR directive may apply only to a dummy data argument"_err_en_US);
 846   }
 847   if (InElemental()) {
 848     if (details.isDummy()) { // C15100
 849       if (details.shape().Rank() > 0) {
 850         messages_.Say(
 851             "A dummy argument of an ELEMENTAL procedure must be scalar"_err_en_US);
 852       }
 853       if (IsAllocatable(symbol)) {
 854         messages_.Say(
 855             "A dummy argument of an ELEMENTAL procedure may not be ALLOCATABLE"_err_en_US);
 856       }
 857       if (evaluate::IsCoarray(symbol)) {
 858         messages_.Say(
 859             "A dummy argument of an ELEMENTAL procedure may not be a coarray"_err_en_US);
 860       }
 861       if (IsPointer(symbol)) {
 862         messages_.Say(
 863             "A dummy argument of an ELEMENTAL procedure may not be a POINTER"_err_en_US);
 864       }
 865       if (!symbol.attrs().HasAny(Attrs{Attr::VALUE, Attr::INTENT_IN,
 866               Attr::INTENT_INOUT, Attr::INTENT_OUT})) { // F'2023 C15120
 867         messages_.Say(
 868             "A dummy argument of an ELEMENTAL procedure must have an INTENT() or VALUE attribute"_err_en_US);
 869       }
 870     } else if (IsFunctionResult(symbol)) { // C15101
 871       if (details.shape().Rank() > 0) {
 872         messages_.Say(
 873             "The result of an ELEMENTAL function must be scalar"_err_en_US);
 874       }
 875       if (IsAllocatable(symbol)) {
 876         messages_.Say(
 877             "The result of an ELEMENTAL function may not be ALLOCATABLE"_err_en_US);
 878       }
 879       if (IsPointer(symbol)) {
 880         messages_.Say(
 881             "The result of an ELEMENTAL function may not be a POINTER"_err_en_US);
 882       }
 883     }
 884   }
 885   if (HasDeclarationInitializer(symbol)) { // C808; ignore DATA initialization
 886     CheckPointerInitialization(symbol);
 887     if (IsAutomatic(symbol)) {
 888       messages_.Say(
 889           "An automatic variable or component must not be initialized"_err_en_US);
 890     } else if (IsDummy(symbol)) {
 891       messages_.Say("A dummy argument must not be initialized"_err_en_US);
 892     } else if (IsFunctionResult(symbol)) {
 893       messages_.Say("A function result must not be initialized"_err_en_US);
 894     } else if (IsInBlankCommon(symbol)) {
 895       Warn(common::LanguageFeature::InitBlankCommon,
 896           "A variable in blank COMMON should not be initialized"_port_en_US);
 897     }
 898   }
 899   if (symbol.owner().kind() == Scope::Kind::BlockData) {
 900     if (IsAllocatable(symbol)) {
 901       messages_.Say(
 902           "An ALLOCATABLE variable may not appear in a BLOCK DATA subprogram"_err_en_US);
 903     } else if (IsInitialized(symbol) && !FindCommonBlockContaining(symbol)) {
 904       messages_.Say(
 905           "An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US);
 906     }
 907   }
 908   if (derived && InPure() && !InInterface() &&
 909       IsAutomaticallyDestroyed(symbol) &&
 910       !IsIntentOut(symbol) /*has better messages*/ &&
 911       !IsFunctionResult(symbol) /*ditto*/) {
 912     // Check automatically deallocated local variables for possible
 913     // problems with finalization in PURE.
 914     if (auto whyNot{
 915             WhyNotDefinable(symbol.name(), symbol.owner(), {}, symbol)}) {
 916       if (auto *msg{messages_.Say(
 917               "'%s' may not be a local variable in a pure subprogram"_err_en_US,
 918               symbol.name())}) {
 919         msg->Attach(std::move(whyNot->set_severity(parser::Severity::Because)));
 920       }
 921     }
 922   }
 923   if (symbol.attrs().test(Attr::EXTERNAL)) {
 924     SayWithDeclaration(symbol,
 925         "'%s' is a data object and may not be EXTERNAL"_err_en_US,
 926         symbol.name());
 927   }
 928
 929   // Check CUDA attributes and special circumstances of being in device
 930   // subprograms
 931   const Scope &progUnit{GetProgramUnitContaining(symbol)};
 932   const auto *subpDetails{!isComponent && progUnit.symbol()
 933           ? progUnit.symbol()->detailsIf<SubprogramDetails>()
 934           : nullptr};
 935   bool inDeviceSubprogram{IsCUDADeviceContext(&symbol.owner())};
 936   if (inDeviceSubprogram) {
 937     if (IsSaved(symbol)) {
 938       Warn(common::UsageWarning::CUDAUsage,
 939           "'%s' should not have the SAVE attribute or initialization in a device subprogram"_warn_en_US,
 940           symbol.name());
 941     }
 942     if (IsPointer(symbol)) {
 943       Warn(common::UsageWarning::CUDAUsage,
 944           "Pointer '%s' may not be associated in a device subprogram"_warn_en_US,
 945           symbol.name());
 946     }
 947     if (details.isDummy() &&
 948         details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=
 949             common::CUDADataAttr::Device &&
 950         details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=
 951             common::CUDADataAttr::Managed &&
 952         details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=
 953             common::CUDADataAttr::Shared) {
 954       Warn(common::UsageWarning::CUDAUsage,
 955           "Dummy argument '%s' may not have ATTRIBUTES(%s) in a device subprogram"_warn_en_US,
 956           symbol.name(),
 957           parser::ToUpperCaseLetters(
 958               common::EnumToString(*details.cudaDataAttr())));
 959     }
 960   }
 961   if (details.cudaDataAttr()) {
 962     if (auto dyType{evaluate::DynamicType::From(symbol)}) {
 963       if (dyType->category() != TypeCategory::Derived) {
 964         if (!IsCUDAIntrinsicType(*dyType)) {
 965           messages_.Say(
 966               "'%s' has intrinsic type '%s' that is not available on the device"_err_en_US,
 967               symbol.name(), dyType->AsFortran());
 968         }
 969       }
 970     }
 971     auto attr{*details.cudaDataAttr()};
 972     switch (attr) {
 973     case common::CUDADataAttr::Constant:
 974       if (subpDetails && !inDeviceSubprogram) {
 975         messages_.Say(
 976             "Object '%s' with ATTRIBUTES(CONSTANT) may not be declared in a host subprogram"_err_en_US,
 977             symbol.name());
 978       } else if (IsAllocatableOrPointer(symbol) ||
 979           symbol.attrs().test(Attr::TARGET)) {
 980         messages_.Say(
 981             "Object '%s' with ATTRIBUTES(CONSTANT) may not be allocatable, pointer, or target"_err_en_US,
 982             symbol.name());
 983       } else if (auto shape{evaluate::GetShape(foldingContext_, symbol)};
 984                  !shape ||
 985                  !evaluate::AsConstantExtents(foldingContext_, *shape)) {
 986         messages_.Say(
 987             "Object '%s' with ATTRIBUTES(CONSTANT) must have constant array bounds"_err_en_US,
 988             symbol.name());
 989       }
 990       break;
 991     case common::CUDADataAttr::Device:
 992       if (isComponent && !IsAllocatable(symbol)) {
 993         messages_.Say(
 994             "Component '%s' with ATTRIBUTES(DEVICE) must also be allocatable"_err_en_US,
 995             symbol.name());
 996       }
 997       break;
 998     case common::CUDADataAttr::Managed:
 999       if (!IsAutomatic(symbol) && !IsAllocatable(symbol) &&
1000           !details.isDummy() && !evaluate::IsExplicitShape(symbol)) {
1001         messages_.Say(
1002             "Object '%s' with ATTRIBUTES(MANAGED) must also be allocatable, automatic, explicit shape, or a dummy argument"_err_en_US,
1003             symbol.name());
1004       }
1005       break;
1006     case common::CUDADataAttr::Pinned:
1007       if (inDeviceSubprogram) {
1008         Warn(common::UsageWarning::CUDAUsage,
1009             "Object '%s' with ATTRIBUTES(PINNED) may not be declared in a device subprogram"_warn_en_US,
1010             symbol.name());
1011       } else if (IsPointer(symbol)) {
1012         Warn(common::UsageWarning::CUDAUsage,
1013             "Object '%s' with ATTRIBUTES(PINNED) may not be a pointer"_warn_en_US,
1014             symbol.name());
1015       } else if (!IsAllocatable(symbol)) {
1016         Warn(common::UsageWarning::CUDAUsage,
1017             "Object '%s' with ATTRIBUTES(PINNED) should also be allocatable"_warn_en_US,
1018             symbol.name());
1019       }
1020       break;
1021     case common::CUDADataAttr::Shared:
1022       if (IsAllocatableOrPointer(symbol) || symbol.attrs().test(Attr::TARGET)) {
1023         messages_.Say(
1024             "Object '%s' with ATTRIBUTES(SHARED) may not be allocatable, pointer, or target"_err_en_US,
1025             symbol.name());
1026       } else if (!inDeviceSubprogram) {
1027         messages_.Say(
1028             "Object '%s' with ATTRIBUTES(SHARED) must be declared in a device subprogram"_err_en_US,
1029             symbol.name());
1030       }
1031       break;
1032     case common::CUDADataAttr::Unified:
1033       if (((!subpDetails &&
1034                symbol.owner().kind() != Scope::Kind::MainProgram) ||
1035               inDeviceSubprogram) &&
1036           !isComponent) {
1037         messages_.Say(
1038             "Object '%s' with ATTRIBUTES(UNIFIED) must be declared in a host subprogram"_err_en_US,
1039             symbol.name());
1040       }
1041       break;
1042     case common::CUDADataAttr::Texture:
1043       messages_.Say(
1044           "ATTRIBUTES(TEXTURE) is obsolete and no longer supported"_err_en_US);
1045       break;
1046     }
1047     if (attr != common::CUDADataAttr::Pinned) {
1048       if (details.commonBlock()) {
1049         messages_.Say(
1050             "Object '%s' with ATTRIBUTES(%s) may not be in COMMON"_err_en_US,
1051             symbol.name(),
1052             parser::ToUpperCaseLetters(common::EnumToString(attr)));
1053       } else if (FindEquivalenceSet(symbol)) {
1054         messages_.Say(
1055             "Object '%s' with ATTRIBUTES(%s) may not be in an equivalence group"_err_en_US,
1056             symbol.name(),
1057             parser::ToUpperCaseLetters(common::EnumToString(attr)));
1058       }
1059     }
1060     if (subpDetails /* not a module variable */ && IsSaved(symbol) &&
1061         !inDeviceSubprogram && !IsAllocatable(symbol) &&
1062         attr == common::CUDADataAttr::Device) {
1063       messages_.Say(
1064           "Saved object '%s' in host code may not have ATTRIBUTES(DEVICE) unless allocatable"_err_en_US,
1065           symbol.name(),
1066           parser::ToUpperCaseLetters(common::EnumToString(attr)));
1067     }
1068     if (isComponent) {
1069       if (attr == common::CUDADataAttr::Device) {
1070         const DeclTypeSpec *type{symbol.GetType()};
1071         if (const DerivedTypeSpec *
1072             derived{type ? type->AsDerived() : nullptr}) {
1073           DirectComponentIterator directs{*derived};
1074           if (auto iter{std::find_if(directs.begin(), directs.end(),
1075                   [](const Symbol &) { return false; })}) {
1076             messages_.Say(
1077                 "Derived type component '%s' may not have ATTRIBUTES(DEVICE) as it has a direct device component '%s'"_err_en_US,
1078                 symbol.name(), iter.BuildResultDesignatorName());
1079           }
1080         }
1081       } else if (attr == common::CUDADataAttr::Constant ||
1082           attr == common::CUDADataAttr::Shared) {
1083         messages_.Say(
1084             "Derived type component '%s' may not have ATTRIBUTES(%s)"_err_en_US,
1085             symbol.name(),
1086             parser::ToUpperCaseLetters(common::EnumToString(attr)));
1087       }
1088     } else if (!subpDetails && symbol.owner().kind() != Scope::Kind::Module &&
1089         symbol.owner().kind() != Scope::Kind::MainProgram &&
1090         symbol.owner().kind() != Scope::Kind::BlockConstruct) {
1091       messages_.Say(
1092           "ATTRIBUTES(%s) may apply only to module, host subprogram, block, or device subprogram data"_err_en_US,
1093           parser::ToUpperCaseLetters(common::EnumToString(attr)));
1094     }
1095   }
1096
1097   if (derived && derived->IsVectorType()) {
1098     CHECK(type);
1099     std::string typeName{type->AsFortran()};
1100     if (IsAssumedShape(symbol)) {
1101       SayWithDeclaration(symbol,
1102           "Assumed-shape entity of %s type is not supported"_err_en_US,
1103           typeName);
1104     } else if (IsDeferredShape(symbol)) {
1105       SayWithDeclaration(symbol,
1106           "Deferred-shape entity of %s type is not supported"_err_en_US,
1107           typeName);
1108     } else if (evaluate::IsAssumedRank(symbol)) {
1109       SayWithDeclaration(symbol,
1110           "Assumed Rank entity of %s type is not supported"_err_en_US,
1111           typeName);
1112     }
1113   }
1114 }
1115
1116 void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
1117   if (IsPointer(symbol) && !context_.HasError(symbol) &&
1118       !scopeIsUninstantiatedPDT_) {
1119     if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
1120       if (object->init()) { // C764, C765; C808
1121         if (auto designator{evaluate::AsGenericExpr(symbol)}) {
1122           auto restorer{messages_.SetLocation(symbol.name())};
1123           context_.set_location(symbol.name());
1124           CheckInitialDataPointerTarget(
1125               context_, *designator, *object->init(), DEREF(scope_));
1126         }
1127       }
1128     } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
1129       if (proc->init() && *proc->init()) {
1130         // C1519 - must be nonelemental external or module procedure,
1131         // or an unrestricted specific intrinsic function.
1132         const Symbol &local{DEREF(*proc->init())};
1133         const Symbol &ultimate{local.GetUltimate()};
1134         bool checkTarget{true};
1135         if (ultimate.attrs().test(Attr::INTRINSIC)) {
1136           if (auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
1137                   ultimate.name().ToString())};
1138               !intrinsic || intrinsic->isRestrictedSpecific) { // C1030
1139             context_.Say(
1140                 "Intrinsic procedure '%s' is not an unrestricted specific "
1141                 "intrinsic permitted for use as the initializer for procedure "
1142                 "pointer '%s'"_err_en_US,
1143                 ultimate.name(), symbol.name());
1144             checkTarget = false;
1145           }
1146         } else if (!(ultimate.attrs().test(Attr::EXTERNAL) ||
1147                        ultimate.owner().kind() == Scope::Kind::Module ||
1148                        ultimate.owner().IsTopLevel()) ||
1149             IsDummy(ultimate) || IsPointer(ultimate)) {
1150           context_.Say(
1151               "Procedure pointer '%s' initializer '%s' is neither an external nor a module procedure"_err_en_US,
1152               symbol.name(), ultimate.name());
1153           checkTarget = false;
1154         } else if (IsElementalProcedure(ultimate)) {
1155           context_.Say("Procedure pointer '%s' cannot be initialized with the "
1156                        "elemental procedure '%s'"_err_en_US,
1157               symbol.name(), ultimate.name());
1158           checkTarget = false;
1159         }
1160         if (checkTarget) {
1161           SomeExpr lhs{evaluate::ProcedureDesignator{symbol}};
1162           SomeExpr rhs{evaluate::ProcedureDesignator{**proc->init()}};
1163           CheckPointerAssignment(context_, lhs, rhs,
1164               GetProgramUnitOrBlockConstructContaining(symbol),
1165               /*isBoundsRemapping=*/false, /*isAssumedRank=*/false);
1166         }
1167       }
1168     }
1169   }
1170 }
1171
1172 // The six different kinds of array-specs:
1173 //   array-spec     -> explicit-shape-list | deferred-shape-list
1174 //                     | assumed-shape-list | implied-shape-list
1175 //                     | assumed-size | assumed-rank
1176 //   explicit-shape -> [ lb : ] ub
1177 //   deferred-shape -> :
1178 //   assumed-shape  -> [ lb ] :
1179 //   implied-shape  -> [ lb : ] *
1180 //   assumed-size   -> [ explicit-shape-list , ] [ lb : ] *
1181 //   assumed-rank   -> ..
1182 // Note:
1183 // - deferred-shape is also an assumed-shape
1184 // - A single "*" or "lb:*" might be assumed-size or implied-shape-list
1185 void CheckHelper::CheckArraySpec(
1186     const Symbol &symbol, const ArraySpec &arraySpec) {
1187   if (arraySpec.Rank() == 0) {
1188     return;
1189   }
1190   bool isExplicit{arraySpec.IsExplicitShape()};
1191   bool canBeDeferred{arraySpec.CanBeDeferredShape()};
1192   bool canBeImplied{arraySpec.CanBeImpliedShape()};
1193   bool canBeAssumedShape{arraySpec.CanBeAssumedShape()};
1194   bool canBeAssumedSize{arraySpec.CanBeAssumedSize()};
1195   bool isAssumedRank{arraySpec.IsAssumedRank()};
1196   bool isCUDAShared{
1197       GetCUDADataAttr(&symbol).value_or(common::CUDADataAttr::Device) ==
1198       common::CUDADataAttr::Shared};
1199   bool isCrayPointee{symbol.test(Symbol::Flag::CrayPointee)};
1200   std::optional<parser::MessageFixedText> msg;
1201   if (isCrayPointee && !isExplicit && !canBeAssumedSize) {
1202     msg =
1203         "Cray pointee '%s' must have explicit shape or assumed size"_err_en_US;
1204   } else if (IsAllocatableOrPointer(symbol) && !canBeDeferred &&
1205       !isAssumedRank) {
1206     if (symbol.owner().IsDerivedType()) { // C745
1207       if (IsAllocatable(symbol)) {
1208         msg = "Allocatable array component '%s' must have"
1209               " deferred shape"_err_en_US;
1210       } else {
1211         msg = "Array pointer component '%s' must have deferred shape"_err_en_US;
1212       }
1213     } else {
1214       if (IsAllocatable(symbol)) { // C832
1215         msg = "Allocatable array '%s' must have deferred shape or"
1216               " assumed rank"_err_en_US;
1217       } else {
1218         msg = "Array pointer '%s' must have deferred shape or"
1219               " assumed rank"_err_en_US;
1220       }
1221     }
1222   } else if (IsDummy(symbol)) {
1223     if (canBeImplied && !canBeAssumedSize) { // C836
1224       msg = "Dummy array argument '%s' may not have implied shape"_err_en_US;
1225     }
1226   } else if (canBeAssumedShape && !canBeDeferred) {
1227     msg = "Assumed-shape array '%s' must be a dummy argument"_err_en_US;
1228   } else if (isAssumedRank) { // C837
1229     msg = "Assumed-rank array '%s' must be a dummy argument"_err_en_US;
1230   } else if (canBeAssumedSize && !canBeImplied && !isCUDAShared &&
1231       !isCrayPointee) { // C833
1232     msg = "Assumed-size array '%s' must be a dummy argument"_err_en_US;
1233   } else if (canBeImplied) {
1234     if (!IsNamedConstant(symbol) && !isCUDAShared &&
1235         !isCrayPointee) { // C835, C836
1236       msg = "Implied-shape array '%s' must be a named constant or a "
1237             "dummy argument"_err_en_US;
1238     }
1239   } else if (IsNamedConstant(symbol)) {
1240     if (!isExplicit && !canBeImplied) {
1241       msg = "Named constant '%s' array must have constant or"
1242             " implied shape"_err_en_US;
1243     }
1244   } else if (!isExplicit &&
1245       !(IsAllocatableOrPointer(symbol) || isCrayPointee)) {
1246     if (symbol.owner().IsDerivedType()) { // C749
1247       msg = "Component array '%s' without ALLOCATABLE or POINTER attribute must"
1248             " have explicit shape"_err_en_US;
1249     } else { // C816
1250       msg = "Array '%s' without ALLOCATABLE or POINTER attribute must have"
1251             " explicit shape"_err_en_US;
1252     }
1253   }
1254   if (msg) {
1255     context_.Say(std::move(*msg), symbol.name());
1256   }
1257 }
1258
1259 void CheckHelper::CheckProcEntity(
1260     const Symbol &symbol, const ProcEntityDetails &details) {
1261   CheckSymbolType(symbol);
1262   const Symbol *interface{details.procInterface()};
1263   if (details.isDummy()) {
1264     if (!symbol.attrs().test(Attr::POINTER) && // C843
1265         symbol.attrs().HasAny(
1266             {Attr::INTENT_IN, Attr::INTENT_OUT, Attr::INTENT_INOUT})) {
1267       messages_.Say("A dummy procedure without the POINTER attribute"
1268                     " may not have an INTENT attribute"_err_en_US);
1269     }
1270     if (InElemental()) { // C15100
1271       messages_.Say(
1272           "An ELEMENTAL subprogram may not have a dummy procedure"_err_en_US);
1273     }
1274     if (interface && IsElementalProcedure(*interface)) {
1275       // There's no explicit constraint or "shall" that we can find in the
1276       // standard for this check, but it seems to be implied in multiple
1277       // sites, and ELEMENTAL non-intrinsic actual arguments *are*
1278       // explicitly forbidden.  But we allow "PROCEDURE(SIN)::dummy"
1279       // because it is explicitly legal to *pass* the specific intrinsic
1280       // function SIN as an actual argument.
1281       if (interface->attrs().test(Attr::INTRINSIC)) {
1282         Warn(common::UsageWarning::Portability,
1283             "A dummy procedure should not have an ELEMENTAL intrinsic as its interface"_port_en_US);
1284       } else {
1285         messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
1286       }
1287     }
1288   } else if (IsPointer(symbol)) {
1289     CheckPointerInitialization(symbol);
1290     if (interface) {
1291       if (interface->attrs().test(Attr::INTRINSIC)) {
1292         auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
1293             interface->name().ToString())};
1294         if (!intrinsic || intrinsic->isRestrictedSpecific) { // C1515
1295           messages_.Say(
1296               "Intrinsic procedure '%s' is not an unrestricted specific "
1297               "intrinsic permitted for use as the definition of the interface "
1298               "to procedure pointer '%s'"_err_en_US,
1299               interface->name(), symbol.name());
1300         } else if (IsElementalProcedure(*interface)) {
1301           Warn(common::UsageWarning::Portability,
1302               "Procedure pointer '%s' should not have an ELEMENTAL intrinsic as its interface"_port_en_US,
1303               symbol.name()); // C1517
1304         }
1305       } else if (IsElementalProcedure(*interface)) {
1306         messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US,
1307             symbol.name()); // C1517
1308       }
1309     }
1310     if (symbol.owner().IsDerivedType()) {
1311       CheckPassArg(symbol, interface, details);
1312     }
1313   } else if (symbol.owner().IsDerivedType()) {
1314     const auto &name{symbol.name()};
1315     messages_.Say(name,
1316         "Procedure component '%s' must have POINTER attribute"_err_en_US, name);
1317   }
1318   CheckExternal(symbol);
1319 }
1320
1321 // When a module subprogram has the MODULE prefix the following must match
1322 // with the corresponding separate module procedure interface body:
1323 // - C1549: characteristics and dummy argument names
1324 // - C1550: binding label
1325 // - C1551: NON_RECURSIVE prefix
1326 class SubprogramMatchHelper {
1327 public:
1328   explicit SubprogramMatchHelper(CheckHelper &checkHelper)
1329       : checkHelper{checkHelper} {}
1330
1331   void Check(const Symbol &, const Symbol &);
1332
1333 private:
1334   SemanticsContext &context() { return checkHelper.context(); }
1335   void CheckDummyArg(const Symbol &, const Symbol &, const DummyArgument &,
1336       const DummyArgument &);
1337   void CheckDummyDataObject(const Symbol &, const Symbol &,
1338       const DummyDataObject &, const DummyDataObject &);
1339   void CheckDummyProcedure(const Symbol &, const Symbol &,
1340       const DummyProcedure &, const DummyProcedure &);
1341   bool CheckSameIntent(
1342       const Symbol &, const Symbol &, common::Intent, common::Intent);
1343   template <typename... A>
1344   void Say(
1345       const Symbol &, const Symbol &, parser::MessageFixedText &&, A &&...);
1346   template <typename ATTRS>
1347   bool CheckSameAttrs(const Symbol &, const Symbol &, ATTRS, ATTRS);
1348   bool ShapesAreCompatible(const DummyDataObject &, const DummyDataObject &);
1349   evaluate::Shape FoldShape(const evaluate::Shape &);
1350   std::optional<evaluate::Shape> FoldShape(
1351       const std::optional<evaluate::Shape> &shape) {
1352     if (shape) {
1353       return FoldShape(*shape);
1354     }
1355     return std::nullopt;
1356   }
1357   std::string AsFortran(DummyDataObject::Attr attr) {
1358     return parser::ToUpperCaseLetters(DummyDataObject::EnumToString(attr));
1359   }
1360   std::string AsFortran(DummyProcedure::Attr attr) {
1361     return parser::ToUpperCaseLetters(DummyProcedure::EnumToString(attr));
1362   }
1363
1364   CheckHelper &checkHelper;
1365 };
1366
1367 // 15.6.2.6 para 3 - can the result of an ENTRY differ from its function?
1368 bool CheckHelper::IsResultOkToDiffer(const FunctionResult &result) {
1369   if (result.attrs.test(FunctionResult::Attr::Allocatable) ||
1370       result.attrs.test(FunctionResult::Attr::Pointer)) {
1371     return false;
1372   }
1373   const auto *typeAndShape{result.GetTypeAndShape()};
1374   if (!typeAndShape || typeAndShape->Rank() != 0) {
1375     return false;
1376   }
1377   auto category{typeAndShape->type().category()};
1378   if (category == TypeCategory::Character ||
1379       category == TypeCategory::Derived) {
1380     return false;
1381   }
1382   int kind{typeAndShape->type().kind()};
1383   return kind == context_.GetDefaultKind(category) ||
1384       (category == TypeCategory::Real &&
1385           kind == context_.doublePrecisionKind());
1386 }
1387
1388 void CheckHelper::CheckSubprogram(
1389     const Symbol &symbol, const SubprogramDetails &details) {
1390   // Evaluate a procedure definition's characteristics to flush out
1391   // any errors that analysis might expose, in case this subprogram hasn't
1392   // had any calls in this compilation unit that would have validated them.
1393   if (!context_.HasError(symbol) && !details.isDummy() &&
1394       !details.isInterface() && !details.stmtFunction()) {
1395     if (!Procedure::Characterize(symbol, foldingContext_)) {
1396       context_.SetError(symbol);
1397     }
1398   }
1399   if (const Symbol *iface{FindSeparateModuleSubprogramInterface(&symbol)}) {
1400     SubprogramMatchHelper{*this}.Check(symbol, *iface);
1401   }
1402   if (const Scope *entryScope{details.entryScope()}) {
1403     // ENTRY F'2023 15.6.2.6
1404     std::optional<parser::MessageFixedText> error;
1405     const Symbol *subprogram{entryScope->symbol()};
1406     const SubprogramDetails *subprogramDetails{nullptr};
1407     if (subprogram) {
1408       subprogramDetails = subprogram->detailsIf<SubprogramDetails>();
1409     }
1410     if (!(entryScope->parent().IsGlobal() || entryScope->parent().IsModule() ||
1411             entryScope->parent().IsSubmodule())) {
1412       error = "ENTRY may not appear in an internal subprogram"_err_en_US;
1413     } else if (subprogramDetails && details.isFunction() &&
1414         subprogramDetails->isFunction() &&
1415         !context_.HasError(details.result()) &&
1416         !context_.HasError(subprogramDetails->result())) {
1417       auto result{FunctionResult::Characterize(
1418           details.result(), context_.foldingContext())};
1419       auto subpResult{FunctionResult::Characterize(
1420           subprogramDetails->result(), context_.foldingContext())};
1421       if (result && subpResult && *result != *subpResult &&
1422           (!IsResultOkToDiffer(*result) || !IsResultOkToDiffer(*subpResult))) {
1423         error =
1424             "Result of ENTRY is not compatible with result of containing function"_err_en_US;
1425       }
1426     }
1427     if (error) {
1428       if (auto *msg{messages_.Say(symbol.name(), *error)}) {
1429         if (subprogram) {
1430           msg->Attach(subprogram->name(), "Containing subprogram"_en_US);
1431         }
1432       }
1433     }
1434   }
1435   if (details.isFunction() &&
1436       details.result().name() != symbol.name()) { // F'2023 C1569 & C1583
1437     if (auto iter{symbol.owner().find(details.result().name())};
1438         iter != symbol.owner().end()) {
1439       const Symbol &resNameSym{*iter->second};
1440       if (const auto *resNameSubp{resNameSym.detailsIf<SubprogramDetails>()}) {
1441         if (const Scope * resNameEntryScope{resNameSubp->entryScope()}) {
1442           const Scope *myScope{
1443               details.entryScope() ? details.entryScope() : symbol.scope()};
1444           if (resNameEntryScope == myScope) {
1445             if (auto *msg{messages_.Say(symbol.name(),
1446                     "Explicit RESULT('%s') of function '%s' cannot have the same name as a distinct ENTRY into the same scope"_err_en_US,
1447                     details.result().name(), symbol.name())}) {
1448               msg->Attach(
1449                   resNameSym.name(), "ENTRY with conflicting name"_en_US);
1450             }
1451           }
1452         }
1453       }
1454     }
1455   }
1456   if (const MaybeExpr & stmtFunction{details.stmtFunction()}) {
1457     if (auto msg{evaluate::CheckStatementFunction(
1458             symbol, *stmtFunction, context_.foldingContext())}) {
1459       SayWithDeclaration(symbol, std::move(*msg));
1460     } else if (IsPointer(symbol)) {
1461       SayWithDeclaration(symbol,
1462           "A statement function must not have the POINTER attribute"_err_en_US);
1463     } else if (details.result().flags().test(Symbol::Flag::Implicit)) {
1464       // 15.6.4 p2 weird requirement
1465       if (const Symbol *
1466           host{symbol.owner().parent().FindSymbol(symbol.name())}) {
1467         evaluate::AttachDeclaration(
1468             Warn(common::LanguageFeature::StatementFunctionExtensions,
1469                 symbol.name(),
1470                 "An implicitly typed statement function should not appear when the same symbol is available in its host scope"_port_en_US),
1471             *host);
1472       }
1473     }
1474     if (GetProgramUnitOrBlockConstructContaining(symbol).kind() ==
1475         Scope::Kind::BlockConstruct) { // C1107
1476       messages_.Say(symbol.name(),
1477           "A statement function definition may not appear in a BLOCK construct"_err_en_US);
1478     }
1479   }
1480   if (IsElementalProcedure(symbol)) {
1481     // See comment on the similar check in CheckProcEntity()
1482     if (details.isDummy()) {
1483       messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
1484     } else {
1485       for (const Symbol *dummy : details.dummyArgs()) {
1486         if (!dummy) { // C15100
1487           messages_.Say(
1488               "An ELEMENTAL subroutine may not have an alternate return dummy argument"_err_en_US);
1489         }
1490       }
1491     }
1492   }
1493   if (details.isInterface()) {
1494     if (!details.isDummy() && details.isFunction() &&
1495         IsAssumedLengthCharacter(details.result())) { // C721
1496       messages_.Say(details.result().name(),
1497           "A function interface may not declare an assumed-length CHARACTER(*) result"_err_en_US);
1498     }
1499   }
1500   CheckExternal(symbol);
1501   CheckModuleProcedureDef(symbol);
1502   auto cudaAttrs{details.cudaSubprogramAttrs()};
1503   if (cudaAttrs &&
1504       (*cudaAttrs == common::CUDASubprogramAttrs::Global ||
1505           *cudaAttrs == common::CUDASubprogramAttrs::Grid_Global) &&
1506       details.isFunction()) {
1507     messages_.Say(symbol.name(),
1508         "A function may not have ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)"_err_en_US);
1509   }
1510   if (cudaAttrs &&
1511       (*cudaAttrs == common::CUDASubprogramAttrs::Global ||
1512           *cudaAttrs == common::CUDASubprogramAttrs::Grid_Global) &&
1513       symbol.attrs().HasAny({Attr::RECURSIVE, Attr::PURE, Attr::ELEMENTAL})) {
1514     messages_.Say(symbol.name(),
1515         "A kernel subprogram may not be RECURSIVE, PURE, or ELEMENTAL"_err_en_US);
1516   }
1517   if (cudaAttrs && *cudaAttrs != common::CUDASubprogramAttrs::Host) {
1518     // CUDA device subprogram checks
1519     if (ClassifyProcedure(symbol) == ProcedureDefinitionClass::Internal) {
1520       messages_.Say(symbol.name(),
1521           "A device subprogram may not be an internal subprogram"_err_en_US);
1522     }
1523   }
1524   if ((!details.cudaLaunchBounds().empty() ||
1525           !details.cudaClusterDims().empty()) &&
1526       !(cudaAttrs &&
1527           (*cudaAttrs == common::CUDASubprogramAttrs::Global ||
1528               *cudaAttrs == common::CUDASubprogramAttrs::Grid_Global))) {
1529     messages_.Say(symbol.name(),
1530         "A subroutine may not have LAUNCH_BOUNDS() or CLUSTER_DIMS() unless it has ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)"_err_en_US);
1531   }
1532   if (!IsStmtFunction(symbol)) {
1533     if (const Scope * outerDevice{FindCUDADeviceContext(&symbol.owner())};
1534         outerDevice && outerDevice->symbol()) {
1535       if (auto *msg{messages_.Say(symbol.name(),
1536               "'%s' may not be an internal procedure of CUDA device subprogram '%s'"_err_en_US,
1537               symbol.name(), outerDevice->symbol()->name())}) {
1538         msg->Attach(outerDevice->symbol()->name(),
1539             "Containing CUDA device subprogram"_en_US);
1540       }
1541     }
1542   }
1543 }
1544
1545 void CheckHelper::CheckExternal(const Symbol &symbol) {
1546   if (IsExternal(symbol)) {
1547     std::string interfaceName{symbol.name().ToString()};
1548     if (const auto *bind{symbol.GetBindName()}) {
1549       interfaceName = *bind;
1550     }
1551     if (const Symbol * global{FindGlobal(symbol)};
1552         global && global != &symbol) {
1553       std::string definitionName{global->name().ToString()};
1554       if (const auto *bind{global->GetBindName()}) {
1555         definitionName = *bind;
1556       }
1557       if (interfaceName == definitionName) {
1558         parser::Message *msg{nullptr};
1559         if (!IsProcedure(*global)) {
1560           if ((symbol.flags().test(Symbol::Flag::Function) ||
1561                   symbol.flags().test(Symbol::Flag::Subroutine))) {
1562             msg = Warn(common::UsageWarning::ExternalNameConflict,
1563                 "The global entity '%s' corresponding to the local procedure '%s' is not a callable subprogram"_warn_en_US,
1564                 global->name(), symbol.name());
1565           }
1566         } else if (auto chars{Characterize(symbol)}) {
1567           if (auto globalChars{Characterize(*global)}) {
1568             if (chars->HasExplicitInterface()) {
1569               std::string whyNot;
1570               if (!chars->IsCompatibleWith(*globalChars,
1571                       /*ignoreImplicitVsExplicit=*/false, &whyNot)) {
1572                 msg = Warn(common::UsageWarning::ExternalInterfaceMismatch,
1573                     "The global subprogram '%s' is not compatible with its local procedure declaration (%s)"_warn_en_US,
1574                     global->name(), whyNot);
1575               }
1576             } else if (!globalChars->CanBeCalledViaImplicitInterface()) {
1577               // TODO: This should be a hard error if the procedure has
1578               // actually been called (as opposed to just being used as a
1579               // procedure pointer target or passed as an actual argument).
1580               msg = Warn(common::UsageWarning::ExternalInterfaceMismatch,
1581                   "The global subprogram '%s' should not be referenced via the implicit interface '%s'"_warn_en_US,
1582                   global->name(), symbol.name());
1583             }
1584           }
1585         }
1586         if (msg) {
1587           if (msg->IsFatal()) {
1588             context_.SetError(symbol);
1589           }
1590           evaluate::AttachDeclaration(msg, *global);
1591           evaluate::AttachDeclaration(msg, symbol);
1592         }
1593       }
1594     } else if (auto iter{externalNames_.find(interfaceName)};
1595                iter != externalNames_.end()) {
1596       const Symbol &previous{*iter->second};
1597       if (auto chars{Characterize(symbol)}) {
1598         if (auto previousChars{Characterize(previous)}) {
1599           std::string whyNot;
1600           if (!chars->IsCompatibleWith(*previousChars,
1601                   /*ignoreImplicitVsExplicit=*/false, &whyNot)) {
1602             if (auto *msg{Warn(common::UsageWarning::ExternalInterfaceMismatch,
1603                     "The external interface '%s' is not compatible with an earlier definition (%s)"_warn_en_US,
1604                     symbol.name(), whyNot)}) {
1605               evaluate::AttachDeclaration(msg, previous);
1606               evaluate::AttachDeclaration(msg, symbol);
1607             }
1608           }
1609         }
1610       }
1611     } else {
1612       externalNames_.emplace(interfaceName, symbol);
1613     }
1614   }
1615 }
1616
1617 void CheckHelper::CheckDerivedType(
1618     const Symbol &derivedType, const DerivedTypeDetails &details) {
1619   if (details.isForwardReferenced() && !context_.HasError(derivedType)) {
1620     messages_.Say("The derived type '%s' has not been defined"_err_en_US,
1621         derivedType.name());
1622   }
1623   const Scope *scope{derivedType.scope()};
1624   if (!scope) {
1625     CHECK(details.isForwardReferenced());
1626     return;
1627   }
1628   CHECK(scope->symbol() == &derivedType);
1629   CHECK(scope->IsDerivedType());
1630   if (derivedType.attrs().test(Attr::ABSTRACT) && // C734
1631       (derivedType.attrs().test(Attr::BIND_C) || details.sequence())) {
1632     messages_.Say("An ABSTRACT derived type must be extensible"_err_en_US);
1633   }
1634   if (const DeclTypeSpec *parent{FindParentTypeSpec(derivedType)}) {
1635     const DerivedTypeSpec *parentDerived{parent->AsDerived()};
1636     if (!IsExtensibleType(parentDerived)) { // C705
1637       messages_.Say("The parent type is not extensible"_err_en_US);
1638     }
1639     if (!derivedType.attrs().test(Attr::ABSTRACT) && parentDerived &&
1640         parentDerived->typeSymbol().attrs().test(Attr::ABSTRACT)) {
1641       ScopeComponentIterator components{*parentDerived};
1642       for (const Symbol &component : components) {
1643         if (component.attrs().test(Attr::DEFERRED)) {
1644           if (scope->FindComponent(component.name()) == &component) {
1645             SayWithDeclaration(component,
1646                 "Non-ABSTRACT extension of ABSTRACT derived type '%s' lacks a binding for DEFERRED procedure '%s'"_err_en_US,
1647                 parentDerived->typeSymbol().name(), component.name());
1648           }
1649         }
1650       }
1651     }
1652     DerivedTypeSpec derived{derivedType.name(), derivedType};
1653     derived.set_scope(*scope);
1654     if (FindCoarrayUltimateComponent(derived) && // C736
1655         !(parentDerived && FindCoarrayUltimateComponent(*parentDerived))) {
1656       messages_.Say(
1657           "Type '%s' has a coarray ultimate component so the type at the base "
1658           "of its type extension chain ('%s') must be a type that has a "
1659           "coarray ultimate component"_err_en_US,
1660           derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name());
1661     }
1662     if (FindEventOrLockPotentialComponent(derived) && // C737
1663         !(FindEventOrLockPotentialComponent(*parentDerived) ||
1664             IsEventTypeOrLockType(parentDerived))) {
1665       messages_.Say(
1666           "Type '%s' has an EVENT_TYPE or LOCK_TYPE component, so the type "
1667           "at the base of its type extension chain ('%s') must either have an "
1668           "EVENT_TYPE or LOCK_TYPE component, or be EVENT_TYPE or "
1669           "LOCK_TYPE"_err_en_US,
1670           derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name());
1671     }
1672   }
1673   if (HasIntrinsicTypeName(derivedType)) { // C729
1674     messages_.Say("A derived type name cannot be the name of an intrinsic"
1675                   " type"_err_en_US);
1676   }
1677   std::map<SourceName, SymbolRef> previous;
1678   for (const auto &pair : details.finals()) {
1679     SourceName source{pair.first};
1680     const Symbol &ref{*pair.second};
1681     if (CheckFinal(ref, source, derivedType) &&
1682         std::all_of(previous.begin(), previous.end(),
1683             [&](std::pair<SourceName, SymbolRef> prev) {
1684               return CheckDistinguishableFinals(
1685                   ref, source, *prev.second, prev.first, derivedType);
1686             })) {
1687       previous.emplace(source, ref);
1688     }
1689   }
1690 }
1691
1692 // C786
1693 bool CheckHelper::CheckFinal(
1694     const Symbol &subroutine, SourceName finalName, const Symbol &derivedType) {
1695   if (!IsModuleProcedure(subroutine)) {
1696     SayWithDeclaration(subroutine, finalName,
1697         "FINAL subroutine '%s' of derived type '%s' must be a module procedure"_err_en_US,
1698         subroutine.name(), derivedType.name());
1699     return false;
1700   }
1701   const Procedure *proc{Characterize(subroutine)};
1702   if (!proc) {
1703     return false; // error recovery
1704   }
1705   if (!proc->IsSubroutine()) {
1706     SayWithDeclaration(subroutine, finalName,
1707         "FINAL subroutine '%s' of derived type '%s' must be a subroutine"_err_en_US,
1708         subroutine.name(), derivedType.name());
1709     return false;
1710   }
1711   if (proc->dummyArguments.size() != 1) {
1712     SayWithDeclaration(subroutine, finalName,
1713         "FINAL subroutine '%s' of derived type '%s' must have a single dummy argument"_err_en_US,
1714         subroutine.name(), derivedType.name());
1715     return false;
1716   }
1717   const auto &arg{proc->dummyArguments[0]};
1718   const Symbol *errSym{&subroutine};
1719   if (const auto *details{subroutine.detailsIf<SubprogramDetails>()}) {
1720     if (!details->dummyArgs().empty()) {
1721       if (const Symbol *argSym{details->dummyArgs()[0]}) {
1722         errSym = argSym;
1723       }
1724     }
1725   }
1726   const auto *ddo{std::get_if<DummyDataObject>(&arg.u)};
1727   if (!ddo) {
1728     SayWithDeclaration(subroutine, finalName,
1729         "FINAL subroutine '%s' of derived type '%s' must have a single dummy argument that is a data object"_err_en_US,
1730         subroutine.name(), derivedType.name());
1731     return false;
1732   }
1733   bool ok{true};
1734   if (arg.IsOptional()) {
1735     SayWithDeclaration(*errSym, finalName,
1736         "FINAL subroutine '%s' of derived type '%s' must not have an OPTIONAL dummy argument"_err_en_US,
1737         subroutine.name(), derivedType.name());
1738     ok = false;
1739   }
1740   if (ddo->attrs.test(DummyDataObject::Attr::Allocatable)) {
1741     SayWithDeclaration(*errSym, finalName,
1742         "FINAL subroutine '%s' of derived type '%s' must not have an ALLOCATABLE dummy argument"_err_en_US,
1743         subroutine.name(), derivedType.name());
1744     ok = false;
1745   }
1746   if (ddo->attrs.test(DummyDataObject::Attr::Pointer)) {
1747     SayWithDeclaration(*errSym, finalName,
1748         "FINAL subroutine '%s' of derived type '%s' must not have a POINTER dummy argument"_err_en_US,
1749         subroutine.name(), derivedType.name());
1750     ok = false;
1751   }
1752   if (ddo->intent == common::Intent::Out) {
1753     SayWithDeclaration(*errSym, finalName,
1754         "FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with INTENT(OUT)"_err_en_US,
1755         subroutine.name(), derivedType.name());
1756     ok = false;
1757   }
1758   if (ddo->attrs.test(DummyDataObject::Attr::Value)) {
1759     SayWithDeclaration(*errSym, finalName,
1760         "FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with the VALUE attribute"_err_en_US,
1761         subroutine.name(), derivedType.name());
1762     ok = false;
1763   }
1764   if (ddo->type.corank() > 0) {
1765     SayWithDeclaration(*errSym, finalName,
1766         "FINAL subroutine '%s' of derived type '%s' must not have a coarray dummy argument"_err_en_US,
1767         subroutine.name(), derivedType.name());
1768     ok = false;
1769   }
1770   if (ddo->type.type().IsPolymorphic()) {
1771     SayWithDeclaration(*errSym, finalName,
1772         "FINAL subroutine '%s' of derived type '%s' must not have a polymorphic dummy argument"_err_en_US,
1773         subroutine.name(), derivedType.name());
1774     ok = false;
1775   } else if (ddo->type.type().category() != TypeCategory::Derived ||
1776       &ddo->type.type().GetDerivedTypeSpec().typeSymbol() != &derivedType) {
1777     SayWithDeclaration(*errSym, finalName,
1778         "FINAL subroutine '%s' of derived type '%s' must have a TYPE(%s) dummy argument"_err_en_US,
1779         subroutine.name(), derivedType.name(), derivedType.name());
1780     ok = false;
1781   } else { // check that all LEN type parameters are assumed
1782     for (auto ref : OrderParameterDeclarations(derivedType)) {
1783       if (IsLenTypeParameter(*ref)) {
1784         const auto *value{
1785             ddo->type.type().GetDerivedTypeSpec().FindParameter(ref->name())};
1786         if (!value || !value->isAssumed()) {
1787           SayWithDeclaration(*errSym, finalName,
1788               "FINAL subroutine '%s' of derived type '%s' must have a dummy argument with an assumed LEN type parameter '%s=*'"_err_en_US,
1789               subroutine.name(), derivedType.name(), ref->name());
1790           ok = false;
1791         }
1792       }
1793     }
1794   }
1795   return ok;
1796 }
1797
1798 bool CheckHelper::CheckDistinguishableFinals(const Symbol &f1,
1799     SourceName f1Name, const Symbol &f2, SourceName f2Name,
1800     const Symbol &derivedType) {
1801   const Procedure *p1{Characterize(f1)};
1802   const Procedure *p2{Characterize(f2)};
1803   if (p1 && p2) {
1804     std::optional<bool> areDistinct{characteristics::Distinguishable(
1805         context_.languageFeatures(), *p1, *p2)};
1806     if (areDistinct.value_or(false)) {
1807       return true;
1808     }
1809     if (auto *msg{messages_.Say(f1Name,
1810             "FINAL subroutines '%s' and '%s' of derived type '%s' cannot be distinguished by rank or KIND type parameter value"_err_en_US,
1811             f1Name, f2Name, derivedType.name())}) {
1812       msg->Attach(f2Name, "FINAL declaration of '%s'"_en_US, f2.name())
1813           .Attach(f1.name(), "Definition of '%s'"_en_US, f1Name)
1814           .Attach(f2.name(), "Definition of '%s'"_en_US, f2Name);
1815     }
1816   }
1817   return false;
1818 }
1819
1820 void CheckHelper::CheckHostAssoc(
1821     const Symbol &symbol, const HostAssocDetails &details) {
1822   const Symbol &hostSymbol{details.symbol()};
1823   if (hostSymbol.test(Symbol::Flag::ImplicitOrError)) {
1824     if (details.implicitOrSpecExprError) {
1825       messages_.Say("Implicitly typed local entity '%s' not allowed in"
1826                     " specification expression"_err_en_US,
1827           symbol.name());
1828     } else if (details.implicitOrExplicitTypeError) {
1829       messages_.Say(
1830           "No explicit type declared for '%s'"_err_en_US, symbol.name());
1831     }
1832   }
1833 }
1834
1835 void CheckHelper::CheckGeneric(
1836     const Symbol &symbol, const GenericDetails &details) {
1837   CheckSpecifics(symbol, details);
1838   common::visit(common::visitors{
1839                     [&](const common::DefinedIo &io) {
1840                       CheckDefinedIoProc(symbol, details, io);
1841                     },
1842                     [&](const GenericKind::OtherKind &other) {
1843                       if (other == GenericKind::OtherKind::Name) {
1844                         CheckGenericVsIntrinsic(symbol, details);
1845                       }
1846                     },
1847                     [](const auto &) {},
1848                 },
1849       details.kind().u);
1850   // Ensure that shadowed symbols are checked
1851   if (details.specific()) {
1852     Check(*details.specific());
1853   }
1854   if (details.derivedType()) {
1855     Check(*details.derivedType());
1856   }
1857 }
1858
1859 // Check that the specifics of this generic are distinguishable from each other
1860 void CheckHelper::CheckSpecifics(
1861     const Symbol &generic, const GenericDetails &details) {
1862   GenericKind kind{details.kind()};
1863   DistinguishabilityHelper helper{context_};
1864   for (const Symbol &specific : details.specificProcs()) {
1865     if (specific.attrs().test(Attr::ABSTRACT)) {
1866       if (auto *msg{messages_.Say(generic.name(),
1867               "Generic interface '%s' must not use abstract interface '%s' as a specific procedure"_err_en_US,
1868               generic.name(), specific.name())}) {
1869         msg->Attach(
1870             specific.name(), "Definition of '%s'"_en_US, specific.name());
1871       }
1872       continue;
1873     }
1874     if (specific.attrs().test(Attr::INTRINSIC)) {
1875       // GNU Fortran allows INTRINSIC procedures in generics.
1876       auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
1877           specific.name().ToString())};
1878       if (intrinsic && !intrinsic->isRestrictedSpecific) {
1879         if (auto *msg{Warn(common::LanguageFeature::IntrinsicAsSpecific,
1880                 specific.name(),
1881                 "Specific procedure '%s' of generic interface '%s' should not be INTRINSIC"_port_en_US,
1882                 specific.name(), generic.name())}) {
1883           msg->Attach(
1884               generic.name(), "Definition of '%s'"_en_US, generic.name());
1885         }
1886       } else {
1887         if (auto *msg{Warn(common::LanguageFeature::IntrinsicAsSpecific,
1888                 specific.name(),
1889                 "Procedure '%s' of generic interface '%s' is INTRINSIC but not an unrestricted specific intrinsic function"_port_en_US,
1890                 specific.name(), generic.name())}) {
1891           msg->Attach(
1892               generic.name(), "Definition of '%s'"_en_US, generic.name());
1893         }
1894         continue;
1895       }
1896     }
1897     if (IsStmtFunction(specific)) {
1898       if (auto *msg{messages_.Say(specific.name(),
1899               "Specific procedure '%s' of generic interface '%s' may not be a statement function"_err_en_US,
1900               specific.name(), generic.name())}) {
1901         msg->Attach(generic.name(), "Definition of '%s'"_en_US, generic.name());
1902       }
1903       continue;
1904     }
1905     if (const Procedure *procedure{Characterize(specific)}) {
1906       if (procedure->HasExplicitInterface()) {
1907         helper.Add(generic, kind, specific, *procedure);
1908       } else {
1909         if (auto *msg{messages_.Say(specific.name(),
1910                 "Specific procedure '%s' of generic interface '%s' must have an explicit interface"_err_en_US,
1911                 specific.name(), generic.name())}) {
1912           msg->Attach(
1913               generic.name(), "Definition of '%s'"_en_US, generic.name());
1914         }
1915       }
1916     }
1917   }
1918   helper.Check(generic.owner());
1919 }
1920
1921 static bool CUDAHostDeviceDiffer(
1922     const Procedure &proc, const DummyDataObject &arg) {
1923   auto procCUDA{
1924       proc.cudaSubprogramAttrs.value_or(common::CUDASubprogramAttrs::Host)};
1925   bool procIsHostOnly{procCUDA == common::CUDASubprogramAttrs::Host};
1926   bool procIsDeviceOnly{
1927       !procIsHostOnly && procCUDA != common::CUDASubprogramAttrs::HostDevice};
1928   const auto &argCUDA{arg.cudaDataAttr};
1929   bool argIsHostOnly{!argCUDA || *argCUDA == common::CUDADataAttr::Pinned};
1930   bool argIsDeviceOnly{(!argCUDA && procIsDeviceOnly) ||
1931       (argCUDA &&
1932           (*argCUDA != common::CUDADataAttr::Managed &&
1933               *argCUDA != common::CUDADataAttr::Pinned &&
1934               *argCUDA != common::CUDADataAttr::Unified))};
1935   return (procIsHostOnly && argIsDeviceOnly) ||
1936       (procIsDeviceOnly && argIsHostOnly);
1937 }
1938
1939 static bool ConflictsWithIntrinsicAssignment(const Procedure &proc) {
1940   const auto &lhsData{std::get<DummyDataObject>(proc.dummyArguments[0].u)};
1941   const auto &lhsTnS{lhsData.type};
1942   const auto &rhsData{std::get<DummyDataObject>(proc.dummyArguments[1].u)};
1943   const auto &rhsTnS{rhsData.type};
1944   return !CUDAHostDeviceDiffer(proc, lhsData) &&
1945       !CUDAHostDeviceDiffer(proc, rhsData) &&
1946       Tristate::No ==
1947       IsDefinedAssignment(
1948           lhsTnS.type(), lhsTnS.Rank(), rhsTnS.type(), rhsTnS.Rank());
1949 }
1950
1951 static bool ConflictsWithIntrinsicOperator(
1952     const GenericKind &kind, const Procedure &proc) {
1953   if (!kind.IsIntrinsicOperator()) {
1954     return false;
1955   }
1956   const auto &arg0Data{std::get<DummyDataObject>(proc.dummyArguments[0].u)};
1957   if (CUDAHostDeviceDiffer(proc, arg0Data)) {
1958     return false;
1959   }
1960   const auto &arg0TnS{arg0Data.type};
1961   auto type0{arg0TnS.type()};
1962   if (proc.dummyArguments.size() == 1) { // unary
1963     return common::visit(
1964         common::visitors{
1965             [&](common::NumericOperator) { return IsIntrinsicNumeric(type0); },
1966             [&](common::LogicalOperator) { return IsIntrinsicLogical(type0); },
1967             [](const auto &) -> bool { DIE("bad generic kind"); },
1968         },
1969         kind.u);
1970   } else { // binary
1971     int rank0{arg0TnS.Rank()};
1972     const auto &arg1Data{std::get<DummyDataObject>(proc.dummyArguments[1].u)};
1973     if (CUDAHostDeviceDiffer(proc, arg1Data)) {
1974       return false;
1975     }
1976     const auto &arg1TnS{arg1Data.type};
1977     auto type1{arg1TnS.type()};
1978     int rank1{arg1TnS.Rank()};
1979     return common::visit(
1980         common::visitors{
1981             [&](common::NumericOperator) {
1982               return IsIntrinsicNumeric(type0, rank0, type1, rank1);
1983             },
1984             [&](common::LogicalOperator) {
1985               return IsIntrinsicLogical(type0, rank0, type1, rank1);
1986             },
1987             [&](common::RelationalOperator opr) {
1988               return IsIntrinsicRelational(opr, type0, rank0, type1, rank1);
1989             },
1990             [&](GenericKind::OtherKind x) {
1991               CHECK(x == GenericKind::OtherKind::Concat);
1992               return IsIntrinsicConcat(type0, rank0, type1, rank1);
1993             },
1994             [](const auto &) -> bool { DIE("bad generic kind"); },
1995         },
1996         kind.u);
1997   }
1998 }
1999
2000 // Check if this procedure can be used for defined operators (see 15.4.3.4.2).
2001 bool CheckHelper::CheckDefinedOperator(SourceName opName, GenericKind kind,
2002     const Symbol &specific, const Procedure &proc) {
2003   if (context_.HasError(specific)) {
2004     return false;
2005   }
2006   std::optional<parser::MessageFixedText> msg;
2007   auto checkDefinedOperatorArgs{
2008       [&](SourceName opName, const Symbol &specific, const Procedure &proc) {
2009         bool arg0Defined{CheckDefinedOperatorArg(opName, specific, proc, 0)};
2010         bool arg1Defined{CheckDefinedOperatorArg(opName, specific, proc, 1)};
2011         return arg0Defined && arg1Defined;
2012       }};
2013   if (specific.attrs().test(Attr::NOPASS)) { // C774
2014     msg = "%s procedure '%s' may not have NOPASS attribute"_err_en_US;
2015   } else if (!proc.functionResult.has_value()) {
2016     msg = "%s procedure '%s' must be a function"_err_en_US;
2017   } else if (proc.functionResult->IsAssumedLengthCharacter()) {
2018     const auto *subpDetails{specific.detailsIf<SubprogramDetails>()};
2019     if (subpDetails && !subpDetails->isDummy() && subpDetails->isInterface()) {
2020       // Error is caught by more general test for interfaces with
2021       // assumed-length character function results
2022       return true;
2023     }
2024     msg = "%s function '%s' may not have assumed-length CHARACTER(*)"
2025           " result"_err_en_US;
2026   } else if (auto m{CheckNumberOfArgs(kind, proc.dummyArguments.size())}) {
2027     if (m->IsFatal()) {
2028       msg = *m;
2029     } else {
2030       evaluate::AttachDeclaration(
2031           Warn(common::UsageWarning::DefinedOperatorArgs, specific.name(),
2032               std::move(*m), MakeOpName(opName), specific.name()),
2033           specific);
2034       return true;
2035     }
2036   } else if (!checkDefinedOperatorArgs(opName, specific, proc)) {
2037     return false; // error was reported
2038   } else if (ConflictsWithIntrinsicOperator(kind, proc)) {
2039     msg = "%s function '%s' conflicts with intrinsic operator"_err_en_US;
2040   }
2041   if (msg) {
2042     SayWithDeclaration(
2043         specific, std::move(*msg), MakeOpName(opName), specific.name());
2044     context_.SetError(specific);
2045     return false;
2046   }
2047   return true;
2048 }
2049
2050 // If the number of arguments is wrong for this intrinsic operator, return
2051 // false and return the error message in msg.
2052 std::optional<parser::MessageFixedText> CheckHelper::CheckNumberOfArgs(
2053     const GenericKind &kind, std::size_t nargs) {
2054   if (!kind.IsIntrinsicOperator()) {
2055     if (nargs < 1 || nargs > 2) {
2056       if (context_.ShouldWarn(common::UsageWarning::DefinedOperatorArgs)) {
2057         return "%s function '%s' should have 1 or 2 dummy arguments"_warn_en_US;
2058       }
2059     }
2060     return std::nullopt;
2061   }
2062   std::size_t min{2}, max{2}; // allowed number of args; default is binary
2063   common::visit(common::visitors{
2064                     [&](const common::NumericOperator &x) {
2065                       if (x == common::NumericOperator::Add ||
2066                           x == common::NumericOperator::Subtract) {
2067                         min = 1; // + and - are unary or binary
2068                       }
2069                     },
2070                     [&](const common::LogicalOperator &x) {
2071                       if (x == common::LogicalOperator::Not) {
2072                         min = 1; // .NOT. is unary
2073                         max = 1;
2074                       }
2075                     },
2076                     [](const common::RelationalOperator &) {
2077                       // all are binary
2078                     },
2079                     [](const GenericKind::OtherKind &x) {
2080                       CHECK(x == GenericKind::OtherKind::Concat);
2081                     },
2082                     [](const auto &) { DIE("expected intrinsic operator"); },
2083                 },
2084       kind.u);
2085   if (nargs >= min && nargs <= max) {
2086     return std::nullopt;
2087   } else if (max == 1) {
2088     return "%s function '%s' must have one dummy argument"_err_en_US;
2089   } else if (min == 2) {
2090     return "%s function '%s' must have two dummy arguments"_err_en_US;
2091   } else {
2092     return "%s function '%s' must have one or two dummy arguments"_err_en_US;
2093   }
2094 }
2095
2096 bool CheckHelper::CheckDefinedOperatorArg(const SourceName &opName,
2097     const Symbol &symbol, const Procedure &proc, std::size_t pos) {
2098   if (pos >= proc.dummyArguments.size()) {
2099     return true;
2100   }
2101   auto &arg{proc.dummyArguments.at(pos)};
2102   std::optional<parser::MessageFixedText> msg;
2103   if (arg.IsOptional()) {
2104     msg =
2105         "In %s function '%s', dummy argument '%s' may not be OPTIONAL"_err_en_US;
2106   } else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)};
2107              dataObject == nullptr) {
2108     msg =
2109         "In %s function '%s', dummy argument '%s' must be a data object"_err_en_US;
2110   } else if (dataObject->intent == common::Intent::Out) {
2111     msg =
2112         "In %s function '%s', dummy argument '%s' may not be INTENT(OUT)"_err_en_US;
2113   } else if (dataObject->intent != common::Intent::In &&
2114       !dataObject->attrs.test(DummyDataObject::Attr::Value)) {
2115     evaluate::AttachDeclaration(
2116         Warn(common::UsageWarning::DefinedOperatorArgs,
2117             "In %s function '%s', dummy argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US,
2118             parser::ToUpperCaseLetters(opName.ToString()), symbol.name(),
2119             arg.name),
2120         symbol);
2121     return true;
2122   }
2123   if (msg) {
2124     SayWithDeclaration(symbol, std::move(*msg),
2125         parser::ToUpperCaseLetters(opName.ToString()), symbol.name(), arg.name);
2126     return false;
2127   }
2128   return true;
2129 }
2130
2131 // Check if this procedure can be used for defined assignment (see 15.4.3.4.3).
2132 bool CheckHelper::CheckDefinedAssignment(
2133     const Symbol &specific, const Procedure &proc) {
2134   if (context_.HasError(specific)) {
2135     return false;
2136   }
2137   std::optional<parser::MessageFixedText> msg;
2138   if (specific.attrs().test(Attr::NOPASS)) { // C774
2139     msg = "Defined assignment procedure '%s' may not have"
2140           " NOPASS attribute"_err_en_US;
2141   } else if (!proc.IsSubroutine()) {
2142     msg = "Defined assignment procedure '%s' must be a subroutine"_err_en_US;
2143   } else if (proc.dummyArguments.size() != 2) {
2144     msg = "Defined assignment subroutine '%s' must have"
2145           " two dummy arguments"_err_en_US;
2146   } else {
2147     // Check both arguments even if the first has an error.
2148     bool ok0{CheckDefinedAssignmentArg(specific, proc.dummyArguments[0], 0)};
2149     bool ok1{CheckDefinedAssignmentArg(specific, proc.dummyArguments[1], 1)};
2150     if (!(ok0 && ok1)) {
2151       return false; // error was reported
2152     } else if (ConflictsWithIntrinsicAssignment(proc)) {
2153       msg =
2154           "Defined assignment subroutine '%s' conflicts with intrinsic assignment"_err_en_US;
2155     } else {
2156       return true; // OK
2157     }
2158   }
2159   SayWithDeclaration(specific, std::move(msg.value()), specific.name());
2160   context_.SetError(specific);
2161   return false;
2162 }
2163
2164 bool CheckHelper::CheckDefinedAssignmentArg(
2165     const Symbol &symbol, const DummyArgument &arg, int pos) {
2166   std::optional<parser::MessageFixedText> msg;
2167   if (arg.IsOptional()) {
2168     msg = "In defined assignment subroutine '%s', dummy argument '%s'"
2169           " may not be OPTIONAL"_err_en_US;
2170   } else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)}) {
2171     if (pos == 0) {
2172       if (dataObject->intent == common::Intent::In) {
2173         msg = "In defined assignment subroutine '%s', first dummy argument '%s'"
2174               " may not have INTENT(IN)"_err_en_US;
2175       } else if (dataObject->intent != common::Intent::Out &&
2176           dataObject->intent != common::Intent::InOut) {
2177         msg =
2178             "In defined assignment subroutine '%s', first dummy argument '%s' should have INTENT(OUT) or INTENT(INOUT)"_warn_en_US;
2179       }
2180     } else if (pos == 1) {
2181       if (dataObject->intent == common::Intent::Out) {
2182         msg = "In defined assignment subroutine '%s', second dummy"
2183               " argument '%s' may not have INTENT(OUT)"_err_en_US;
2184       } else if (dataObject->intent != common::Intent::In &&
2185           !dataObject->attrs.test(DummyDataObject::Attr::Value)) {
2186         msg =
2187             "In defined assignment subroutine '%s', second dummy argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US;
2188       } else if (dataObject->attrs.test(DummyDataObject::Attr::Pointer)) {
2189         msg =
2190             "In defined assignment subroutine '%s', second dummy argument '%s' must not be a pointer"_err_en_US;
2191       } else if (dataObject->attrs.test(DummyDataObject::Attr::Allocatable)) {
2192         msg =
2193             "In defined assignment subroutine '%s', second dummy argument '%s' must not be an allocatable"_err_en_US;
2194       }
2195     } else {
2196       DIE("pos must be 0 or 1");
2197     }
2198   } else {
2199     msg = "In defined assignment subroutine '%s', dummy argument '%s'"
2200           " must be a data object"_err_en_US;
2201   }
2202   if (msg) {
2203     if (msg->IsFatal()) {
2204       SayWithDeclaration(symbol, std::move(*msg), symbol.name(), arg.name);
2205       context_.SetError(symbol);
2206       return false;
2207     } else {
2208       evaluate::AttachDeclaration(
2209           Warn(common::UsageWarning::DefinedOperatorArgs, std::move(*msg),
2210               symbol.name(), arg.name),
2211           symbol);
2212     }
2213   }
2214   return true;
2215 }
2216
2217 // Report a conflicting attribute error if symbol has both of these attributes
2218 bool CheckHelper::CheckConflicting(const Symbol &symbol, Attr a1, Attr a2) {
2219   if (symbol.attrs().test(a1) && symbol.attrs().test(a2)) {
2220     messages_.Say("'%s' may not have both the %s and %s attributes"_err_en_US,
2221         symbol.name(), AttrToString(a1), AttrToString(a2));
2222     return true;
2223   } else {
2224     return false;
2225   }
2226 }
2227
2228 void CheckHelper::WarnMissingFinal(const Symbol &symbol) {
2229   const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
2230   if (!object || object->IsAssumedRank() ||
2231       (!IsAutomaticallyDestroyed(symbol) &&
2232           symbol.owner().kind() != Scope::Kind::DerivedType)) {
2233     return;
2234   }
2235   const DeclTypeSpec *type{object->type()};
2236   const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
2237   const Symbol *derivedSym{derived ? &derived->typeSymbol() : nullptr};
2238   int rank{object->shape().Rank()};
2239   const Symbol *initialDerivedSym{derivedSym};
2240   while (const auto *derivedDetails{
2241       derivedSym ? derivedSym->detailsIf<DerivedTypeDetails>() : nullptr}) {
2242     if (!derivedDetails->finals().empty() &&
2243         !derivedDetails->GetFinalForRank(rank)) {
2244       if (auto *msg{derivedSym == initialDerivedSym
2245                   ? Warn(common::UsageWarning::Final, symbol.name(),
2246                         "'%s' of derived type '%s' does not have a FINAL subroutine for its rank (%d)"_warn_en_US,
2247                         symbol.name(), derivedSym->name(), rank)
2248                   : Warn(common::UsageWarning::Final, symbol.name(),
2249                         "'%s' of derived type '%s' extended from '%s' does not have a FINAL subroutine for its rank (%d)"_warn_en_US,
2250                         symbol.name(), initialDerivedSym->name(),
2251                         derivedSym->name(), rank)}) {
2252         msg->Attach(derivedSym->name(),
2253             "Declaration of derived type '%s'"_en_US, derivedSym->name());
2254       }
2255       return;
2256     }
2257     derived = derivedSym->GetParentTypeSpec();
2258     derivedSym = derived ? &derived->typeSymbol() : nullptr;
2259   }
2260 }
2261
2262 const Procedure *CheckHelper::Characterize(const Symbol &symbol) {
2263   auto it{characterizeCache_.find(symbol)};
2264   if (it == characterizeCache_.end()) {
2265     auto pair{characterizeCache_.emplace(SymbolRef{symbol},
2266         Procedure::Characterize(symbol, context_.foldingContext()))};
2267     it = pair.first;
2268   }
2269   return common::GetPtrFromOptional(it->second);
2270 }
2271
2272 void CheckHelper::CheckVolatile(const Symbol &symbol,
2273     const DerivedTypeSpec *derived) { // C866 - C868
2274   if (IsIntentIn(symbol)) {
2275     messages_.Say(
2276         "VOLATILE attribute may not apply to an INTENT(IN) argument"_err_en_US);
2277   }
2278   if (IsProcedure(symbol)) {
2279     messages_.Say("VOLATILE attribute may apply only to a variable"_err_en_US);
2280   }
2281   if (symbol.has<UseDetails>() || symbol.has<HostAssocDetails>()) {
2282     const Symbol &ultimate{symbol.GetUltimate()};
2283     if (evaluate::IsCoarray(ultimate)) {
2284       messages_.Say(
2285           "VOLATILE attribute may not apply to a coarray accessed by USE or host association"_err_en_US);
2286     }
2287     if (derived) {
2288       if (FindCoarrayUltimateComponent(*derived)) {
2289         messages_.Say(
2290             "VOLATILE attribute may not apply to a type with a coarray ultimate component accessed by USE or host association"_err_en_US);
2291       }
2292     }
2293   }
2294 }
2295
2296 void CheckHelper::CheckContiguous(const Symbol &symbol) {
2297   if (evaluate::IsVariable(symbol) &&
2298       ((IsPointer(symbol) && symbol.Rank() > 0) || IsAssumedShape(symbol) ||
2299           evaluate::IsAssumedRank(symbol))) {
2300   } else {
2301     parser::MessageFixedText msg{symbol.owner().IsDerivedType()
2302             ? "CONTIGUOUS component '%s' should be an array with the POINTER attribute"_port_en_US
2303             : "CONTIGUOUS entity '%s' should be an array pointer, assumed-shape, or assumed-rank"_port_en_US};
2304     if (!context_.IsEnabled(common::LanguageFeature::RedundantContiguous)) {
2305       msg.set_severity(parser::Severity::Error);
2306       messages_.Say(std::move(msg), symbol.name());
2307     } else {
2308       Warn(common::LanguageFeature::RedundantContiguous, std::move(msg),
2309           symbol.name());
2310     }
2311   }
2312 }
2313
2314 void CheckHelper::CheckPointer(const Symbol &symbol) { // C852
2315   CheckConflicting(symbol, Attr::POINTER, Attr::TARGET);
2316   CheckConflicting(symbol, Attr::POINTER, Attr::ALLOCATABLE); // C751
2317   CheckConflicting(symbol, Attr::POINTER, Attr::INTRINSIC);
2318   // Prohibit constant pointers.  The standard does not explicitly prohibit
2319   // them, but the PARAMETER attribute requires a entity-decl to have an
2320   // initialization that is a constant-expr, and the only form of
2321   // initialization that allows a constant-expr is the one that's not a "=>"
2322   // pointer initialization.  See C811, C807, and section 8.5.13.
2323   CheckConflicting(symbol, Attr::POINTER, Attr::PARAMETER);
2324   if (symbol.Corank() > 0) {
2325     messages_.Say(
2326         "'%s' may not have the POINTER attribute because it is a coarray"_err_en_US,
2327         symbol.name());
2328   }
2329 }
2330
2331 // C760 constraints on the passed-object dummy argument
2332 // C757 constraints on procedure pointer components
2333 void CheckHelper::CheckPassArg(
2334     const Symbol &proc, const Symbol *interface0, const WithPassArg &details) {
2335   if (proc.attrs().test(Attr::NOPASS)) {
2336     return;
2337   }
2338   const auto &name{proc.name()};
2339   const Symbol *interface {
2340     interface0 ? FindInterface(*interface0) : nullptr
2341   };
2342   if (!interface) {
2343     messages_.Say(name,
2344         "Procedure component '%s' must have NOPASS attribute or explicit interface"_err_en_US,
2345         name);
2346     return;
2347   }
2348   const auto *subprogram{interface->detailsIf<SubprogramDetails>()};
2349   if (!subprogram) {
2350     messages_.Say(name,
2351         "Procedure component '%s' has invalid interface '%s'"_err_en_US, name,
2352         interface->name());
2353     return;
2354   }
2355   std::optional<SourceName> passName{details.passName()};
2356   const auto &dummyArgs{subprogram->dummyArgs()};
2357   if (!passName) {
2358     if (dummyArgs.empty()) {
2359       messages_.Say(name,
2360           proc.has<ProcEntityDetails>()
2361               ? "Procedure component '%s' with no dummy arguments"
2362                 " must have NOPASS attribute"_err_en_US
2363               : "Procedure binding '%s' with no dummy arguments"
2364                 " must have NOPASS attribute"_err_en_US,
2365           name);
2366       context_.SetError(*interface);
2367       return;
2368     }
2369     Symbol *argSym{dummyArgs[0]};
2370     if (!argSym) {
2371       messages_.Say(interface->name(),
2372           "Cannot use an alternate return as the passed-object dummy "
2373           "argument"_err_en_US);
2374       return;
2375     }
2376     passName = dummyArgs[0]->name();
2377   }
2378   std::optional<int> passArgIndex{};
2379   for (std::size_t i{0}; i < dummyArgs.size(); ++i) {
2380     if (dummyArgs[i] && dummyArgs[i]->name() == *passName) {
2381       passArgIndex = i;
2382       break;
2383     }
2384   }
2385   if (!passArgIndex) { // C758
2386     messages_.Say(*passName,
2387         "'%s' is not a dummy argument of procedure interface '%s'"_err_en_US,
2388         *passName, interface->name());
2389     return;
2390   }
2391   const Symbol &passArg{*dummyArgs[*passArgIndex]};
2392   std::optional<parser::MessageFixedText> msg;
2393   if (!passArg.has<ObjectEntityDetails>()) {
2394     msg = "Passed-object dummy argument '%s' of procedure '%s'"
2395           " must be a data object"_err_en_US;
2396   } else if (passArg.attrs().test(Attr::POINTER)) {
2397     msg = "Passed-object dummy argument '%s' of procedure '%s'"
2398           " may not have the POINTER attribute"_err_en_US;
2399   } else if (passArg.attrs().test(Attr::ALLOCATABLE)) {
2400     msg = "Passed-object dummy argument '%s' of procedure '%s'"
2401           " may not have the ALLOCATABLE attribute"_err_en_US;
2402   } else if (passArg.attrs().test(Attr::VALUE)) {
2403     msg = "Passed-object dummy argument '%s' of procedure '%s'"
2404           " may not have the VALUE attribute"_err_en_US;
2405   } else if (passArg.Rank() > 0) {
2406     msg = "Passed-object dummy argument '%s' of procedure '%s'"
2407           " must be scalar"_err_en_US;
2408   }
2409   if (msg) {
2410     messages_.Say(name, std::move(*msg), passName.value(), name);
2411     return;
2412   }
2413   const DeclTypeSpec *type{passArg.GetType()};
2414   if (!type) {
2415     return; // an error already occurred
2416   }
2417   const Symbol &typeSymbol{*proc.owner().GetSymbol()};
2418   const DerivedTypeSpec *derived{type->AsDerived()};
2419   if (!derived || derived->typeSymbol() != typeSymbol) {
2420     messages_.Say(name,
2421         "Passed-object dummy argument '%s' of procedure '%s'"
2422         " must be of type '%s' but is '%s'"_err_en_US,
2423         passName.value(), name, typeSymbol.name(), type->AsFortran());
2424     return;
2425   }
2426   if (IsExtensibleType(derived) != type->IsPolymorphic()) {
2427     messages_.Say(name,
2428         type->IsPolymorphic()
2429             ? "Passed-object dummy argument '%s' of procedure '%s'"
2430               " may not be polymorphic because '%s' is not extensible"_err_en_US
2431             : "Passed-object dummy argument '%s' of procedure '%s'"
2432               " must be polymorphic because '%s' is extensible"_err_en_US,
2433         passName.value(), name, typeSymbol.name());
2434     return;
2435   }
2436   for (const auto &[paramName, paramValue] : derived->parameters()) {
2437     if (paramValue.isLen() && !paramValue.isAssumed()) {
2438       messages_.Say(name,
2439           "Passed-object dummy argument '%s' of procedure '%s'"
2440           " has non-assumed length parameter '%s'"_err_en_US,
2441           passName.value(), name, paramName);
2442     }
2443   }
2444 }
2445
2446 void CheckHelper::CheckProcBinding(
2447     const Symbol &symbol, const ProcBindingDetails &binding) {
2448   const Scope &dtScope{symbol.owner()};
2449   CHECK(dtScope.kind() == Scope::Kind::DerivedType);
2450   if (symbol.attrs().test(Attr::DEFERRED)) {
2451     if (const Symbol *dtSymbol{dtScope.symbol()}) {
2452       if (!dtSymbol->attrs().test(Attr::ABSTRACT)) { // C733
2453         SayWithDeclaration(*dtSymbol,
2454             "Procedure bound to non-ABSTRACT derived type '%s' may not be DEFERRED"_err_en_US,
2455             dtSymbol->name());
2456       }
2457     }
2458     if (symbol.attrs().test(Attr::NON_OVERRIDABLE)) {
2459       messages_.Say(
2460           "Type-bound procedure '%s' may not be both DEFERRED and NON_OVERRIDABLE"_err_en_US,
2461           symbol.name());
2462     }
2463   }
2464   if (binding.symbol().attrs().test(Attr::INTRINSIC) &&
2465       !context_.intrinsics().IsSpecificIntrinsicFunction(
2466           binding.symbol().name().ToString())) {
2467     messages_.Say(
2468         "Intrinsic procedure '%s' is not a specific intrinsic permitted for use in the definition of binding '%s'"_err_en_US,
2469         binding.symbol().name(), symbol.name());
2470   }
2471   bool isInaccessibleDeferred{false};
2472   if (const Symbol *
2473       overridden{FindOverriddenBinding(symbol, isInaccessibleDeferred)}) {
2474     if (isInaccessibleDeferred) {
2475       SayWithDeclaration(*overridden,
2476           "Override of PRIVATE DEFERRED '%s' must appear in its module"_err_en_US,
2477           symbol.name());
2478     }
2479     if (overridden->attrs().test(Attr::NON_OVERRIDABLE)) {
2480       SayWithDeclaration(*overridden,
2481           "Override of NON_OVERRIDABLE '%s' is not permitted"_err_en_US,
2482           symbol.name());
2483     }
2484     if (const auto *overriddenBinding{
2485             overridden->detailsIf<ProcBindingDetails>()}) {
2486       if (!IsPureProcedure(symbol) && IsPureProcedure(*overridden)) {
2487         SayWithDeclaration(*overridden,
2488             "An overridden pure type-bound procedure binding must also be pure"_err_en_US);
2489         return;
2490       }
2491       if (!IsElementalProcedure(binding.symbol()) &&
2492           IsElementalProcedure(*overridden)) {
2493         SayWithDeclaration(*overridden,
2494             "A type-bound procedure and its override must both, or neither, be ELEMENTAL"_err_en_US);
2495         return;
2496       }
2497       bool isNopass{symbol.attrs().test(Attr::NOPASS)};
2498       if (isNopass != overridden->attrs().test(Attr::NOPASS)) {
2499         SayWithDeclaration(*overridden,
2500             isNopass
2501                 ? "A NOPASS type-bound procedure may not override a passed-argument procedure"_err_en_US
2502                 : "A passed-argument type-bound procedure may not override a NOPASS procedure"_err_en_US);
2503       } else {
2504         const auto *bindingChars{Characterize(symbol)};
2505         const auto *overriddenChars{Characterize(*overridden)};
2506         if (bindingChars && overriddenChars) {
2507           if (isNopass) {
2508             if (!bindingChars->CanOverride(*overriddenChars, std::nullopt)) {
2509               SayWithDeclaration(*overridden,
2510                   "A NOPASS type-bound procedure and its override must have identical interfaces"_err_en_US);
2511             }
2512           } else if (!context_.HasError(binding.symbol())) {
2513             auto passIndex{bindingChars->FindPassIndex(binding.passName())};
2514             auto overriddenPassIndex{
2515                 overriddenChars->FindPassIndex(overriddenBinding->passName())};
2516             if (passIndex && overriddenPassIndex) {
2517               if (*passIndex != *overriddenPassIndex) {
2518                 SayWithDeclaration(*overridden,
2519                     "A type-bound procedure and its override must use the same PASS argument"_err_en_US);
2520               } else if (!bindingChars->CanOverride(
2521                              *overriddenChars, passIndex)) {
2522                 SayWithDeclaration(*overridden,
2523                     "A type-bound procedure and its override must have compatible interfaces"_err_en_US);
2524               }
2525             }
2526           }
2527         }
2528       }
2529       if (symbol.attrs().test(Attr::PRIVATE)) {
2530         if (FindModuleContaining(dtScope) ==
2531             FindModuleContaining(overridden->owner())) {
2532           // types declared in same madule
2533           if (!overridden->attrs().test(Attr::PRIVATE)) {
2534             SayWithDeclaration(*overridden,
2535                 "A PRIVATE procedure may not override a PUBLIC procedure"_err_en_US);
2536           }
2537         } else { // types declared in distinct madules
2538           if (!CheckAccessibleSymbol(dtScope.parent(), *overridden)) {
2539             SayWithDeclaration(*overridden,
2540                 "A PRIVATE procedure may not override an accessible procedure"_err_en_US);
2541           }
2542         }
2543       }
2544     } else {
2545       SayWithDeclaration(*overridden,
2546           "A type-bound procedure binding may not have the same name as a parent component"_err_en_US);
2547     }
2548   }
2549   CheckPassArg(symbol, &binding.symbol(), binding);
2550 }
2551
2552 void CheckHelper::Check(const Scope &scope) {
2553   scope_ = &scope;
2554   common::Restorer<const Symbol *> restorer{innermostSymbol_, innermostSymbol_};
2555   if (const Symbol *symbol{scope.symbol()}) {
2556     innermostSymbol_ = symbol;
2557   }
2558   if (scope.IsParameterizedDerivedTypeInstantiation()) {
2559     auto restorer{common::ScopedSet(scopeIsUninstantiatedPDT_, false)};
2560     auto restorer2{context_.foldingContext().messages().SetContext(
2561         scope.instantiationContext().get())};
2562     for (const auto &pair : scope) {
2563       CheckPointerInitialization(*pair.second);
2564     }
2565   } else {
2566     auto restorer{common::ScopedSet(
2567         scopeIsUninstantiatedPDT_, scope.IsParameterizedDerivedType())};
2568     for (const auto &set : scope.equivalenceSets()) {
2569       CheckEquivalenceSet(set);
2570     }
2571     for (const auto &pair : scope) {
2572       Check(*pair.second);
2573     }
2574     if (scope.IsSubmodule() && scope.symbol()) {
2575       // Submodule names are not in their parent's scopes
2576       Check(*scope.symbol());
2577     }
2578     for (const auto &pair : scope.commonBlocks()) {
2579       CheckCommonBlock(*pair.second);
2580     }
2581     int mainProgCnt{0};
2582     for (const Scope &child : scope.children()) {
2583       Check(child);
2584       // A program shall consist of exactly one main program (5.2.2).
2585       if (child.kind() == Scope::Kind::MainProgram) {
2586         ++mainProgCnt;
2587         if (mainProgCnt > 1) {
2588           messages_.Say(child.sourceRange(),
2589               "A source file cannot contain more than one main program"_err_en_US);
2590         }
2591       }
2592     }
2593     if (scope.kind() == Scope::Kind::BlockData) {
2594       CheckBlockData(scope);
2595     }
2596     if (auto name{scope.GetName()}) {
2597       auto iter{scope.find(*name)};
2598       if (iter != scope.end()) {
2599         const char *kind{nullptr};
2600         switch (scope.kind()) {
2601         case Scope::Kind::Module:
2602           kind = scope.symbol()->get<ModuleDetails>().isSubmodule()
2603               ? "submodule"
2604               : "module";
2605           break;
2606         case Scope::Kind::MainProgram:
2607           kind = "main program";
2608           break;
2609         case Scope::Kind::BlockData:
2610           kind = "BLOCK DATA subprogram";
2611           break;
2612         default:;
2613         }
2614         if (kind) {
2615           Warn(common::LanguageFeature::BenignNameClash, iter->second->name(),
2616               "Name '%s' declared in a %s should not have the same name as the %s"_port_en_US,
2617               *name, kind, kind);
2618         }
2619       }
2620     }
2621     CheckGenericOps(scope);
2622   }
2623 }
2624
2625 void CheckHelper::CheckEquivalenceSet(const EquivalenceSet &set) {
2626   auto iter{
2627       std::find_if(set.begin(), set.end(), [](const EquivalenceObject &object) {
2628         return FindCommonBlockContaining(object.symbol) != nullptr;
2629       })};
2630   if (iter != set.end()) {
2631     const Symbol &commonBlock{DEREF(FindCommonBlockContaining(iter->symbol))};
2632     for (auto &object : set) {
2633       if (&object != &*iter) {
2634         if (auto *details{object.symbol.detailsIf<ObjectEntityDetails>()}) {
2635           if (details->commonBlock()) {
2636             if (details->commonBlock() != &commonBlock) { // 8.10.3 paragraph 1
2637               if (auto *msg{messages_.Say(object.symbol.name(),
2638                       "Two objects in the same EQUIVALENCE set may not be members of distinct COMMON blocks"_err_en_US)}) {
2639                 msg->Attach(iter->symbol.name(),
2640                        "Other object in EQUIVALENCE set"_en_US)
2641                     .Attach(details->commonBlock()->name(),
2642                         "COMMON block containing '%s'"_en_US,
2643                         object.symbol.name())
2644                     .Attach(commonBlock.name(),
2645                         "COMMON block containing '%s'"_en_US,
2646                         iter->symbol.name());
2647               }
2648             }
2649           } else {
2650             // Mark all symbols in the equivalence set with the same COMMON
2651             // block to prevent spurious error messages about initialization
2652             // in BLOCK DATA outside COMMON
2653             details->set_commonBlock(commonBlock);
2654           }
2655         }
2656       }
2657     }
2658   }
2659   for (const EquivalenceObject &object : set) {
2660     CheckEquivalenceObject(object);
2661   }
2662 }
2663
2664 static bool InCommonWithBind(const Symbol &symbol) {
2665   if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
2666     const Symbol *commonBlock{details->commonBlock()};
2667     return commonBlock && commonBlock->attrs().test(Attr::BIND_C);
2668   } else {
2669     return false;
2670   }
2671 }
2672
2673 void CheckHelper::CheckEquivalenceObject(const EquivalenceObject &object) {
2674   parser::MessageFixedText msg;
2675   const Symbol &symbol{object.symbol};
2676   if (symbol.owner().IsDerivedType()) {
2677     msg =
2678         "Derived type component '%s' is not allowed in an equivalence set"_err_en_US;
2679   } else if (IsDummy(symbol)) {
2680     msg = "Dummy argument '%s' is not allowed in an equivalence set"_err_en_US;
2681   } else if (symbol.IsFuncResult()) {
2682     msg = "Function result '%s' is not allow in an equivalence set"_err_en_US;
2683   } else if (IsPointer(symbol)) {
2684     msg = "Pointer '%s' is not allowed in an equivalence set"_err_en_US;
2685   } else if (IsAllocatable(symbol)) {
2686     msg =
2687         "Allocatable variable '%s' is not allowed in an equivalence set"_err_en_US;
2688   } else if (symbol.Corank() > 0) {
2689     msg = "Coarray '%s' is not allowed in an equivalence set"_err_en_US;
2690   } else if (symbol.has<UseDetails>()) {
2691     msg =
2692         "Use-associated variable '%s' is not allowed in an equivalence set"_err_en_US;
2693   } else if (symbol.attrs().test(Attr::BIND_C)) {
2694     msg =
2695         "Variable '%s' with BIND attribute is not allowed in an equivalence set"_err_en_US;
2696   } else if (symbol.attrs().test(Attr::TARGET)) {
2697     msg =
2698         "Variable '%s' with TARGET attribute is not allowed in an equivalence set"_err_en_US;
2699   } else if (IsNamedConstant(symbol)) {
2700     msg = "Named constant '%s' is not allowed in an equivalence set"_err_en_US;
2701   } else if (InCommonWithBind(symbol)) {
2702     msg =
2703         "Variable '%s' in common block with BIND attribute is not allowed in an equivalence set"_err_en_US;
2704   } else if (!symbol.has<ObjectEntityDetails>()) {
2705     msg = "'%s' in equivalence set is not a data object"_err_en_US;
2706   } else if (const auto *type{symbol.GetType()}) {
2707     const auto *derived{type->AsDerived()};
2708     if (derived && !derived->IsVectorType()) {
2709       if (const auto *comp{
2710               FindUltimateComponent(*derived, IsAllocatableOrPointer)}) {
2711         msg = IsPointer(*comp)
2712             ? "Derived type object '%s' with pointer ultimate component is not allowed in an equivalence set"_err_en_US
2713             : "Derived type object '%s' with allocatable ultimate component is not allowed in an equivalence set"_err_en_US;
2714       } else if (!derived->typeSymbol().get<DerivedTypeDetails>().sequence()) {
2715         msg =
2716             "Nonsequence derived type object '%s' is not allowed in an equivalence set"_err_en_US;
2717       }
2718     } else if (IsAutomatic(symbol)) {
2719       msg =
2720           "Automatic object '%s' is not allowed in an equivalence set"_err_en_US;
2721     } else if (symbol.test(Symbol::Flag::CrayPointee)) {
2722       messages_.Say(object.symbol.name(),
2723           "Cray pointee '%s' may not be a member of an EQUIVALENCE group"_err_en_US,
2724           object.symbol.name());
2725     }
2726   }
2727   if (!msg.text().empty()) {
2728     context_.Say(object.source, std::move(msg), symbol.name());
2729   }
2730 }
2731
2732 void CheckHelper::CheckBlockData(const Scope &scope) {
2733   // BLOCK DATA subprograms should contain only named common blocks.
2734   // C1415 presents a list of statements that shouldn't appear in
2735   // BLOCK DATA, but so long as the subprogram contains no executable
2736   // code and allocates no storage outside named COMMON, we're happy
2737   // (e.g., an ENUM is strictly not allowed).
2738   for (const auto &pair : scope) {
2739     const Symbol &symbol{*pair.second};
2740     if (!(symbol.has<CommonBlockDetails>() || symbol.has<UseDetails>() ||
2741             symbol.has<UseErrorDetails>() || symbol.has<DerivedTypeDetails>() ||
2742             symbol.has<SubprogramDetails>() ||
2743             symbol.has<ObjectEntityDetails>() ||
2744             (symbol.has<ProcEntityDetails>() &&
2745                 !symbol.attrs().test(Attr::POINTER)))) {
2746       messages_.Say(symbol.name(),
2747           "'%s' may not appear in a BLOCK DATA subprogram"_err_en_US,
2748           symbol.name());
2749     }
2750   }
2751 }
2752
2753 // Check distinguishability of generic assignment and operators.
2754 // For these, generics and generic bindings must be considered together.
2755 void CheckHelper::CheckGenericOps(const Scope &scope) {
2756   DistinguishabilityHelper helper{context_};
2757   auto addSpecifics{[&](const Symbol &generic) {
2758     if (!IsAccessible(generic, scope)) {
2759       return;
2760     }
2761     const auto *details{generic.GetUltimate().detailsIf<GenericDetails>()};
2762     if (!details) {
2763       // Not a generic; ensure characteristics are defined if a function.
2764       auto restorer{messages_.SetLocation(generic.name())};
2765       if (IsFunction(generic) && !context_.HasError(generic)) {
2766         if (const Symbol *result{FindFunctionResult(generic)};
2767             result && !context_.HasError(*result)) {
2768           Characterize(generic);
2769         }
2770       }
2771       return;
2772     }
2773     GenericKind kind{details->kind()};
2774     if (!kind.IsAssignment() && !kind.IsOperator()) {
2775       return;
2776     }
2777     const SymbolVector &specifics{details->specificProcs()};
2778     const std::vector<SourceName> &bindingNames{details->bindingNames()};
2779     for (std::size_t i{0}; i < specifics.size(); ++i) {
2780       const Symbol &specific{*specifics[i]};
2781       auto restorer{messages_.SetLocation(bindingNames[i])};
2782       if (const Procedure *proc{Characterize(specific)}) {
2783         if (kind.IsAssignment()) {
2784           if (!CheckDefinedAssignment(specific, *proc)) {
2785             continue;
2786           }
2787         } else {
2788           if (!CheckDefinedOperator(generic.name(), kind, specific, *proc)) {
2789             continue;
2790           }
2791         }
2792         helper.Add(generic, kind, specific, *proc);
2793       }
2794     }
2795   }};
2796   for (const auto &pair : scope) {
2797     const Symbol &symbol{*pair.second};
2798     addSpecifics(symbol);
2799     const Symbol &ultimate{symbol.GetUltimate()};
2800     if (ultimate.has<DerivedTypeDetails>()) {
2801       if (const Scope *typeScope{ultimate.scope()}) {
2802         for (const auto &pair2 : *typeScope) {
2803           addSpecifics(*pair2.second);
2804         }
2805       }
2806     }
2807   }
2808   helper.Check(scope);
2809 }
2810
2811 static bool IsSubprogramDefinition(const Symbol &symbol) {
2812   const auto *subp{symbol.detailsIf<SubprogramDetails>()};
2813   return subp && !subp->isInterface() && symbol.scope() &&
2814       symbol.scope()->kind() == Scope::Kind::Subprogram;
2815 }
2816
2817 static bool IsExternalProcedureDefinition(const Symbol &symbol) {
2818   return IsBlockData(symbol) ||
2819       (IsSubprogramDefinition(symbol) &&
2820           (IsExternal(symbol) || symbol.GetBindName()));
2821 }
2822
2823 static std::optional<std::string> DefinesGlobalName(const Symbol &symbol) {
2824   if (const auto *module{symbol.detailsIf<ModuleDetails>()}) {
2825     if (!module->isSubmodule() && !symbol.owner().IsIntrinsicModules()) {
2826       return symbol.name().ToString();
2827     }
2828   } else if (IsBlockData(symbol)) {
2829     return symbol.name().ToString();
2830   } else {
2831     const std::string *bindC{symbol.GetBindName()};
2832     if (symbol.has<CommonBlockDetails>() ||
2833         IsExternalProcedureDefinition(symbol) ||
2834         (symbol.owner().IsGlobal() && IsExternal(symbol))) {
2835       return bindC ? *bindC : symbol.name().ToString();
2836     } else if (bindC &&
2837         (symbol.has<ObjectEntityDetails>() || IsModuleProcedure(symbol))) {
2838       return *bindC;
2839     }
2840   }
2841   return std::nullopt;
2842 }
2843
2844 // 19.2 p2
2845 void CheckHelper::CheckGlobalName(const Symbol &symbol) {
2846   if (auto global{DefinesGlobalName(symbol)}) {
2847     auto pair{globalNames_.emplace(std::move(*global), symbol)};
2848     if (!pair.second) {
2849       const Symbol &other{*pair.first->second};
2850       if (context_.HasError(symbol) || context_.HasError(other)) {
2851         // don't pile on
2852       } else if (symbol.has<CommonBlockDetails>() &&
2853           other.has<CommonBlockDetails>() && symbol.name() == other.name()) {
2854         // Two common blocks can have the same global name so long as
2855         // they're not in the same scope.
2856       } else if ((IsProcedure(symbol) || IsBlockData(symbol)) &&
2857           (IsProcedure(other) || IsBlockData(other)) &&
2858           (!IsExternalProcedureDefinition(symbol) ||
2859               !IsExternalProcedureDefinition(other))) {
2860         // both are procedures/BLOCK DATA, not both definitions
2861       } else if (symbol.has<ModuleDetails>()) {
2862         Warn(common::LanguageFeature::BenignNameClash, symbol.name(),
2863             "Module '%s' conflicts with a global name"_port_en_US,
2864             pair.first->first);
2865       } else if (other.has<ModuleDetails>()) {
2866         Warn(common::LanguageFeature::BenignNameClash, symbol.name(),
2867             "Global name '%s' conflicts with a module"_port_en_US,
2868             pair.first->first);
2869       } else if (auto *msg{messages_.Say(symbol.name(),
2870                      "Two entities have the same global name '%s'"_err_en_US,
2871                      pair.first->first)}) {
2872         msg->Attach(other.name(), "Conflicting declaration"_en_US);
2873         context_.SetError(symbol);
2874         context_.SetError(other);
2875       }
2876     }
2877   }
2878 }
2879
2880 void CheckHelper::CheckProcedureAssemblyName(const Symbol &symbol) {
2881   if (!IsProcedure(symbol) || symbol != symbol.GetUltimate())
2882     return;
2883   const std::string *bindName{symbol.GetBindName()};
2884   const bool hasExplicitBindingLabel{
2885       symbol.GetIsExplicitBindName() && bindName};
2886   if (hasExplicitBindingLabel || IsExternal(symbol)) {
2887     const std::string assemblyName{hasExplicitBindingLabel
2888             ? *bindName
2889             : common::GetExternalAssemblyName(
2890                   symbol.name().ToString(), context_.underscoring())};
2891     auto pair{procedureAssemblyNames_.emplace(std::move(assemblyName), symbol)};
2892     if (!pair.second) {
2893       const Symbol &other{*pair.first->second};
2894       const bool otherHasExplicitBindingLabel{
2895           other.GetIsExplicitBindName() && other.GetBindName()};
2896       if (otherHasExplicitBindingLabel != hasExplicitBindingLabel) {
2897         // The BIND(C,NAME="...") binding label is the same as the name that
2898         // will be used in LLVM IR for an external procedure declared without
2899         // BIND(C) in the same file. While this is not forbidden by the
2900         // standard, this name collision would lead to a crash when producing
2901         // the IR.
2902         if (auto *msg{messages_.Say(symbol.name(),
2903                 "%s procedure assembly name conflicts with %s procedure assembly name"_err_en_US,
2904                 hasExplicitBindingLabel ? "BIND(C)" : "Non BIND(C)",
2905                 hasExplicitBindingLabel ? "non BIND(C)" : "BIND(C)")}) {
2906           msg->Attach(other.name(), "Conflicting declaration"_en_US);
2907         }
2908         context_.SetError(symbol);
2909         context_.SetError(other);
2910       }
2911       // Otherwise, the global names also match and the conflict is analyzed
2912       // by CheckGlobalName.
2913     }
2914   }
2915 }
2916
2917 parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
2918     const Symbol &symbol) {
2919   parser::Messages msgs;
2920   if (examinedByWhyNotInteroperable_.find(symbol) !=
2921       examinedByWhyNotInteroperable_.end()) {
2922     return msgs;
2923   }
2924   examinedByWhyNotInteroperable_.insert(symbol);
2925   if (const auto *derived{symbol.detailsIf<DerivedTypeDetails>()}) {
2926     if (derived->sequence()) { // C1801
2927       msgs.Say(symbol.name(),
2928           "An interoperable derived type cannot have the SEQUENCE attribute"_err_en_US);
2929     } else if (!derived->paramNameOrder().empty()) { // C1802
2930       msgs.Say(symbol.name(),
2931           "An interoperable derived type cannot have a type parameter"_err_en_US);
2932     } else if (const auto *parent{
2933                    symbol.scope()->GetDerivedTypeParent()}) { // C1803
2934       if (symbol.attrs().test(Attr::BIND_C)) {
2935         msgs.Say(symbol.name(),
2936             "A derived type with the BIND attribute cannot be an extended derived type"_err_en_US);
2937       } else {
2938         bool interoperableParent{true};
2939         if (parent->symbol()) {
2940           auto bad{WhyNotInteroperableDerivedType(*parent->symbol())};
2941           if (bad.AnyFatalError()) {
2942             auto &msg{msgs.Say(symbol.name(),
2943                 "The parent of an interoperable type is not interoperable"_err_en_US)};
2944             bad.AttachTo(msg, parser::Severity::None);
2945             interoperableParent = false;
2946           }
2947         }
2948         if (interoperableParent) {
2949           msgs.Say(symbol.name(),
2950               "An interoperable type should not be an extended derived type"_warn_en_US);
2951         }
2952       }
2953     }
2954     const Symbol *parentComponent{symbol.scope()
2955             ? derived->GetParentComponent(*symbol.scope())
2956             : nullptr};
2957     for (const auto &pair : *symbol.scope()) {
2958       const Symbol &component{*pair.second};
2959       if (&component == parentComponent) {
2960         continue; // was checked above
2961       }
2962       if (IsProcedure(component)) { // C1804
2963         msgs.Say(component.name(),
2964             "An interoperable derived type cannot have a type bound procedure"_err_en_US);
2965       } else if (IsAllocatableOrPointer(component)) { // C1806
2966         msgs.Say(component.name(),
2967             "An interoperable derived type cannot have a pointer or allocatable component"_err_en_US);
2968       } else if (const auto *type{component.GetType()}) {
2969         if (const auto *derived{type->AsDerived()}) {
2970           auto bad{WhyNotInteroperableDerivedType(derived->typeSymbol())};
2971           if (bad.AnyFatalError()) {
2972             auto &msg{msgs.Say(component.name(),
2973                 "Component '%s' of an interoperable derived type must have an interoperable type but does not"_err_en_US,
2974                 component.name())};
2975             bad.AttachTo(msg, parser::Severity::None);
2976           } else if (!derived->typeSymbol().GetUltimate().attrs().test(
2977                          Attr::BIND_C)) {
2978             auto &msg{
2979                 msgs.Say(component.name(),
2980                         "Derived type of component '%s' of an interoperable derived type should have the BIND attribute"_warn_en_US,
2981                         component.name())
2982                     .Attach(derived->typeSymbol().name(),
2983                         "Non-BIND(C) component type"_en_US)};
2984             bad.AttachTo(msg, parser::Severity::None);
2985           } else {
2986             msgs.Annex(std::move(bad));
2987           }
2988         } else if (auto dyType{evaluate::DynamicType::From(*type)}; dyType &&
2989                    !evaluate::IsInteroperableIntrinsicType(
2990                        *dyType, &context_.languageFeatures())
2991                         .value_or(false)) {
2992           if (type->category() == DeclTypeSpec::Logical) {
2993             if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {
2994               msgs.Say(common::UsageWarning::LogicalVsCBool, component.name(),
2995                   "A LOGICAL component of an interoperable type should have the interoperable KIND=C_BOOL"_port_en_US);
2996             }
2997           } else if (type->category() == DeclTypeSpec::Character && dyType &&
2998               dyType->kind() == 1) {
2999             if (context_.ShouldWarn(common::UsageWarning::BindCCharLength)) {
3000               msgs.Say(common::UsageWarning::BindCCharLength, component.name(),
3001                   "A CHARACTER component of an interoperable type should have length 1"_port_en_US);
3002             }
3003           } else {
3004             msgs.Say(component.name(),
3005                 "Each component of an interoperable derived type must have an interoperable type"_err_en_US);
3006           }
3007         }
3008       }
3009       if (auto extents{
3010               evaluate::GetConstantExtents(foldingContext_, &component)};
3011           extents && evaluate::GetSize(*extents) == 0) {
3012         msgs.Say(component.name(),
3013             "An array component of an interoperable type must have at least one element"_err_en_US);
3014       }
3015     }
3016     if (derived->componentNames().empty()) { // F'2023 C1805
3017       if (context_.ShouldWarn(common::LanguageFeature::EmptyBindCDerivedType)) {
3018         msgs.Say(common::LanguageFeature::EmptyBindCDerivedType, symbol.name(),
3019             "A derived type with the BIND attribute should not be empty"_warn_en_US);
3020       }
3021     }
3022   }
3023   if (msgs.AnyFatalError()) {
3024     examinedByWhyNotInteroperable_.erase(symbol);
3025   }
3026   return msgs;
3027 }
3028
3029 parser::Messages CheckHelper::WhyNotInteroperableObject(
3030     const Symbol &symbol, bool allowNonInteroperableType) {
3031   parser::Messages msgs;
3032   if (examinedByWhyNotInteroperable_.find(symbol) !=
3033       examinedByWhyNotInteroperable_.end()) {
3034     return msgs;
3035   }
3036   bool isExplicitBindC{symbol.attrs().test(Attr::BIND_C)};
3037   examinedByWhyNotInteroperable_.insert(symbol);
3038   CHECK(symbol.has<ObjectEntityDetails>());
3039   if (isExplicitBindC && !symbol.owner().IsModule()) {
3040     msgs.Say(symbol.name(),
3041         "A variable with BIND(C) attribute may only appear in the specification part of a module"_err_en_US);
3042   }
3043   auto shape{evaluate::GetShape(foldingContext_, symbol)};
3044   if (shape) {
3045     if (evaluate::GetRank(*shape) == 0) { // 18.3.4
3046       if (IsAllocatableOrPointer(symbol) && !IsDummy(symbol)) {
3047         msgs.Say(symbol.name(),
3048             "A scalar interoperable variable may not be ALLOCATABLE or POINTER"_err_en_US);
3049       }
3050     } else if (auto extents{
3051                    evaluate::AsConstantExtents(foldingContext_, *shape)}) {
3052       if (evaluate::GetSize(*extents) == 0) {
3053         msgs.Say(symbol.name(),
3054             "Interoperable array must have at least one element"_err_en_US);
3055       }
3056     } else if (!evaluate::IsExplicitShape(symbol) &&
3057         !IsAssumedSizeArray(symbol) &&
3058         !(IsDummy(symbol) && !symbol.attrs().test(Attr::VALUE))) {
3059       msgs.Say(symbol.name(),
3060           "BIND(C) array must have explicit shape or be assumed-size unless a dummy argument without the VALUE attribute"_err_en_US);
3061     }
3062   }
3063   if (const auto *type{symbol.GetType()}) {
3064     const auto *derived{type->AsDerived()};
3065     if (derived && !derived->typeSymbol().attrs().test(Attr::BIND_C)) {
3066       if (allowNonInteroperableType) { // portability warning only
3067         evaluate::AttachDeclaration(
3068             context_.Warn(common::UsageWarning::Portability, symbol.name(),
3069                 "The derived type of this interoperable object should be BIND(C)"_port_en_US),
3070             derived->typeSymbol());
3071       } else if (!context_.IsEnabled(
3072                      common::LanguageFeature::NonBindCInteroperability)) {
3073         msgs.Say(symbol.name(),
3074                 "The derived type of an interoperable object must be BIND(C)"_err_en_US)
3075             .Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);
3076       } else if (auto bad{
3077                      WhyNotInteroperableDerivedType(derived->typeSymbol())};
3078                  bad.AnyFatalError()) {
3079         bad.AttachTo(
3080             msgs.Say(symbol.name(),
3081                     "The derived type of an interoperable object must be interoperable, but is not"_err_en_US)
3082                 .Attach(derived->typeSymbol().name(),
3083                     "Non-interoperable type"_en_US),
3084             parser::Severity::None);
3085       } else {
3086         msgs.Say(symbol.name(),
3087                 "The derived type of an interoperable object should be BIND(C)"_warn_en_US)
3088             .Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);
3089       }
3090     }
3091     if (type->IsAssumedType()) { // ok
3092     } else if (IsAssumedLengthCharacter(symbol) &&
3093         !IsAllocatableOrPointer(symbol)) {
3094     } else if (IsAllocatableOrPointer(symbol) &&
3095         type->category() == DeclTypeSpec::Character &&
3096         type->characterTypeSpec().length().isDeferred()) {
3097       // ok; F'2023 18.3.7 p2(6)
3098     } else if (derived) { // type has been checked
3099     } else if (auto dyType{evaluate::DynamicType::From(*type)}; dyType &&
3100         evaluate::IsInteroperableIntrinsicType(
3101             *dyType, InModuleFile() ? nullptr : &context_.languageFeatures())
3102             .value_or(false)) {
3103       // F'2023 18.3.7 p2(4,5)
3104       // N.B. Language features are not passed to IsInteroperableIntrinsicType
3105       // when processing a module file, since the module file might have been
3106       // compiled with CUDA while the client is not.
3107     } else if (type->category() == DeclTypeSpec::Logical) {
3108       if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {
3109         if (IsDummy(symbol)) {
3110           msgs.Say(common::UsageWarning::LogicalVsCBool, symbol.name(),
3111               "A BIND(C) LOGICAL dummy argument should have the interoperable KIND=C_BOOL"_port_en_US);
3112         } else {
3113           msgs.Say(common::UsageWarning::LogicalVsCBool, symbol.name(),
3114               "A BIND(C) LOGICAL object should have the interoperable KIND=C_BOOL"_port_en_US);
3115         }
3116       }
3117     } else if (symbol.attrs().test(Attr::VALUE)) {
3118       msgs.Say(symbol.name(),
3119           "A BIND(C) VALUE dummy argument must have an interoperable type"_err_en_US);
3120     } else {
3121       msgs.Say(symbol.name(),
3122           "A BIND(C) object must have an interoperable type"_err_en_US);
3123     }
3124   }
3125   if (IsOptional(symbol) && !symbol.attrs().test(Attr::VALUE)) {
3126     msgs.Say(symbol.name(),
3127         "An interoperable procedure with an OPTIONAL dummy argument might not be portable"_port_en_US);
3128   }
3129   if (IsDescriptor(symbol) && IsPointer(symbol) &&
3130       symbol.attrs().test(Attr::CONTIGUOUS)) {
3131     msgs.Say(symbol.name(),
3132         "An interoperable pointer must not be CONTIGUOUS"_err_en_US);
3133   }
3134   if (msgs.AnyFatalError()) {
3135     examinedByWhyNotInteroperable_.erase(symbol);
3136   }
3137   return msgs;
3138 }
3139
3140 parser::Messages CheckHelper::WhyNotInteroperableFunctionResult(
3141     const Symbol &symbol) {
3142   parser::Messages msgs;
3143   if (IsPointer(symbol) || IsAllocatable(symbol)) {
3144     msgs.Say(symbol.name(),
3145         "Interoperable function result may not have ALLOCATABLE or POINTER attribute"_err_en_US);
3146   }
3147   if (const DeclTypeSpec * type{symbol.GetType()};
3148       type && type->category() == DeclTypeSpec::Character) {
3149     bool isConstOne{false}; // 18.3.1(1)
3150     if (const auto &len{type->characterTypeSpec().length().GetExplicit()}) {
3151       if (auto constLen{evaluate::ToInt64(*len)}) {
3152         isConstOne = constLen == 1;
3153       }
3154     }
3155     if (!isConstOne) {
3156       msgs.Say(symbol.name(),
3157           "Interoperable character function result must have length one"_err_en_US);
3158     }
3159   }
3160   if (symbol.Rank() > 0) {
3161     msgs.Say(symbol.name(),
3162         "Interoperable function result must be scalar"_err_en_US);
3163   }
3164   if (symbol.Corank()) {
3165     msgs.Say(symbol.name(),
3166         "Interoperable function result may not be a coarray"_err_en_US);
3167   }
3168   return msgs;
3169 }
3170
3171 parser::Messages CheckHelper::WhyNotInteroperableProcedure(
3172     const Symbol &symbol, bool isError) {
3173   parser::Messages msgs;
3174   if (examinedByWhyNotInteroperable_.find(symbol) !=
3175       examinedByWhyNotInteroperable_.end()) {
3176     return msgs;
3177   }
3178   isError |= symbol.attrs().test(Attr::BIND_C);
3179   examinedByWhyNotInteroperable_.insert(symbol);
3180   if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
3181     if (isError) {
3182       if (!proc->procInterface() ||
3183           !proc->procInterface()->attrs().test(Attr::BIND_C)) {
3184         msgs.Say(symbol.name(),
3185             "An interface name with the BIND attribute must appear if the BIND attribute appears in a procedure declaration"_err_en_US);
3186       }
3187     } else if (!proc->procInterface()) {
3188       msgs.Say(symbol.name(),
3189           "An interoperable procedure should have an interface"_port_en_US);
3190     } else if (!proc->procInterface()->attrs().test(Attr::BIND_C)) {
3191       auto bad{WhyNotInteroperableProcedure(
3192           *proc->procInterface(), /*isError=*/false)};
3193       if (bad.AnyFatalError()) {
3194         bad.AttachTo(msgs.Say(symbol.name(),
3195             "An interoperable procedure must have an interoperable interface"_err_en_US));
3196       } else {
3197         msgs.Say(symbol.name(),
3198             "An interoperable procedure should have an interface with the BIND attribute"_warn_en_US);
3199       }
3200     }
3201   } else if (const auto *subp{symbol.detailsIf<SubprogramDetails>()}) {
3202     for (const Symbol *dummy : subp->dummyArgs()) {
3203       if (dummy) {
3204         parser::Messages dummyMsgs;
3205         if (dummy->has<ProcEntityDetails>() ||
3206             dummy->has<SubprogramDetails>()) {
3207           dummyMsgs = WhyNotInteroperableProcedure(*dummy, /*isError=*/false);
3208           if (dummyMsgs.empty() && !dummy->attrs().test(Attr::BIND_C)) {
3209             dummyMsgs.Say(dummy->name(),
3210                 "A dummy procedure of an interoperable procedure should be BIND(C)"_warn_en_US);
3211           }
3212         } else if (dummy->has<ObjectEntityDetails>()) {
3213           // Emit only optional portability warnings for non-interoperable
3214           // types when the dummy argument is not VALUE and will be implemented
3215           // on the C side by either a cdesc_t * or a void *.  F'2023 18.3.7 (5)
3216           bool allowNonInteroperableType{!dummy->attrs().test(Attr::VALUE) &&
3217               (IsDescriptor(*dummy) || IsAssumedType(*dummy))};
3218           dummyMsgs =
3219               WhyNotInteroperableObject(*dummy, allowNonInteroperableType);
3220         } else {
3221           CheckBindC(*dummy);
3222         }
3223         msgs.Annex(std::move(dummyMsgs));
3224       } else {
3225         msgs.Say(symbol.name(),
3226             "A subprogram interface with the BIND attribute may not have an alternate return argument"_err_en_US);
3227       }
3228     }
3229     if (subp->isFunction()) {
3230       if (subp->result().has<ObjectEntityDetails>()) {
3231         msgs.Annex(WhyNotInteroperableFunctionResult(subp->result()));
3232       } else {
3233         msgs.Say(subp->result().name(),
3234             "The result of an interoperable function must be a data object"_err_en_US);
3235       }
3236     }
3237   }
3238   if (msgs.AnyFatalError()) {
3239     examinedByWhyNotInteroperable_.erase(symbol);
3240   }
3241   return msgs;
3242 }
3243
3244 void CheckHelper::CheckBindC(const Symbol &symbol) {
3245   bool isExplicitBindC{symbol.attrs().test(Attr::BIND_C)};
3246   if (isExplicitBindC) {
3247     CheckConflicting(symbol, Attr::BIND_C, Attr::ELEMENTAL);
3248     CheckConflicting(symbol, Attr::BIND_C, Attr::INTRINSIC);
3249     CheckConflicting(symbol, Attr::BIND_C, Attr::PARAMETER);
3250   } else {
3251     // symbol must be interoperable (e.g., dummy argument of interoperable
3252     // procedure interface) but is not itself BIND(C).
3253   }
3254   parser::Messages whyNot;
3255   if (const std::string * bindName{symbol.GetBindName()};
3256       bindName) { // has a binding name
3257     if (!bindName->empty()) {
3258       bool ok{bindName->front() == '_' || parser::IsLetter(bindName->front())};
3259       for (char ch : *bindName) {
3260         ok &= ch == '_' || parser::IsLetter(ch) || parser::IsDecimalDigit(ch);
3261       }
3262       if (!ok) {
3263         messages_.Say(symbol.name(),
3264             "Symbol has a BIND(C) name that is not a valid C language identifier"_err_en_US);
3265         context_.SetError(symbol);
3266       }
3267     }
3268   }
3269   if (symbol.GetIsExplicitBindName()) { // BIND(C,NAME=...); C1552, C1529
3270     auto defClass{ClassifyProcedure(symbol)};
3271     if (IsProcedurePointer(symbol)) {
3272       messages_.Say(symbol.name(),
3273           "A procedure pointer may not have a BIND attribute with a name"_err_en_US);
3274       context_.SetError(symbol);
3275     } else if (defClass == ProcedureDefinitionClass::None ||
3276         IsExternal(symbol)) {
3277     } else if (symbol.attrs().test(Attr::ABSTRACT)) {
3278       messages_.Say(symbol.name(),
3279           "An ABSTRACT interface may not have a BIND attribute with a name"_err_en_US);
3280       context_.SetError(symbol);
3281     } else if (defClass == ProcedureDefinitionClass::Internal ||
3282         defClass == ProcedureDefinitionClass::Dummy) {
3283       messages_.Say(symbol.name(),
3284           "An internal or dummy procedure may not have a BIND(C,NAME=) binding label"_err_en_US);
3285       context_.SetError(symbol);
3286     }
3287   }
3288   if (symbol.has<ObjectEntityDetails>()) {
3289     whyNot = WhyNotInteroperableObject(symbol);
3290   } else if (symbol.has<ProcEntityDetails>() ||
3291       symbol.has<SubprogramDetails>()) {
3292     whyNot = WhyNotInteroperableProcedure(symbol, /*isError=*/isExplicitBindC);
3293   } else if (symbol.has<DerivedTypeDetails>()) {
3294     whyNot = WhyNotInteroperableDerivedType(symbol);
3295   }
3296   if (!whyNot.empty()) {
3297     bool anyFatal{whyNot.AnyFatalError()};
3298     if (anyFatal ||
3299         (!InModuleFile() &&
3300             context_.ShouldWarn(
3301                 common::LanguageFeature::NonBindCInteroperability))) {
3302       context_.messages().Annex(std::move(whyNot));
3303     }
3304     if (anyFatal) {
3305       context_.SetError(symbol);
3306     }
3307   }
3308 }
3309
3310 bool CheckHelper::CheckDioDummyIsData(
3311     const Symbol &subp, const Symbol *arg, std::size_t position) {
3312   if (arg && arg->detailsIf<ObjectEntityDetails>()) {
3313     return true;
3314   } else {
3315     if (arg) {
3316       messages_.Say(arg->name(),
3317           "Dummy argument '%s' must be a data object"_err_en_US, arg->name());
3318     } else {
3319       messages_.Say(subp.name(),
3320           "Dummy argument %d of '%s' must be a data object"_err_en_US, position,
3321           subp.name());
3322     }
3323     return false;
3324   }
3325 }
3326
3327 void CheckHelper::CheckAlreadySeenDefinedIo(const DerivedTypeSpec &derivedType,
3328     common::DefinedIo ioKind, const Symbol &proc, const Symbol &generic) {
3329   // Check for conflict between non-type-bound defined I/O and type-bound
3330   // generics. It's okay to have two or more distinct defined I/O procedures for
3331   // the same type if they're coming from distinct non-type-bound interfaces.
3332   // (The non-type-bound interfaces would have been merged into a single generic
3333   //  -- with errors where indistinguishable --  when both were visible from the
3334   // same scope.)
3335   if (generic.owner().IsDerivedType()) {
3336     return;
3337   }
3338   if (const Scope * dtScope{derivedType.scope()}) {
3339     if (auto iter{dtScope->find(generic.name())}; iter != dtScope->end()) {
3340       for (auto specRef : iter->second->get<GenericDetails>().specificProcs()) {
3341         const Symbol &specific{specRef->get<ProcBindingDetails>().symbol()};
3342         if (specific == proc) { // unambiguous, accept
3343           continue;
3344         }
3345         if (const auto *specDT{GetDtvArgDerivedType(specific)};
3346             specDT && evaluate::AreSameDerivedType(derivedType, *specDT)) {
3347           SayWithDeclaration(*specRef, proc.name(),
3348               "Derived type '%s' has conflicting type-bound input/output procedure '%s'"_err_en_US,
3349               derivedType.name(), GenericKind::AsFortran(ioKind));
3350           return;
3351         }
3352       }
3353     }
3354   }
3355 }
3356
3357 void CheckHelper::CheckDioDummyIsDerived(const Symbol &subp, const Symbol &arg,
3358     common::DefinedIo ioKind, const Symbol &generic) {
3359   if (const DeclTypeSpec *type{arg.GetType()}) {
3360     if (const DerivedTypeSpec *derivedType{type->AsDerived()}) {
3361       CheckAlreadySeenDefinedIo(*derivedType, ioKind, subp, generic);
3362       bool isPolymorphic{type->IsPolymorphic()};
3363       if (isPolymorphic != IsExtensibleType(derivedType)) {
3364         messages_.Say(arg.name(),
3365             "Dummy argument '%s' of a defined input/output procedure must be %s when the derived type is %s"_err_en_US,
3366             arg.name(), isPolymorphic ? "TYPE()" : "CLASS()",
3367             isPolymorphic ? "not extensible" : "extensible");
3368       }
3369     } else {
3370       messages_.Say(arg.name(),
3371           "Dummy argument '%s' of a defined input/output procedure must have a"
3372           " derived type"_err_en_US,
3373           arg.name());
3374     }
3375   }
3376 }
3377
3378 void CheckHelper::CheckDioDummyIsDefaultInteger(
3379     const Symbol &subp, const Symbol &arg) {
3380   if (const DeclTypeSpec *type{arg.GetType()};
3381       type && type->IsNumeric(TypeCategory::Integer)) {
3382     if (const auto kind{evaluate::ToInt64(type->numericTypeSpec().kind())};
3383         kind && *kind == context_.GetDefaultKind(TypeCategory::Integer)) {
3384       return;
3385     }
3386   }
3387   messages_.Say(arg.name(),
3388       "Dummy argument '%s' of a defined input/output procedure"
3389       " must be an INTEGER of default KIND"_err_en_US,
3390       arg.name());
3391 }
3392
3393 void CheckHelper::CheckDioDummyIsScalar(const Symbol &subp, const Symbol &arg) {
3394   if (arg.Rank() > 0 || arg.Corank() > 0) {
3395     messages_.Say(arg.name(),
3396         "Dummy argument '%s' of a defined input/output procedure"
3397         " must be a scalar"_err_en_US,
3398         arg.name());
3399   }
3400 }
3401
3402 void CheckHelper::CheckDioDtvArg(const Symbol &subp, const Symbol *arg,
3403     common::DefinedIo ioKind, const Symbol &generic) {
3404   // Dtv argument looks like: dtv-type-spec, INTENT(INOUT) :: dtv
3405   if (CheckDioDummyIsData(subp, arg, 0)) {
3406     CheckDioDummyIsDerived(subp, *arg, ioKind, generic);
3407     CheckDioDummyAttrs(subp, *arg,
3408         ioKind == common::DefinedIo::ReadFormatted ||
3409                 ioKind == common::DefinedIo::ReadUnformatted
3410             ? Attr::INTENT_INOUT
3411             : Attr::INTENT_IN);
3412   }
3413 }
3414
3415 // If an explicit INTRINSIC name is a function, so must all the specifics be,
3416 // and similarly for subroutines
3417 void CheckHelper::CheckGenericVsIntrinsic(
3418     const Symbol &symbol, const GenericDetails &generic) {
3419   if (symbol.attrs().test(Attr::INTRINSIC)) {
3420     const evaluate::IntrinsicProcTable &table{
3421         context_.foldingContext().intrinsics()};
3422     bool isSubroutine{table.IsIntrinsicSubroutine(symbol.name().ToString())};
3423     if (isSubroutine || table.IsIntrinsicFunction(symbol.name().ToString())) {
3424       for (const SymbolRef &ref : generic.specificProcs()) {
3425         const Symbol &ultimate{ref->GetUltimate()};
3426         bool specificFunc{ultimate.test(Symbol::Flag::Function)};
3427         bool specificSubr{ultimate.test(Symbol::Flag::Subroutine)};
3428         if (!specificFunc && !specificSubr) {
3429           if (const auto *proc{ultimate.detailsIf<SubprogramDetails>()}) {
3430             if (proc->isFunction()) {
3431               specificFunc = true;
3432             } else {
3433               specificSubr = true;
3434             }
3435           }
3436         }
3437         if ((specificFunc || specificSubr) &&
3438             isSubroutine != specificSubr) { // C848
3439           messages_.Say(symbol.name(),
3440               "Generic interface '%s' with explicit intrinsic %s of the same name may not have specific procedure '%s' that is a %s"_err_en_US,
3441               symbol.name(), isSubroutine ? "subroutine" : "function",
3442               ref->name(), isSubroutine ? "function" : "subroutine");
3443         }
3444       }
3445     }
3446   }
3447 }
3448
3449 void CheckHelper::CheckDefaultIntegerArg(
3450     const Symbol &subp, const Symbol *arg, Attr intent) {
3451   // Argument looks like: INTEGER, INTENT(intent) :: arg
3452   if (CheckDioDummyIsData(subp, arg, 1)) {
3453     CheckDioDummyIsDefaultInteger(subp, *arg);
3454     CheckDioDummyIsScalar(subp, *arg);
3455     CheckDioDummyAttrs(subp, *arg, intent);
3456   }
3457 }
3458
3459 void CheckHelper::CheckDioAssumedLenCharacterArg(const Symbol &subp,
3460     const Symbol *arg, std::size_t argPosition, Attr intent) {
3461   // Argument looks like: CHARACTER (LEN=*), INTENT(intent) :: (iotype OR iomsg)
3462   if (CheckDioDummyIsData(subp, arg, argPosition)) {
3463     CheckDioDummyAttrs(subp, *arg, intent);
3464     const DeclTypeSpec *type{arg ? arg->GetType() : nullptr};
3465     const IntrinsicTypeSpec *intrinsic{type ? type->AsIntrinsic() : nullptr};
3466     const auto kind{
3467         intrinsic ? evaluate::ToInt64(intrinsic->kind()) : std::nullopt};
3468     if (!IsAssumedLengthCharacter(*arg) ||
3469         (!kind ||
3470             *kind !=
3471                 context_.defaultKinds().GetDefaultKind(
3472                     TypeCategory::Character))) {
3473       messages_.Say(arg->name(),
3474           "Dummy argument '%s' of a defined input/output procedure"
3475           " must be assumed-length CHARACTER of default kind"_err_en_US,
3476           arg->name());
3477     }
3478   }
3479 }
3480
3481 void CheckHelper::CheckDioVlistArg(
3482     const Symbol &subp, const Symbol *arg, std::size_t argPosition) {
3483   // Vlist argument looks like: INTEGER, INTENT(IN) :: v_list(:)
3484   if (CheckDioDummyIsData(subp, arg, argPosition)) {
3485     CheckDioDummyIsDefaultInteger(subp, *arg);
3486     CheckDioDummyAttrs(subp, *arg, Attr::INTENT_IN);
3487     const auto *objectDetails{arg->detailsIf<ObjectEntityDetails>()};
3488     if (!objectDetails || !objectDetails->shape().CanBeDeferredShape()) {
3489       messages_.Say(arg->name(),
3490           "Dummy argument '%s' of a defined input/output procedure must be"
3491           " deferred shape"_err_en_US,
3492           arg->name());
3493     }
3494   }
3495 }
3496
3497 void CheckHelper::CheckDioArgCount(
3498     const Symbol &subp, common::DefinedIo ioKind, std::size_t argCount) {
3499   const std::size_t requiredArgCount{
3500       (std::size_t)(ioKind == common::DefinedIo::ReadFormatted ||
3501                   ioKind == common::DefinedIo::WriteFormatted
3502               ? 6
3503               : 4)};
3504   if (argCount != requiredArgCount) {
3505     SayWithDeclaration(subp,
3506         "Defined input/output procedure '%s' must have"
3507         " %d dummy arguments rather than %d"_err_en_US,
3508         subp.name(), requiredArgCount, argCount);
3509     context_.SetError(subp);
3510   }
3511 }
3512
3513 void CheckHelper::CheckDioDummyAttrs(
3514     const Symbol &subp, const Symbol &arg, Attr goodIntent) {
3515   // Defined I/O procedures can't have attributes other than INTENT
3516   Attrs attrs{arg.attrs()};
3517   if (!attrs.test(goodIntent)) {
3518     messages_.Say(arg.name(),
3519         "Dummy argument '%s' of a defined input/output procedure"
3520         " must have intent '%s'"_err_en_US,
3521         arg.name(), AttrToString(goodIntent));
3522   }
3523   attrs = attrs - Attr::INTENT_IN - Attr::INTENT_OUT - Attr::INTENT_INOUT;
3524   if (!attrs.empty()) {
3525     messages_.Say(arg.name(),
3526         "Dummy argument '%s' of a defined input/output procedure may not have"
3527         " any attributes"_err_en_US,
3528         arg.name());
3529   }
3530 }
3531
3532 // Enforce semantics for defined input/output procedures (12.6.4.8.2) and C777
3533 void CheckHelper::CheckDefinedIoProc(const Symbol &symbol,
3534     const GenericDetails &details, common::DefinedIo ioKind) {
3535   for (auto ref : details.specificProcs()) {
3536     const Symbol &ultimate{ref->GetUltimate()};
3537     const auto *binding{ultimate.detailsIf<ProcBindingDetails>()};
3538     const Symbol &specific{*(binding ? &binding->symbol() : &ultimate)};
3539     if (ultimate.attrs().test(Attr::NOPASS)) { // C774
3540       messages_.Say("Defined input/output procedure '%s' may not have NOPASS "
3541                     "attribute"_err_en_US,
3542           ultimate.name());
3543       context_.SetError(ultimate);
3544     }
3545     if (const auto *subpDetails{specific.detailsIf<SubprogramDetails>()}) {
3546       const std::vector<Symbol *> &dummyArgs{subpDetails->dummyArgs()};
3547       CheckDioArgCount(specific, ioKind, dummyArgs.size());
3548       int argCount{0};
3549       for (auto *arg : dummyArgs) {
3550         switch (argCount++) {
3551         case 0:
3552           // dtv-type-spec, INTENT(INOUT) :: dtv
3553           CheckDioDtvArg(specific, arg, ioKind, symbol);
3554           break;
3555         case 1:
3556           // INTEGER, INTENT(IN) :: unit
3557           CheckDefaultIntegerArg(specific, arg, Attr::INTENT_IN);
3558           break;
3559         case 2:
3560           if (ioKind == common::DefinedIo::ReadFormatted ||
3561               ioKind == common::DefinedIo::WriteFormatted) {
3562             // CHARACTER (LEN=*), INTENT(IN) :: iotype
3563             CheckDioAssumedLenCharacterArg(
3564                 specific, arg, argCount, Attr::INTENT_IN);
3565           } else {
3566             // INTEGER, INTENT(OUT) :: iostat
3567             CheckDefaultIntegerArg(specific, arg, Attr::INTENT_OUT);
3568           }
3569           break;
3570         case 3:
3571           if (ioKind == common::DefinedIo::ReadFormatted ||
3572               ioKind == common::DefinedIo::WriteFormatted) {
3573             // INTEGER, INTENT(IN) :: v_list(:)
3574             CheckDioVlistArg(specific, arg, argCount);
3575           } else {
3576             // CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
3577             CheckDioAssumedLenCharacterArg(
3578                 specific, arg, argCount, Attr::INTENT_INOUT);
3579           }
3580           break;
3581         case 4:
3582           // INTEGER, INTENT(OUT) :: iostat
3583           CheckDefaultIntegerArg(specific, arg, Attr::INTENT_OUT);
3584           break;
3585         case 5:
3586           // CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
3587           CheckDioAssumedLenCharacterArg(
3588               specific, arg, argCount, Attr::INTENT_INOUT);
3589           break;
3590         default:;
3591         }
3592       }
3593     }
3594   }
3595 }
3596
3597 void CheckHelper::CheckSymbolType(const Symbol &symbol) {
3598   const Symbol *result{FindFunctionResult(symbol)};
3599   const Symbol &relevant{result ? *result : symbol};
3600   if (IsAllocatable(relevant)) { // always ok
3601   } else if (IsProcedurePointer(symbol) && result && IsPointer(*result)) {
3602     // procedure pointer returning allocatable or pointer: ok
3603   } else if (IsPointer(relevant) && !IsProcedure(relevant)) {
3604     // object pointers are always ok
3605   } else if (auto dyType{evaluate::DynamicType::From(relevant)}) {
3606     if (dyType->IsPolymorphic() && !dyType->IsAssumedType() &&
3607         !(IsDummy(symbol) && !IsProcedure(relevant))) { // C708
3608       messages_.Say(
3609           "CLASS entity '%s' must be a dummy argument, allocatable, or object pointer"_err_en_US,
3610           symbol.name());
3611     }
3612     if (dyType->HasDeferredTypeParameter()) { // C702
3613       messages_.Say(
3614           "'%s' has a type %s with a deferred type parameter but is neither an allocatable nor an object pointer"_err_en_US,
3615           symbol.name(), dyType->AsFortran());
3616     }
3617   }
3618 }
3619
3620 void CheckHelper::CheckModuleProcedureDef(const Symbol &symbol) {
3621   auto procClass{ClassifyProcedure(symbol)};
3622   if (const auto *subprogram{symbol.detailsIf<SubprogramDetails>()};
3623       subprogram &&
3624       (procClass == ProcedureDefinitionClass::Module &&
3625           symbol.attrs().test(Attr::MODULE)) &&
3626       !subprogram->bindName() && !subprogram->isInterface()) {
3627     const Symbol &interface {
3628       subprogram->moduleInterface() ? *subprogram->moduleInterface() : symbol
3629     };
3630     if (const Symbol *
3631             module{interface.owner().kind() == Scope::Kind::Module
3632                     ? interface.owner().symbol()
3633                     : nullptr};
3634         module && module->has<ModuleDetails>()) {
3635       std::pair<SourceName, const Symbol *> key{symbol.name(), module};
3636       auto iter{moduleProcs_.find(key)};
3637       if (iter == moduleProcs_.end()) {
3638         moduleProcs_.emplace(std::move(key), symbol);
3639       } else if (
3640           auto *msg{messages_.Say(symbol.name(),
3641               "Module procedure '%s' in '%s' has multiple definitions"_err_en_US,
3642               symbol.name(), GetModuleOrSubmoduleName(*module))}) {
3643         msg->Attach(iter->second->name(), "Previous definition of '%s'"_en_US,
3644             symbol.name());
3645       }
3646     }
3647   }
3648 }
3649
3650 void SubprogramMatchHelper::Check(
3651     const Symbol &symbol1, const Symbol &symbol2) {
3652   const auto details1{symbol1.get<SubprogramDetails>()};
3653   const auto details2{symbol2.get<SubprogramDetails>()};
3654   if (details1.isFunction() != details2.isFunction()) {
3655     Say(symbol1, symbol2,
3656         details1.isFunction()
3657             ? "Module function '%s' was declared as a subroutine in the"
3658               " corresponding interface body"_err_en_US
3659             : "Module subroutine '%s' was declared as a function in the"
3660               " corresponding interface body"_err_en_US);
3661     return;
3662   }
3663   const auto &args1{details1.dummyArgs()};
3664   const auto &args2{details2.dummyArgs()};
3665   int nargs1{static_cast<int>(args1.size())};
3666   int nargs2{static_cast<int>(args2.size())};
3667   if (nargs1 != nargs2) {
3668     Say(symbol1, symbol2,
3669         "Module subprogram '%s' has %d args but the corresponding interface"
3670         " body has %d"_err_en_US,
3671         nargs1, nargs2);
3672     return;
3673   }
3674   bool nonRecursive1{symbol1.attrs().test(Attr::NON_RECURSIVE)};
3675   if (nonRecursive1 != symbol2.attrs().test(Attr::NON_RECURSIVE)) { // C1551
3676     Say(symbol1, symbol2,
3677         nonRecursive1
3678             ? "Module subprogram '%s' has NON_RECURSIVE prefix but"
3679               " the corresponding interface body does not"_err_en_US
3680             : "Module subprogram '%s' does not have NON_RECURSIVE prefix but "
3681               "the corresponding interface body does"_err_en_US);
3682   }
3683   const std::string *bindName1{details1.bindName()};
3684   const std::string *bindName2{details2.bindName()};
3685   if (!bindName1 && !bindName2) {
3686     // OK - neither has a binding label
3687   } else if (!bindName1) {
3688     Say(symbol1, symbol2,
3689         "Module subprogram '%s' does not have a binding label but the"
3690         " corresponding interface body does"_err_en_US);
3691   } else if (!bindName2) {
3692     Say(symbol1, symbol2,
3693         "Module subprogram '%s' has a binding label but the"
3694         " corresponding interface body does not"_err_en_US);
3695   } else if (*bindName1 != *bindName2) {
3696     Say(symbol1, symbol2,
3697         "Module subprogram '%s' has binding label '%s' but the corresponding"
3698         " interface body has '%s'"_err_en_US,
3699         *details1.bindName(), *details2.bindName());
3700   }
3701   const Procedure *proc1{checkHelper.Characterize(symbol1)};
3702   const Procedure *proc2{checkHelper.Characterize(symbol2)};
3703   if (!proc1 || !proc2) {
3704     return;
3705   }
3706   if (proc1->attrs.test(Procedure::Attr::Pure) !=
3707       proc2->attrs.test(Procedure::Attr::Pure)) {
3708     Say(symbol1, symbol2,
3709         "Module subprogram '%s' and its corresponding interface body are not both PURE"_err_en_US);
3710   }
3711   if (proc1->attrs.test(Procedure::Attr::Elemental) !=
3712       proc2->attrs.test(Procedure::Attr::Elemental)) {
3713     Say(symbol1, symbol2,
3714         "Module subprogram '%s' and its corresponding interface body are not both ELEMENTAL"_err_en_US);
3715   }
3716   if (proc1->attrs.test(Procedure::Attr::BindC) !=
3717       proc2->attrs.test(Procedure::Attr::BindC)) {
3718     Say(symbol1, symbol2,
3719         "Module subprogram '%s' and its corresponding interface body are not both BIND(C)"_err_en_US);
3720   }
3721   if (proc1->functionResult && proc2->functionResult) {
3722     std::string whyNot;
3723     if (!proc1->functionResult->IsCompatibleWith(
3724             *proc2->functionResult, &whyNot)) {
3725       Say(symbol1, symbol2,
3726           "Result of function '%s' is not compatible with the result of the corresponding interface body: %s"_err_en_US,
3727           whyNot);
3728     }
3729   }
3730   for (int i{0}; i < nargs1; ++i) {
3731     const Symbol *arg1{args1[i]};
3732     const Symbol *arg2{args2[i]};
3733     if (arg1 && !arg2) {
3734       Say(symbol1, symbol2,
3735           "Dummy argument %2$d of '%1$s' is not an alternate return indicator"
3736           " but the corresponding argument in the interface body is"_err_en_US,
3737           i + 1);
3738     } else if (!arg1 && arg2) {
3739       Say(symbol1, symbol2,
3740           "Dummy argument %2$d of '%1$s' is an alternate return indicator but"
3741           " the corresponding argument in the interface body is not"_err_en_US,
3742           i + 1);
3743     } else if (arg1 && arg2) {
3744       SourceName name1{arg1->name()};
3745       SourceName name2{arg2->name()};
3746       if (name1 != name2) {
3747         Say(*arg1, *arg2,
3748             "Dummy argument name '%s' does not match corresponding name '%s'"
3749             " in interface body"_err_en_US,
3750             name2);
3751       } else {
3752         CheckDummyArg(
3753             *arg1, *arg2, proc1->dummyArguments[i], proc2->dummyArguments[i]);
3754       }
3755     }
3756   }
3757 }
3758
3759 void SubprogramMatchHelper::CheckDummyArg(const Symbol &symbol1,
3760     const Symbol &symbol2, const DummyArgument &arg1,
3761     const DummyArgument &arg2) {
3762   common::visit(
3763       common::visitors{
3764           [&](const DummyDataObject &obj1, const DummyDataObject &obj2) {
3765             CheckDummyDataObject(symbol1, symbol2, obj1, obj2);
3766           },
3767           [&](const DummyProcedure &proc1, const DummyProcedure &proc2) {
3768             CheckDummyProcedure(symbol1, symbol2, proc1, proc2);
3769           },
3770           [&](const DummyDataObject &, const auto &) {
3771             Say(symbol1, symbol2,
3772                 "Dummy argument '%s' is a data object; the corresponding"
3773                 " argument in the interface body is not"_err_en_US);
3774           },
3775           [&](const DummyProcedure &, const auto &) {
3776             Say(symbol1, symbol2,
3777                 "Dummy argument '%s' is a procedure; the corresponding"
3778                 " argument in the interface body is not"_err_en_US);
3779           },
3780           [&](const auto &, const auto &) {
3781             llvm_unreachable("Dummy arguments are not data objects or"
3782                              "procedures");
3783           },
3784       },
3785       arg1.u, arg2.u);
3786 }
3787
3788 void SubprogramMatchHelper::CheckDummyDataObject(const Symbol &symbol1,
3789     const Symbol &symbol2, const DummyDataObject &obj1,
3790     const DummyDataObject &obj2) {
3791   if (!CheckSameIntent(symbol1, symbol2, obj1.intent, obj2.intent)) {
3792   } else if (!CheckSameAttrs(symbol1, symbol2, obj1.attrs, obj2.attrs)) {
3793   } else if (!obj1.type.type().IsEquivalentTo(obj2.type.type())) {
3794     Say(symbol1, symbol2,
3795         "Dummy argument '%s' has type %s; the corresponding argument in the interface body has distinct type %s"_err_en_US,
3796         obj1.type.type().AsFortran(), obj2.type.type().AsFortran());
3797   } else if (!ShapesAreCompatible(obj1, obj2)) {
3798     Say(symbol1, symbol2,
3799         "The shape of dummy argument '%s' does not match the shape of the"
3800         " corresponding argument in the interface body"_err_en_US);
3801   }
3802   // TODO: coshape
3803 }
3804
3805 void SubprogramMatchHelper::CheckDummyProcedure(const Symbol &symbol1,
3806     const Symbol &symbol2, const DummyProcedure &proc1,
3807     const DummyProcedure &proc2) {
3808   std::string whyNot;
3809   if (!CheckSameIntent(symbol1, symbol2, proc1.intent, proc2.intent)) {
3810   } else if (!CheckSameAttrs(symbol1, symbol2, proc1.attrs, proc2.attrs)) {
3811   } else if (!proc2.IsCompatibleWith(proc1, &whyNot)) {
3812     Say(symbol1, symbol2,
3813         "Dummy procedure '%s' is not compatible with the corresponding argument in the interface body: %s"_err_en_US,
3814         whyNot);
3815   } else if (proc1 != proc2) {
3816     evaluate::AttachDeclaration(
3817         symbol1.owner().context().Warn(
3818             common::UsageWarning::MismatchingDummyProcedure,
3819             "Dummy procedure '%s' does not exactly match the corresponding argument in the interface body"_warn_en_US,
3820             symbol1.name()),
3821         symbol2);
3822   }
3823 }
3824
3825 bool SubprogramMatchHelper::CheckSameIntent(const Symbol &symbol1,
3826     const Symbol &symbol2, common::Intent intent1, common::Intent intent2) {
3827   if (intent1 == intent2) {
3828     return true;
3829   } else {
3830     Say(symbol1, symbol2,
3831         "The intent of dummy argument '%s' does not match the intent"
3832         " of the corresponding argument in the interface body"_err_en_US);
3833     return false;
3834   }
3835 }
3836
3837 // Report an error referring to first symbol with declaration of second symbol
3838 template <typename... A>
3839 void SubprogramMatchHelper::Say(const Symbol &symbol1, const Symbol &symbol2,
3840     parser::MessageFixedText &&text, A &&...args) {
3841   auto &message{context().Say(symbol1.name(), std::move(text), symbol1.name(),
3842       std::forward<A>(args)...)};
3843   evaluate::AttachDeclaration(message, symbol2);
3844 }
3845
3846 template <typename ATTRS>
3847 bool SubprogramMatchHelper::CheckSameAttrs(
3848     const Symbol &symbol1, const Symbol &symbol2, ATTRS attrs1, ATTRS attrs2) {
3849   if (attrs1 == attrs2) {
3850     return true;
3851   }
3852   attrs1.IterateOverMembers([&](auto attr) {
3853     if (!attrs2.test(attr)) {
3854       Say(symbol1, symbol2,
3855           "Dummy argument '%s' has the %s attribute; the corresponding"
3856           " argument in the interface body does not"_err_en_US,
3857           AsFortran(attr));
3858     }
3859   });
3860   attrs2.IterateOverMembers([&](auto attr) {
3861     if (!attrs1.test(attr)) {
3862       Say(symbol1, symbol2,
3863           "Dummy argument '%s' does not have the %s attribute; the"
3864           " corresponding argument in the interface body does"_err_en_US,
3865           AsFortran(attr));
3866     }
3867   });
3868   return false;
3869 }
3870
3871 bool SubprogramMatchHelper::ShapesAreCompatible(
3872     const DummyDataObject &obj1, const DummyDataObject &obj2) {
3873   return characteristics::ShapesAreCompatible(
3874       FoldShape(obj1.type.shape()), FoldShape(obj2.type.shape()));
3875 }
3876
3877 evaluate::Shape SubprogramMatchHelper::FoldShape(const evaluate::Shape &shape) {
3878   evaluate::Shape result;
3879   for (const auto &extent : shape) {
3880     result.emplace_back(
3881         evaluate::Fold(context().foldingContext(), common::Clone(extent)));
3882   }
3883   return result;
3884 }
3885
3886 void DistinguishabilityHelper::Add(const Symbol &generic, GenericKind kind,
3887     const Symbol &ultimateSpecific, const Procedure &procedure) {
3888   if (!context_.HasError(ultimateSpecific)) {
3889     nameToSpecifics_[generic.name()].emplace(
3890         &ultimateSpecific, ProcedureInfo{kind, procedure});
3891   }
3892 }
3893
3894 void DistinguishabilityHelper::Check(const Scope &scope) {
3895   if (FindModuleFileContaining(scope)) {
3896     // Distinguishability was checked when the module was created;
3897     // don't let optional warnings then become errors now.
3898     return;
3899   }
3900   for (const auto &[name, info] : nameToSpecifics_) {
3901     for (auto iter1{info.begin()}; iter1 != info.end(); ++iter1) {
3902       const auto &[ultimate, procInfo]{*iter1};
3903       const auto &[kind, proc]{procInfo};
3904       for (auto iter2{iter1}; ++iter2 != info.end();) {
3905         auto distinguishable{kind.IsName()
3906                 ? evaluate::characteristics::Distinguishable
3907                 : evaluate::characteristics::DistinguishableOpOrAssign};
3908         std::optional<bool> distinct{distinguishable(
3909             context_.languageFeatures(), proc, iter2->second.procedure)};
3910         if (!distinct.value_or(false)) {
3911           SayNotDistinguishable(GetTopLevelUnitContaining(scope), name, kind,
3912               *ultimate, *iter2->first, distinct.has_value());
3913         }
3914       }
3915     }
3916   }
3917 }
3918
3919 void DistinguishabilityHelper::SayNotDistinguishable(const Scope &scope,
3920     const SourceName &name, GenericKind kind, const Symbol &proc1,
3921     const Symbol &proc2, bool isHardConflict) {
3922   bool isUseAssociated{!scope.sourceRange().Contains(name)};
3923   // The rules for distinguishing specific procedures (F'2023 15.4.3.4.5)
3924   // are inadequate for some real-world cases like pFUnit.
3925   // When there are optional dummy arguments or unlimited polymorphic
3926   // dummy data object arguments, the best that we can do is emit an optional
3927   // portability warning.  Also, named generics created by USE association
3928   // merging shouldn't receive hard errors for ambiguity.
3929   // (Non-named generics might be defined I/O procedures or defined
3930   // assignments that need to be used by the runtime.)
3931   bool isWarning{!isHardConflict || (isUseAssociated && kind.IsName())};
3932   if (isWarning &&
3933       (!context_.ShouldWarn(
3934            common::LanguageFeature::IndistinguishableSpecifics) ||
3935           FindModuleFileContaining(scope))) {
3936     return;
3937   }
3938   std::string name1{proc1.name().ToString()};
3939   std::string name2{proc2.name().ToString()};
3940   if (kind.IsOperator() || kind.IsAssignment()) {
3941     // proc1 and proc2 may come from different scopes so qualify their names
3942     if (proc1.owner().IsDerivedType()) {
3943       name1 = proc1.owner().GetName()->ToString() + '%' + name1;
3944     }
3945     if (proc2.owner().IsDerivedType()) {
3946       name2 = proc2.owner().GetName()->ToString() + '%' + name2;
3947     }
3948   }
3949   parser::Message *msg;
3950   if (!isUseAssociated) {
3951     CHECK(isWarning == !isHardConflict);
3952     msg = &context_.Say(name,
3953         isHardConflict
3954             ? "Generic '%s' may not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_err_en_US
3955             : "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,
3956         MakeOpName(name), name1, name2);
3957   } else {
3958     msg = &context_.Say(*GetTopLevelUnitContaining(proc1).GetName(),
3959         isHardConflict
3960             ? (isWarning
3961                       ? "USE-associated generic '%s' should not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_warn_en_US
3962                       : "USE-associated generic '%s' may not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_err_en_US)
3963             : "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,
3964         MakeOpName(name), name1, name2);
3965   }
3966   AttachDeclaration(*msg, scope, proc1);
3967   AttachDeclaration(*msg, scope, proc2);
3968 }
3969
3970 // `evaluate::AttachDeclaration` doesn't handle the generic case where `proc`
3971 // comes from a different module but is not necessarily use-associated.
3972 void DistinguishabilityHelper::AttachDeclaration(
3973     parser::Message &msg, const Scope &scope, const Symbol &proc) {
3974   const Scope &unit{GetTopLevelUnitContaining(proc)};
3975   if (unit == scope) {
3976     evaluate::AttachDeclaration(msg, proc);
3977   } else {
3978     msg.Attach(unit.GetName().value(),
3979         "'%s' is USE-associated from module '%s'"_en_US, proc.name(),
3980         unit.GetName().value());
3981   }
3982 }
3983
3984 void CheckDeclarations(SemanticsContext &context) {
3985   CheckHelper{context}.Check();
3986 }
3987 } // namespace Fortran::semantics