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