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