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 "pointer-assignment.h" 13 #include "flang/Evaluate/check-expression.h" 14 #include "flang/Evaluate/fold.h" 15 #include "flang/Evaluate/tools.h" 16 #include "flang/Semantics/scope.h" 17 #include "flang/Semantics/semantics.h" 18 #include "flang/Semantics/symbol.h" 19 #include "flang/Semantics/tools.h" 20 #include "flang/Semantics/type.h" 21 #include <algorithm> 22 #include <map> 23 #include <string> 24 25 namespace Fortran::semantics { 26 27 namespace characteristics = evaluate::characteristics; 28 using characteristics::DummyArgument; 29 using characteristics::DummyDataObject; 30 using characteristics::DummyProcedure; 31 using characteristics::FunctionResult; 32 using characteristics::Procedure; 33 34 class CheckHelper { 35 public: 36 explicit CheckHelper(SemanticsContext &c) : context_{c} {} 37 CheckHelper(SemanticsContext &c, const Scope &s) : context_{c}, scope_{&s} {} 38 39 SemanticsContext &context() { return context_; } 40 void Check() { Check(context_.globalScope()); } 41 void Check(const ParamValue &, bool canBeAssumed); 42 void Check(const Bound &bound) { CheckSpecExpr(bound.GetExplicit()); } 43 void Check(const ShapeSpec &spec) { 44 Check(spec.lbound()); 45 Check(spec.ubound()); 46 } 47 void Check(const ArraySpec &); 48 void Check(const DeclTypeSpec &, bool canHaveAssumedTypeParameters); 49 void Check(const Symbol &); 50 void Check(const Scope &); 51 const Procedure *Characterize(const Symbol &); 52 53 private: 54 template <typename A> void CheckSpecExpr(const A &x) { 55 evaluate::CheckSpecificationExpr(x, DEREF(scope_), foldingContext_); 56 } 57 void CheckValue(const Symbol &, const DerivedTypeSpec *); 58 void CheckVolatile(const Symbol &, const DerivedTypeSpec *); 59 void CheckPointer(const Symbol &); 60 void CheckPassArg( 61 const Symbol &proc, const Symbol *interface, const WithPassArg &); 62 void CheckProcBinding(const Symbol &, const ProcBindingDetails &); 63 void CheckObjectEntity(const Symbol &, const ObjectEntityDetails &); 64 void CheckPointerInitialization(const Symbol &); 65 void CheckArraySpec(const Symbol &, const ArraySpec &); 66 void CheckProcEntity(const Symbol &, const ProcEntityDetails &); 67 void CheckSubprogram(const Symbol &, const SubprogramDetails &); 68 void CheckAssumedTypeEntity(const Symbol &, const ObjectEntityDetails &); 69 void CheckDerivedType(const Symbol &, const DerivedTypeDetails &); 70 bool CheckFinal( 71 const Symbol &subroutine, SourceName, const Symbol &derivedType); 72 bool CheckDistinguishableFinals(const Symbol &f1, SourceName f1name, 73 const Symbol &f2, SourceName f2name, const Symbol &derivedType); 74 void CheckGeneric(const Symbol &, const GenericDetails &); 75 void CheckHostAssoc(const Symbol &, const HostAssocDetails &); 76 bool CheckDefinedOperator( 77 SourceName, GenericKind, const Symbol &, const Procedure &); 78 std::optional<parser::MessageFixedText> CheckNumberOfArgs( 79 const GenericKind &, std::size_t); 80 bool CheckDefinedOperatorArg( 81 const SourceName &, const Symbol &, const Procedure &, std::size_t); 82 bool CheckDefinedAssignment(const Symbol &, const Procedure &); 83 bool CheckDefinedAssignmentArg(const Symbol &, const DummyArgument &, int); 84 void CheckSpecificsAreDistinguishable(const Symbol &, const GenericDetails &); 85 void CheckEquivalenceSet(const EquivalenceSet &); 86 void CheckBlockData(const Scope &); 87 void CheckGenericOps(const Scope &); 88 bool CheckConflicting(const Symbol &, Attr, Attr); 89 void WarnMissingFinal(const Symbol &); 90 bool InPure() const { 91 return innermostSymbol_ && IsPureProcedure(*innermostSymbol_); 92 } 93 bool InElemental() const { 94 return innermostSymbol_ && innermostSymbol_->attrs().test(Attr::ELEMENTAL); 95 } 96 bool InFunction() const { 97 return innermostSymbol_ && IsFunction(*innermostSymbol_); 98 } 99 template <typename... A> 100 void SayWithDeclaration(const Symbol &symbol, A &&...x) { 101 if (parser::Message * msg{messages_.Say(std::forward<A>(x)...)}) { 102 if (messages_.at().begin() != symbol.name().begin()) { 103 evaluate::AttachDeclaration(*msg, symbol); 104 } 105 } 106 } 107 bool IsResultOkToDiffer(const FunctionResult &); 108 void CheckBindCName(const Symbol &); 109 // Check functions for defined I/O procedures 110 void CheckDefinedIoProc( 111 const Symbol &, const GenericDetails &, GenericKind::DefinedIo); 112 bool CheckDioDummyIsData(const Symbol &, const Symbol *, std::size_t); 113 void CheckDioDummyIsDerived( 114 const Symbol &, const Symbol &, GenericKind::DefinedIo ioKind); 115 void CheckDioDummyIsDefaultInteger(const Symbol &, const Symbol &); 116 void CheckDioDummyIsScalar(const Symbol &, const Symbol &); 117 void CheckDioDummyAttrs(const Symbol &, const Symbol &, Attr); 118 void CheckDioDtvArg(const Symbol &, const Symbol *, GenericKind::DefinedIo); 119 void CheckDefaultIntegerArg(const Symbol &, const Symbol *, Attr); 120 void CheckDioAssumedLenCharacterArg( 121 const Symbol &, const Symbol *, std::size_t, Attr); 122 void CheckDioVlistArg(const Symbol &, const Symbol *, std::size_t); 123 void CheckDioArgCount( 124 const Symbol &, GenericKind::DefinedIo ioKind, std::size_t); 125 struct TypeWithDefinedIo { 126 const DerivedTypeSpec *type; 127 GenericKind::DefinedIo ioKind; 128 const Symbol &proc; 129 }; 130 void CheckAlreadySeenDefinedIo( 131 const DerivedTypeSpec *, GenericKind::DefinedIo, const Symbol &); 132 133 SemanticsContext &context_; 134 evaluate::FoldingContext &foldingContext_{context_.foldingContext()}; 135 parser::ContextualMessages &messages_{foldingContext_.messages()}; 136 const Scope *scope_{nullptr}; 137 bool scopeIsUninstantiatedPDT_{false}; 138 // This symbol is the one attached to the innermost enclosing scope 139 // that has a symbol. 140 const Symbol *innermostSymbol_{nullptr}; 141 // Cache of calls to Procedure::Characterize(Symbol) 142 std::map<SymbolRef, std::optional<Procedure>, SymbolAddressCompare> 143 characterizeCache_; 144 // Collection of symbols with BIND(C) names 145 std::map<std::string, SymbolRef> bindC_; 146 // Derived types that have defined input/output procedures 147 std::vector<TypeWithDefinedIo> seenDefinedIoTypes_; 148 }; 149 150 class DistinguishabilityHelper { 151 public: 152 DistinguishabilityHelper(SemanticsContext &context) : context_{context} {} 153 void Add(const Symbol &, GenericKind, const Symbol &, const Procedure &); 154 void Check(const Scope &); 155 156 private: 157 void SayNotDistinguishable(const Scope &, const SourceName &, GenericKind, 158 const Symbol &, const Symbol &); 159 void AttachDeclaration(parser::Message &, const Scope &, const Symbol &); 160 161 SemanticsContext &context_; 162 struct ProcedureInfo { 163 GenericKind kind; 164 const Symbol &symbol; 165 const Procedure &procedure; 166 }; 167 std::map<SourceName, std::vector<ProcedureInfo>> nameToInfo_; 168 }; 169 170 void CheckHelper::Check(const ParamValue &value, bool canBeAssumed) { 171 if (value.isAssumed()) { 172 if (!canBeAssumed) { // C795, C721, C726 173 messages_.Say( 174 "An assumed (*) type parameter may be used only for a (non-statement" 175 " function) dummy argument, associate name, named constant, or" 176 " external function result"_err_en_US); 177 } 178 } else { 179 CheckSpecExpr(value.GetExplicit()); 180 } 181 } 182 183 void CheckHelper::Check(const ArraySpec &shape) { 184 for (const auto &spec : shape) { 185 Check(spec); 186 } 187 } 188 189 void CheckHelper::Check( 190 const DeclTypeSpec &type, bool canHaveAssumedTypeParameters) { 191 if (type.category() == DeclTypeSpec::Character) { 192 Check(type.characterTypeSpec().length(), canHaveAssumedTypeParameters); 193 } else if (const DerivedTypeSpec * derived{type.AsDerived()}) { 194 for (auto &parm : derived->parameters()) { 195 Check(parm.second, canHaveAssumedTypeParameters); 196 } 197 } 198 } 199 200 void CheckHelper::Check(const Symbol &symbol) { 201 if (context_.HasError(symbol)) { 202 return; 203 } 204 auto restorer{messages_.SetLocation(symbol.name())}; 205 context_.set_location(symbol.name()); 206 const DeclTypeSpec *type{symbol.GetType()}; 207 const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr}; 208 bool isDone{false}; 209 std::visit( 210 common::visitors{ 211 [&](const UseDetails &x) { isDone = true; }, 212 [&](const HostAssocDetails &x) { 213 CheckHostAssoc(symbol, x); 214 isDone = true; 215 }, 216 [&](const ProcBindingDetails &x) { 217 CheckProcBinding(symbol, x); 218 isDone = true; 219 }, 220 [&](const ObjectEntityDetails &x) { CheckObjectEntity(symbol, x); }, 221 [&](const ProcEntityDetails &x) { CheckProcEntity(symbol, x); }, 222 [&](const SubprogramDetails &x) { CheckSubprogram(symbol, x); }, 223 [&](const DerivedTypeDetails &x) { CheckDerivedType(symbol, x); }, 224 [&](const GenericDetails &x) { CheckGeneric(symbol, x); }, 225 [](const auto &) {}, 226 }, 227 symbol.details()); 228 if (symbol.attrs().test(Attr::VOLATILE)) { 229 CheckVolatile(symbol, derived); 230 } 231 CheckBindCName(symbol); 232 if (isDone) { 233 return; // following checks do not apply 234 } 235 if (IsPointer(symbol)) { 236 CheckPointer(symbol); 237 } 238 if (InPure()) { 239 if (IsSaved(symbol)) { 240 messages_.Say( 241 "A pure subprogram may not have a variable with the SAVE attribute"_err_en_US); 242 } 243 if (symbol.attrs().test(Attr::VOLATILE)) { 244 messages_.Say( 245 "A pure subprogram may not have a variable with the VOLATILE attribute"_err_en_US); 246 } 247 if (IsProcedure(symbol) && !IsPureProcedure(symbol) && IsDummy(symbol)) { 248 messages_.Say( 249 "A dummy procedure of a pure subprogram must be pure"_err_en_US); 250 } 251 if (!IsDummy(symbol) && !IsFunctionResult(symbol)) { 252 if (IsPolymorphicAllocatable(symbol)) { 253 SayWithDeclaration(symbol, 254 "Deallocation of polymorphic object '%s' is not permitted in a pure subprogram"_err_en_US, 255 symbol.name()); 256 } else if (derived) { 257 if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) { 258 SayWithDeclaration(*bad, 259 "Deallocation of polymorphic object '%s%s' is not permitted in a pure subprogram"_err_en_US, 260 symbol.name(), bad.BuildResultDesignatorName()); 261 } 262 } 263 } 264 } 265 if (type) { // Section 7.2, paragraph 7 266 bool canHaveAssumedParameter{IsNamedConstant(symbol) || 267 (IsAssumedLengthCharacter(symbol) && // C722 268 IsExternal(symbol)) || 269 symbol.test(Symbol::Flag::ParentComp)}; 270 if (!IsStmtFunctionDummy(symbol)) { // C726 271 if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) { 272 canHaveAssumedParameter |= object->isDummy() || 273 (object->isFuncResult() && 274 type->category() == DeclTypeSpec::Character) || 275 IsStmtFunctionResult(symbol); // Avoids multiple messages 276 } else { 277 canHaveAssumedParameter |= symbol.has<AssocEntityDetails>(); 278 } 279 } 280 Check(*type, canHaveAssumedParameter); 281 if (InPure() && InFunction() && IsFunctionResult(symbol)) { 282 if (derived && HasImpureFinal(*derived)) { // C1584 283 messages_.Say( 284 "Result of pure function may not have an impure FINAL subroutine"_err_en_US); 285 } 286 if (type->IsPolymorphic() && IsAllocatable(symbol)) { // C1585 287 messages_.Say( 288 "Result of pure function may not be both polymorphic and ALLOCATABLE"_err_en_US); 289 } 290 if (derived) { 291 if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) { 292 SayWithDeclaration(*bad, 293 "Result of pure function may not have polymorphic ALLOCATABLE ultimate component '%s'"_err_en_US, 294 bad.BuildResultDesignatorName()); 295 } 296 } 297 } 298 } 299 if (IsAssumedLengthCharacter(symbol) && IsExternal(symbol)) { // C723 300 if (symbol.attrs().test(Attr::RECURSIVE)) { 301 messages_.Say( 302 "An assumed-length CHARACTER(*) function cannot be RECURSIVE"_err_en_US); 303 } 304 if (symbol.Rank() > 0) { 305 messages_.Say( 306 "An assumed-length CHARACTER(*) function cannot return an array"_err_en_US); 307 } 308 if (symbol.attrs().test(Attr::PURE)) { 309 messages_.Say( 310 "An assumed-length CHARACTER(*) function cannot be PURE"_err_en_US); 311 } 312 if (symbol.attrs().test(Attr::ELEMENTAL)) { 313 messages_.Say( 314 "An assumed-length CHARACTER(*) function cannot be ELEMENTAL"_err_en_US); 315 } 316 if (const Symbol * result{FindFunctionResult(symbol)}) { 317 if (IsPointer(*result)) { 318 messages_.Say( 319 "An assumed-length CHARACTER(*) function cannot return a POINTER"_err_en_US); 320 } 321 } 322 } 323 if (symbol.attrs().test(Attr::VALUE)) { 324 CheckValue(symbol, derived); 325 } 326 if (symbol.attrs().test(Attr::CONTIGUOUS) && IsPointer(symbol) && 327 symbol.Rank() == 0) { // C830 328 messages_.Say("CONTIGUOUS POINTER must be an array"_err_en_US); 329 } 330 if (IsDummy(symbol)) { 331 if (IsNamedConstant(symbol)) { 332 messages_.Say( 333 "A dummy argument may not also be a named constant"_err_en_US); 334 } 335 if (!symbol.test(Symbol::Flag::InDataStmt) /*caught elsewhere*/ && 336 IsSaved(symbol)) { 337 messages_.Say( 338 "A dummy argument may not have the SAVE attribute"_err_en_US); 339 } 340 } else if (IsFunctionResult(symbol)) { 341 if (!symbol.test(Symbol::Flag::InDataStmt) /*caught elsewhere*/ && 342 IsSaved(symbol)) { 343 messages_.Say( 344 "A function result may not have the SAVE attribute"_err_en_US); 345 } 346 } 347 if (symbol.owner().IsDerivedType() && 348 (symbol.attrs().test(Attr::CONTIGUOUS) && 349 !(IsPointer(symbol) && symbol.Rank() > 0))) { // C752 350 messages_.Say( 351 "A CONTIGUOUS component must be an array with the POINTER attribute"_err_en_US); 352 } 353 if (symbol.owner().IsModule() && IsAutomatic(symbol)) { 354 messages_.Say( 355 "Automatic data object '%s' may not appear in the specification part" 356 " of a module"_err_en_US, 357 symbol.name()); 358 } 359 } 360 361 void CheckHelper::CheckValue( 362 const Symbol &symbol, const DerivedTypeSpec *derived) { // C863 - C865 363 if (!IsDummy(symbol)) { 364 messages_.Say( 365 "VALUE attribute may apply only to a dummy argument"_err_en_US); 366 } 367 if (IsProcedure(symbol)) { 368 messages_.Say( 369 "VALUE attribute may apply only to a dummy data object"_err_en_US); 370 } 371 if (IsAssumedSizeArray(symbol)) { 372 messages_.Say( 373 "VALUE attribute may not apply to an assumed-size array"_err_en_US); 374 } 375 if (evaluate::IsCoarray(symbol)) { 376 messages_.Say("VALUE attribute may not apply to a coarray"_err_en_US); 377 } 378 if (IsAllocatable(symbol)) { 379 messages_.Say("VALUE attribute may not apply to an ALLOCATABLE"_err_en_US); 380 } else if (IsPointer(symbol)) { 381 messages_.Say("VALUE attribute may not apply to a POINTER"_err_en_US); 382 } 383 if (IsIntentInOut(symbol)) { 384 messages_.Say( 385 "VALUE attribute may not apply to an INTENT(IN OUT) argument"_err_en_US); 386 } else if (IsIntentOut(symbol)) { 387 messages_.Say( 388 "VALUE attribute may not apply to an INTENT(OUT) argument"_err_en_US); 389 } 390 if (symbol.attrs().test(Attr::VOLATILE)) { 391 messages_.Say("VALUE attribute may not apply to a VOLATILE"_err_en_US); 392 } 393 if (innermostSymbol_ && IsBindCProcedure(*innermostSymbol_) && 394 IsOptional(symbol)) { 395 messages_.Say( 396 "VALUE attribute may not apply to an OPTIONAL in a BIND(C) procedure"_err_en_US); 397 } 398 if (derived) { 399 if (FindCoarrayUltimateComponent(*derived)) { 400 messages_.Say( 401 "VALUE attribute may not apply to a type with a coarray ultimate component"_err_en_US); 402 } 403 } 404 } 405 406 void CheckHelper::CheckAssumedTypeEntity( // C709 407 const Symbol &symbol, const ObjectEntityDetails &details) { 408 if (const DeclTypeSpec * type{symbol.GetType()}; 409 type && type->category() == DeclTypeSpec::TypeStar) { 410 if (!IsDummy(symbol)) { 411 messages_.Say( 412 "Assumed-type entity '%s' must be a dummy argument"_err_en_US, 413 symbol.name()); 414 } else { 415 if (symbol.attrs().test(Attr::ALLOCATABLE)) { 416 messages_.Say("Assumed-type argument '%s' cannot have the ALLOCATABLE" 417 " attribute"_err_en_US, 418 symbol.name()); 419 } 420 if (symbol.attrs().test(Attr::POINTER)) { 421 messages_.Say("Assumed-type argument '%s' cannot have the POINTER" 422 " attribute"_err_en_US, 423 symbol.name()); 424 } 425 if (symbol.attrs().test(Attr::VALUE)) { 426 messages_.Say("Assumed-type argument '%s' cannot have the VALUE" 427 " attribute"_err_en_US, 428 symbol.name()); 429 } 430 if (symbol.attrs().test(Attr::INTENT_OUT)) { 431 messages_.Say( 432 "Assumed-type argument '%s' cannot be INTENT(OUT)"_err_en_US, 433 symbol.name()); 434 } 435 if (evaluate::IsCoarray(symbol)) { 436 messages_.Say( 437 "Assumed-type argument '%s' cannot be a coarray"_err_en_US, 438 symbol.name()); 439 } 440 if (details.IsArray() && details.shape().IsExplicitShape()) { 441 messages_.Say( 442 "Assumed-type array argument 'arg8' must be assumed shape," 443 " assumed size, or assumed rank"_err_en_US, 444 symbol.name()); 445 } 446 } 447 } 448 } 449 450 void CheckHelper::CheckObjectEntity( 451 const Symbol &symbol, const ObjectEntityDetails &details) { 452 CheckArraySpec(symbol, details.shape()); 453 Check(details.shape()); 454 Check(details.coshape()); 455 CheckAssumedTypeEntity(symbol, details); 456 WarnMissingFinal(symbol); 457 if (!details.coshape().empty()) { 458 bool isDeferredCoshape{details.coshape().CanBeDeferredShape()}; 459 if (IsAllocatable(symbol)) { 460 if (!isDeferredCoshape) { // C827 461 messages_.Say("'%s' is an ALLOCATABLE coarray and must have a deferred" 462 " coshape"_err_en_US, 463 symbol.name()); 464 } 465 } else if (symbol.owner().IsDerivedType()) { // C746 466 std::string deferredMsg{ 467 isDeferredCoshape ? "" : " and have a deferred coshape"}; 468 messages_.Say("Component '%s' is a coarray and must have the ALLOCATABLE" 469 " attribute%s"_err_en_US, 470 symbol.name(), deferredMsg); 471 } else { 472 if (!details.coshape().CanBeAssumedSize()) { // C828 473 messages_.Say( 474 "'%s' is a non-ALLOCATABLE coarray and must have an explicit coshape"_err_en_US, 475 symbol.name()); 476 } 477 } 478 if (const DeclTypeSpec * type{details.type()}) { 479 if (IsBadCoarrayType(type->AsDerived())) { // C747 & C824 480 messages_.Say( 481 "Coarray '%s' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR"_err_en_US, 482 symbol.name()); 483 } 484 } 485 } 486 if (details.isDummy()) { 487 if (symbol.attrs().test(Attr::INTENT_OUT)) { 488 if (FindUltimateComponent(symbol, [](const Symbol &x) { 489 return evaluate::IsCoarray(x) && IsAllocatable(x); 490 })) { // C846 491 messages_.Say( 492 "An INTENT(OUT) dummy argument may not be, or contain, an ALLOCATABLE coarray"_err_en_US); 493 } 494 if (IsOrContainsEventOrLockComponent(symbol)) { // C847 495 messages_.Say( 496 "An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE"_err_en_US); 497 } 498 } 499 if (InPure() && !IsStmtFunction(DEREF(innermostSymbol_)) && 500 !IsPointer(symbol) && !IsIntentIn(symbol) && 501 !symbol.attrs().test(Attr::VALUE)) { 502 if (InFunction()) { // C1583 503 messages_.Say( 504 "non-POINTER dummy argument of pure function must be INTENT(IN) or VALUE"_err_en_US); 505 } else if (IsIntentOut(symbol)) { 506 if (const DeclTypeSpec * type{details.type()}) { 507 if (type && type->IsPolymorphic()) { // C1588 508 messages_.Say( 509 "An INTENT(OUT) dummy argument of a pure subroutine may not be polymorphic"_err_en_US); 510 } else if (const DerivedTypeSpec * derived{type->AsDerived()}) { 511 if (FindUltimateComponent(*derived, [](const Symbol &x) { 512 const DeclTypeSpec *type{x.GetType()}; 513 return type && type->IsPolymorphic(); 514 })) { // C1588 515 messages_.Say( 516 "An INTENT(OUT) dummy argument of a pure subroutine may not have a polymorphic ultimate component"_err_en_US); 517 } 518 if (HasImpureFinal(*derived)) { // C1587 519 messages_.Say( 520 "An INTENT(OUT) dummy argument of a pure subroutine may not have an impure FINAL subroutine"_err_en_US); 521 } 522 } 523 } 524 } else if (!IsIntentInOut(symbol)) { // C1586 525 messages_.Say( 526 "non-POINTER dummy argument of pure subroutine must have INTENT() or VALUE attribute"_err_en_US); 527 } 528 } 529 } else if (symbol.attrs().test(Attr::INTENT_IN) || 530 symbol.attrs().test(Attr::INTENT_OUT) || 531 symbol.attrs().test(Attr::INTENT_INOUT)) { 532 messages_.Say("INTENT attributes may apply only to a dummy " 533 "argument"_err_en_US); // C843 534 } else if (IsOptional(symbol)) { 535 messages_.Say("OPTIONAL attribute may apply only to a dummy " 536 "argument"_err_en_US); // C849 537 } 538 if (InElemental()) { 539 if (details.isDummy()) { // C15100 540 if (details.shape().Rank() > 0) { 541 messages_.Say( 542 "A dummy argument of an ELEMENTAL procedure must be scalar"_err_en_US); 543 } 544 if (IsAllocatable(symbol)) { 545 messages_.Say( 546 "A dummy argument of an ELEMENTAL procedure may not be ALLOCATABLE"_err_en_US); 547 } 548 if (evaluate::IsCoarray(symbol)) { 549 messages_.Say( 550 "A dummy argument of an ELEMENTAL procedure may not be a coarray"_err_en_US); 551 } 552 if (IsPointer(symbol)) { 553 messages_.Say( 554 "A dummy argument of an ELEMENTAL procedure may not be a POINTER"_err_en_US); 555 } 556 if (!symbol.attrs().HasAny(Attrs{Attr::VALUE, Attr::INTENT_IN, 557 Attr::INTENT_INOUT, Attr::INTENT_OUT})) { // C15102 558 messages_.Say( 559 "A dummy argument of an ELEMENTAL procedure must have an INTENT() or VALUE attribute"_err_en_US); 560 } 561 } else if (IsFunctionResult(symbol)) { // C15101 562 if (details.shape().Rank() > 0) { 563 messages_.Say( 564 "The result of an ELEMENTAL function must be scalar"_err_en_US); 565 } 566 if (IsAllocatable(symbol)) { 567 messages_.Say( 568 "The result of an ELEMENTAL function may not be ALLOCATABLE"_err_en_US); 569 } 570 if (IsPointer(symbol)) { 571 messages_.Say( 572 "The result of an ELEMENTAL function may not be a POINTER"_err_en_US); 573 } 574 } 575 } 576 if (HasDeclarationInitializer(symbol)) { // C808; ignore DATA initialization 577 CheckPointerInitialization(symbol); 578 if (IsAutomatic(symbol)) { 579 messages_.Say( 580 "An automatic variable or component must not be initialized"_err_en_US); 581 } else if (IsDummy(symbol)) { 582 messages_.Say("A dummy argument must not be initialized"_err_en_US); 583 } else if (IsFunctionResult(symbol)) { 584 messages_.Say("A function result must not be initialized"_err_en_US); 585 } else if (IsInBlankCommon(symbol)) { 586 messages_.Say( 587 "A variable in blank COMMON should not be initialized"_en_US); 588 } 589 } 590 if (symbol.owner().kind() == Scope::Kind::BlockData) { 591 if (IsAllocatable(symbol)) { 592 messages_.Say( 593 "An ALLOCATABLE variable may not appear in a BLOCK DATA subprogram"_err_en_US); 594 } else if (IsInitialized(symbol) && !FindCommonBlockContaining(symbol)) { 595 messages_.Say( 596 "An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US); 597 } 598 } 599 if (const DeclTypeSpec * type{details.type()}) { // C708 600 if (type->IsPolymorphic() && 601 !(type->IsAssumedType() || IsAllocatableOrPointer(symbol) || 602 IsDummy(symbol))) { 603 messages_.Say("CLASS entity '%s' must be a dummy argument or have " 604 "ALLOCATABLE or POINTER attribute"_err_en_US, 605 symbol.name()); 606 } 607 } 608 } 609 610 void CheckHelper::CheckPointerInitialization(const Symbol &symbol) { 611 if (IsPointer(symbol) && !context_.HasError(symbol) && 612 !scopeIsUninstantiatedPDT_) { 613 if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) { 614 if (object->init()) { // C764, C765; C808 615 if (auto designator{evaluate::AsGenericExpr(symbol)}) { 616 auto restorer{messages_.SetLocation(symbol.name())}; 617 context_.set_location(symbol.name()); 618 CheckInitialTarget(foldingContext_, *designator, *object->init()); 619 } 620 } 621 } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) { 622 if (proc->init() && *proc->init()) { 623 // C1519 - must be nonelemental external or module procedure, 624 // or an unrestricted specific intrinsic function. 625 const Symbol &ultimate{(*proc->init())->GetUltimate()}; 626 if (ultimate.attrs().test(Attr::INTRINSIC)) { 627 if (const auto intrinsic{ 628 context_.intrinsics().IsSpecificIntrinsicFunction( 629 ultimate.name().ToString())}; 630 !intrinsic || intrinsic->isRestrictedSpecific) { // C1030 631 context_.Say( 632 "Intrinsic procedure '%s' is not an unrestricted specific " 633 "intrinsic permitted for use as the initializer for procedure " 634 "pointer '%s'"_err_en_US, 635 ultimate.name(), symbol.name()); 636 } 637 } else if (!ultimate.attrs().test(Attr::EXTERNAL) && 638 ultimate.owner().kind() != Scope::Kind::Module) { 639 context_.Say("Procedure pointer '%s' initializer '%s' is neither " 640 "an external nor a module procedure"_err_en_US, 641 symbol.name(), ultimate.name()); 642 } else if (ultimate.attrs().test(Attr::ELEMENTAL)) { 643 context_.Say("Procedure pointer '%s' cannot be initialized with the " 644 "elemental procedure '%s"_err_en_US, 645 symbol.name(), ultimate.name()); 646 } else { 647 // TODO: Check the "shalls" in the 15.4.3.6 paragraphs 7-10. 648 } 649 } 650 } 651 } 652 } 653 654 // The six different kinds of array-specs: 655 // array-spec -> explicit-shape-list | deferred-shape-list 656 // | assumed-shape-list | implied-shape-list 657 // | assumed-size | assumed-rank 658 // explicit-shape -> [ lb : ] ub 659 // deferred-shape -> : 660 // assumed-shape -> [ lb ] : 661 // implied-shape -> [ lb : ] * 662 // assumed-size -> [ explicit-shape-list , ] [ lb : ] * 663 // assumed-rank -> .. 664 // Note: 665 // - deferred-shape is also an assumed-shape 666 // - A single "*" or "lb:*" might be assumed-size or implied-shape-list 667 void CheckHelper::CheckArraySpec( 668 const Symbol &symbol, const ArraySpec &arraySpec) { 669 if (arraySpec.Rank() == 0) { 670 return; 671 } 672 bool isExplicit{arraySpec.IsExplicitShape()}; 673 bool canBeDeferred{arraySpec.CanBeDeferredShape()}; 674 bool canBeImplied{arraySpec.CanBeImpliedShape()}; 675 bool canBeAssumedShape{arraySpec.CanBeAssumedShape()}; 676 bool canBeAssumedSize{arraySpec.CanBeAssumedSize()}; 677 bool isAssumedRank{arraySpec.IsAssumedRank()}; 678 std::optional<parser::MessageFixedText> msg; 679 if (symbol.test(Symbol::Flag::CrayPointee) && !isExplicit && 680 !canBeAssumedSize) { 681 msg = "Cray pointee '%s' must have must have explicit shape or" 682 " assumed size"_err_en_US; 683 } else if (IsAllocatableOrPointer(symbol) && !canBeDeferred && 684 !isAssumedRank) { 685 if (symbol.owner().IsDerivedType()) { // C745 686 if (IsAllocatable(symbol)) { 687 msg = "Allocatable array component '%s' must have" 688 " deferred shape"_err_en_US; 689 } else { 690 msg = "Array pointer component '%s' must have deferred shape"_err_en_US; 691 } 692 } else { 693 if (IsAllocatable(symbol)) { // C832 694 msg = "Allocatable array '%s' must have deferred shape or" 695 " assumed rank"_err_en_US; 696 } else { 697 msg = "Array pointer '%s' must have deferred shape or" 698 " assumed rank"_err_en_US; 699 } 700 } 701 } else if (IsDummy(symbol)) { 702 if (canBeImplied && !canBeAssumedSize) { // C836 703 msg = "Dummy array argument '%s' may not have implied shape"_err_en_US; 704 } 705 } else if (canBeAssumedShape && !canBeDeferred) { 706 msg = "Assumed-shape array '%s' must be a dummy argument"_err_en_US; 707 } else if (canBeAssumedSize && !canBeImplied) { // C833 708 msg = "Assumed-size array '%s' must be a dummy argument"_err_en_US; 709 } else if (isAssumedRank) { // C837 710 msg = "Assumed-rank array '%s' must be a dummy argument"_err_en_US; 711 } else if (canBeImplied) { 712 if (!IsNamedConstant(symbol)) { // C835, C836 713 msg = "Implied-shape array '%s' must be a named constant or a " 714 "dummy argument"_err_en_US; 715 } 716 } else if (IsNamedConstant(symbol)) { 717 if (!isExplicit && !canBeImplied) { 718 msg = "Named constant '%s' array must have constant or" 719 " implied shape"_err_en_US; 720 } 721 } else if (!IsAllocatableOrPointer(symbol) && !isExplicit) { 722 if (symbol.owner().IsDerivedType()) { // C749 723 msg = "Component array '%s' without ALLOCATABLE or POINTER attribute must" 724 " have explicit shape"_err_en_US; 725 } else { // C816 726 msg = "Array '%s' without ALLOCATABLE or POINTER attribute must have" 727 " explicit shape"_err_en_US; 728 } 729 } 730 if (msg) { 731 context_.Say(std::move(*msg), symbol.name()); 732 } 733 } 734 735 void CheckHelper::CheckProcEntity( 736 const Symbol &symbol, const ProcEntityDetails &details) { 737 if (details.isDummy()) { 738 if (!symbol.attrs().test(Attr::POINTER) && // C843 739 (symbol.attrs().test(Attr::INTENT_IN) || 740 symbol.attrs().test(Attr::INTENT_OUT) || 741 symbol.attrs().test(Attr::INTENT_INOUT))) { 742 messages_.Say("A dummy procedure without the POINTER attribute" 743 " may not have an INTENT attribute"_err_en_US); 744 } 745 if (InElemental()) { // C15100 746 messages_.Say( 747 "An ELEMENTAL subprogram may not have a dummy procedure"_err_en_US); 748 } 749 const Symbol *interface { details.interface().symbol() }; 750 if (!symbol.attrs().test(Attr::INTRINSIC) && 751 (symbol.attrs().test(Attr::ELEMENTAL) || 752 (interface && !interface->attrs().test(Attr::INTRINSIC) && 753 interface->attrs().test(Attr::ELEMENTAL)))) { 754 // There's no explicit constraint or "shall" that we can find in the 755 // standard for this check, but it seems to be implied in multiple 756 // sites, and ELEMENTAL non-intrinsic actual arguments *are* 757 // explicitly forbidden. But we allow "PROCEDURE(SIN)::dummy" 758 // because it is explicitly legal to *pass* the specific intrinsic 759 // function SIN as an actual argument. 760 messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US); 761 } 762 } else if (symbol.attrs().test(Attr::INTENT_IN) || 763 symbol.attrs().test(Attr::INTENT_OUT) || 764 symbol.attrs().test(Attr::INTENT_INOUT)) { 765 messages_.Say("INTENT attributes may apply only to a dummy " 766 "argument"_err_en_US); // C843 767 } else if (IsOptional(symbol)) { 768 messages_.Say("OPTIONAL attribute may apply only to a dummy " 769 "argument"_err_en_US); // C849 770 } else if (symbol.owner().IsDerivedType()) { 771 if (!symbol.attrs().test(Attr::POINTER)) { // C756 772 const auto &name{symbol.name()}; 773 messages_.Say(name, 774 "Procedure component '%s' must have POINTER attribute"_err_en_US, 775 name); 776 } 777 CheckPassArg(symbol, details.interface().symbol(), details); 778 } 779 if (symbol.attrs().test(Attr::POINTER)) { 780 CheckPointerInitialization(symbol); 781 if (const Symbol * interface{details.interface().symbol()}) { 782 if (interface->attrs().test(Attr::INTRINSIC)) { 783 if (const auto intrinsic{ 784 context_.intrinsics().IsSpecificIntrinsicFunction( 785 interface->name().ToString())}; 786 !intrinsic || intrinsic->isRestrictedSpecific) { // C1515 787 messages_.Say( 788 "Intrinsic procedure '%s' is not an unrestricted specific " 789 "intrinsic permitted for use as the definition of the interface " 790 "to procedure pointer '%s'"_err_en_US, 791 interface->name(), symbol.name()); 792 } 793 } else if (interface->attrs().test(Attr::ELEMENTAL)) { 794 messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US, 795 symbol.name()); // C1517 796 } 797 } 798 } else if (symbol.attrs().test(Attr::SAVE)) { 799 messages_.Say( 800 "Procedure '%s' with SAVE attribute must also have POINTER attribute"_err_en_US, 801 symbol.name()); 802 } 803 } 804 805 // When a module subprogram has the MODULE prefix the following must match 806 // with the corresponding separate module procedure interface body: 807 // - C1549: characteristics and dummy argument names 808 // - C1550: binding label 809 // - C1551: NON_RECURSIVE prefix 810 class SubprogramMatchHelper { 811 public: 812 explicit SubprogramMatchHelper(CheckHelper &checkHelper) 813 : checkHelper{checkHelper} {} 814 815 void Check(const Symbol &, const Symbol &); 816 817 private: 818 SemanticsContext &context() { return checkHelper.context(); } 819 void CheckDummyArg(const Symbol &, const Symbol &, const DummyArgument &, 820 const DummyArgument &); 821 void CheckDummyDataObject(const Symbol &, const Symbol &, 822 const DummyDataObject &, const DummyDataObject &); 823 void CheckDummyProcedure(const Symbol &, const Symbol &, 824 const DummyProcedure &, const DummyProcedure &); 825 bool CheckSameIntent( 826 const Symbol &, const Symbol &, common::Intent, common::Intent); 827 template <typename... A> 828 void Say( 829 const Symbol &, const Symbol &, parser::MessageFixedText &&, A &&...); 830 template <typename ATTRS> 831 bool CheckSameAttrs(const Symbol &, const Symbol &, ATTRS, ATTRS); 832 bool ShapesAreCompatible(const DummyDataObject &, const DummyDataObject &); 833 evaluate::Shape FoldShape(const evaluate::Shape &); 834 std::string AsFortran(DummyDataObject::Attr attr) { 835 return parser::ToUpperCaseLetters(DummyDataObject::EnumToString(attr)); 836 } 837 std::string AsFortran(DummyProcedure::Attr attr) { 838 return parser::ToUpperCaseLetters(DummyProcedure::EnumToString(attr)); 839 } 840 841 CheckHelper &checkHelper; 842 }; 843 844 // 15.6.2.6 para 3 - can the result of an ENTRY differ from its function? 845 bool CheckHelper::IsResultOkToDiffer(const FunctionResult &result) { 846 if (result.attrs.test(FunctionResult::Attr::Allocatable) || 847 result.attrs.test(FunctionResult::Attr::Pointer)) { 848 return false; 849 } 850 const auto *typeAndShape{result.GetTypeAndShape()}; 851 if (!typeAndShape || typeAndShape->Rank() != 0) { 852 return false; 853 } 854 auto category{typeAndShape->type().category()}; 855 if (category == TypeCategory::Character || 856 category == TypeCategory::Derived) { 857 return false; 858 } 859 int kind{typeAndShape->type().kind()}; 860 return kind == context_.GetDefaultKind(category) || 861 (category == TypeCategory::Real && 862 kind == context_.doublePrecisionKind()); 863 } 864 865 void CheckHelper::CheckSubprogram( 866 const Symbol &symbol, const SubprogramDetails &details) { 867 if (const Symbol * iface{FindSeparateModuleSubprogramInterface(&symbol)}) { 868 SubprogramMatchHelper{*this}.Check(symbol, *iface); 869 } 870 if (const Scope * entryScope{details.entryScope()}) { 871 // ENTRY 15.6.2.6, esp. C1571 872 std::optional<parser::MessageFixedText> error; 873 const Symbol *subprogram{entryScope->symbol()}; 874 const SubprogramDetails *subprogramDetails{nullptr}; 875 if (subprogram) { 876 subprogramDetails = subprogram->detailsIf<SubprogramDetails>(); 877 } 878 if (entryScope->kind() != Scope::Kind::Subprogram) { 879 error = "ENTRY may appear only in a subroutine or function"_err_en_US; 880 } else if (!(entryScope->parent().IsGlobal() || 881 entryScope->parent().IsModule() || 882 entryScope->parent().IsSubmodule())) { 883 error = "ENTRY may not appear in an internal subprogram"_err_en_US; 884 } else if (FindSeparateModuleSubprogramInterface(subprogram)) { 885 error = "ENTRY may not appear in a separate module procedure"_err_en_US; 886 } else if (subprogramDetails && details.isFunction() && 887 subprogramDetails->isFunction() && 888 !context_.HasError(details.result()) && 889 !context_.HasError(subprogramDetails->result())) { 890 auto result{FunctionResult::Characterize( 891 details.result(), context_.foldingContext())}; 892 auto subpResult{FunctionResult::Characterize( 893 subprogramDetails->result(), context_.foldingContext())}; 894 if (result && subpResult && *result != *subpResult && 895 (!IsResultOkToDiffer(*result) || !IsResultOkToDiffer(*subpResult))) { 896 error = 897 "Result of ENTRY is not compatible with result of containing function"_err_en_US; 898 } 899 } 900 if (error) { 901 if (auto *msg{messages_.Say(symbol.name(), *error)}) { 902 if (subprogram) { 903 msg->Attach(subprogram->name(), "Containing subprogram"_en_US); 904 } 905 } 906 } 907 } 908 if (symbol.attrs().test(Attr::ELEMENTAL)) { 909 // See comment on the similar check in CheckProcEntity() 910 if (details.isDummy()) { 911 messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US); 912 } else { 913 for (const Symbol *dummy : details.dummyArgs()) { 914 if (!dummy) { // C15100 915 messages_.Say( 916 "An ELEMENTAL subroutine may not have an alternate return dummy argument"_err_en_US); 917 } 918 } 919 } 920 } 921 } 922 923 void CheckHelper::CheckDerivedType( 924 const Symbol &derivedType, const DerivedTypeDetails &details) { 925 if (details.isForwardReferenced() && !context_.HasError(derivedType)) { 926 messages_.Say("The derived type '%s' has not been defined"_err_en_US, 927 derivedType.name()); 928 } 929 const Scope *scope{derivedType.scope()}; 930 if (!scope) { 931 CHECK(details.isForwardReferenced()); 932 return; 933 } 934 CHECK(scope->symbol() == &derivedType); 935 CHECK(scope->IsDerivedType()); 936 if (derivedType.attrs().test(Attr::ABSTRACT) && // C734 937 (derivedType.attrs().test(Attr::BIND_C) || details.sequence())) { 938 messages_.Say("An ABSTRACT derived type must be extensible"_err_en_US); 939 } 940 if (const DeclTypeSpec * parent{FindParentTypeSpec(derivedType)}) { 941 const DerivedTypeSpec *parentDerived{parent->AsDerived()}; 942 if (!IsExtensibleType(parentDerived)) { // C705 943 messages_.Say("The parent type is not extensible"_err_en_US); 944 } 945 if (!derivedType.attrs().test(Attr::ABSTRACT) && parentDerived && 946 parentDerived->typeSymbol().attrs().test(Attr::ABSTRACT)) { 947 ScopeComponentIterator components{*parentDerived}; 948 for (const Symbol &component : components) { 949 if (component.attrs().test(Attr::DEFERRED)) { 950 if (scope->FindComponent(component.name()) == &component) { 951 SayWithDeclaration(component, 952 "Non-ABSTRACT extension of ABSTRACT derived type '%s' lacks a binding for DEFERRED procedure '%s'"_err_en_US, 953 parentDerived->typeSymbol().name(), component.name()); 954 } 955 } 956 } 957 } 958 DerivedTypeSpec derived{derivedType.name(), derivedType}; 959 derived.set_scope(*scope); 960 if (FindCoarrayUltimateComponent(derived) && // C736 961 !(parentDerived && FindCoarrayUltimateComponent(*parentDerived))) { 962 messages_.Say( 963 "Type '%s' has a coarray ultimate component so the type at the base " 964 "of its type extension chain ('%s') must be a type that has a " 965 "coarray ultimate component"_err_en_US, 966 derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name()); 967 } 968 if (FindEventOrLockPotentialComponent(derived) && // C737 969 !(FindEventOrLockPotentialComponent(*parentDerived) || 970 IsEventTypeOrLockType(parentDerived))) { 971 messages_.Say( 972 "Type '%s' has an EVENT_TYPE or LOCK_TYPE component, so the type " 973 "at the base of its type extension chain ('%s') must either have an " 974 "EVENT_TYPE or LOCK_TYPE component, or be EVENT_TYPE or " 975 "LOCK_TYPE"_err_en_US, 976 derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name()); 977 } 978 } 979 if (HasIntrinsicTypeName(derivedType)) { // C729 980 messages_.Say("A derived type name cannot be the name of an intrinsic" 981 " type"_err_en_US); 982 } 983 std::map<SourceName, SymbolRef> previous; 984 for (const auto &pair : details.finals()) { 985 SourceName source{pair.first}; 986 const Symbol &ref{*pair.second}; 987 if (CheckFinal(ref, source, derivedType) && 988 std::all_of(previous.begin(), previous.end(), 989 [&](std::pair<SourceName, SymbolRef> prev) { 990 return CheckDistinguishableFinals( 991 ref, source, *prev.second, prev.first, derivedType); 992 })) { 993 previous.emplace(source, ref); 994 } 995 } 996 } 997 998 // C786 999 bool CheckHelper::CheckFinal( 1000 const Symbol &subroutine, SourceName finalName, const Symbol &derivedType) { 1001 if (!IsModuleProcedure(subroutine)) { 1002 SayWithDeclaration(subroutine, finalName, 1003 "FINAL subroutine '%s' of derived type '%s' must be a module procedure"_err_en_US, 1004 subroutine.name(), derivedType.name()); 1005 return false; 1006 } 1007 const Procedure *proc{Characterize(subroutine)}; 1008 if (!proc) { 1009 return false; // error recovery 1010 } 1011 if (!proc->IsSubroutine()) { 1012 SayWithDeclaration(subroutine, finalName, 1013 "FINAL subroutine '%s' of derived type '%s' must be a subroutine"_err_en_US, 1014 subroutine.name(), derivedType.name()); 1015 return false; 1016 } 1017 if (proc->dummyArguments.size() != 1) { 1018 SayWithDeclaration(subroutine, finalName, 1019 "FINAL subroutine '%s' of derived type '%s' must have a single dummy argument"_err_en_US, 1020 subroutine.name(), derivedType.name()); 1021 return false; 1022 } 1023 const auto &arg{proc->dummyArguments[0]}; 1024 const Symbol *errSym{&subroutine}; 1025 if (const auto *details{subroutine.detailsIf<SubprogramDetails>()}) { 1026 if (!details->dummyArgs().empty()) { 1027 if (const Symbol * argSym{details->dummyArgs()[0]}) { 1028 errSym = argSym; 1029 } 1030 } 1031 } 1032 const auto *ddo{std::get_if<DummyDataObject>(&arg.u)}; 1033 if (!ddo) { 1034 SayWithDeclaration(subroutine, finalName, 1035 "FINAL subroutine '%s' of derived type '%s' must have a single dummy argument that is a data object"_err_en_US, 1036 subroutine.name(), derivedType.name()); 1037 return false; 1038 } 1039 bool ok{true}; 1040 if (arg.IsOptional()) { 1041 SayWithDeclaration(*errSym, finalName, 1042 "FINAL subroutine '%s' of derived type '%s' must not have an OPTIONAL dummy argument"_err_en_US, 1043 subroutine.name(), derivedType.name()); 1044 ok = false; 1045 } 1046 if (ddo->attrs.test(DummyDataObject::Attr::Allocatable)) { 1047 SayWithDeclaration(*errSym, finalName, 1048 "FINAL subroutine '%s' of derived type '%s' must not have an ALLOCATABLE dummy argument"_err_en_US, 1049 subroutine.name(), derivedType.name()); 1050 ok = false; 1051 } 1052 if (ddo->attrs.test(DummyDataObject::Attr::Pointer)) { 1053 SayWithDeclaration(*errSym, finalName, 1054 "FINAL subroutine '%s' of derived type '%s' must not have a POINTER dummy argument"_err_en_US, 1055 subroutine.name(), derivedType.name()); 1056 ok = false; 1057 } 1058 if (ddo->intent == common::Intent::Out) { 1059 SayWithDeclaration(*errSym, finalName, 1060 "FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with INTENT(OUT)"_err_en_US, 1061 subroutine.name(), derivedType.name()); 1062 ok = false; 1063 } 1064 if (ddo->attrs.test(DummyDataObject::Attr::Value)) { 1065 SayWithDeclaration(*errSym, finalName, 1066 "FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with the VALUE attribute"_err_en_US, 1067 subroutine.name(), derivedType.name()); 1068 ok = false; 1069 } 1070 if (ddo->type.corank() > 0) { 1071 SayWithDeclaration(*errSym, finalName, 1072 "FINAL subroutine '%s' of derived type '%s' must not have a coarray dummy argument"_err_en_US, 1073 subroutine.name(), derivedType.name()); 1074 ok = false; 1075 } 1076 if (ddo->type.type().IsPolymorphic()) { 1077 SayWithDeclaration(*errSym, finalName, 1078 "FINAL subroutine '%s' of derived type '%s' must not have a polymorphic dummy argument"_err_en_US, 1079 subroutine.name(), derivedType.name()); 1080 ok = false; 1081 } else if (ddo->type.type().category() != TypeCategory::Derived || 1082 &ddo->type.type().GetDerivedTypeSpec().typeSymbol() != &derivedType) { 1083 SayWithDeclaration(*errSym, finalName, 1084 "FINAL subroutine '%s' of derived type '%s' must have a TYPE(%s) dummy argument"_err_en_US, 1085 subroutine.name(), derivedType.name(), derivedType.name()); 1086 ok = false; 1087 } else { // check that all LEN type parameters are assumed 1088 for (auto ref : OrderParameterDeclarations(derivedType)) { 1089 if (IsLenTypeParameter(*ref)) { 1090 const auto *value{ 1091 ddo->type.type().GetDerivedTypeSpec().FindParameter(ref->name())}; 1092 if (!value || !value->isAssumed()) { 1093 SayWithDeclaration(*errSym, finalName, 1094 "FINAL subroutine '%s' of derived type '%s' must have a dummy argument with an assumed LEN type parameter '%s=*'"_err_en_US, 1095 subroutine.name(), derivedType.name(), ref->name()); 1096 ok = false; 1097 } 1098 } 1099 } 1100 } 1101 return ok; 1102 } 1103 1104 bool CheckHelper::CheckDistinguishableFinals(const Symbol &f1, 1105 SourceName f1Name, const Symbol &f2, SourceName f2Name, 1106 const Symbol &derivedType) { 1107 const Procedure *p1{Characterize(f1)}; 1108 const Procedure *p2{Characterize(f2)}; 1109 if (p1 && p2) { 1110 if (characteristics::Distinguishable( 1111 context_.languageFeatures(), *p1, *p2)) { 1112 return true; 1113 } 1114 if (auto *msg{messages_.Say(f1Name, 1115 "FINAL subroutines '%s' and '%s' of derived type '%s' cannot be distinguished by rank or KIND type parameter value"_err_en_US, 1116 f1Name, f2Name, derivedType.name())}) { 1117 msg->Attach(f2Name, "FINAL declaration of '%s'"_en_US, f2.name()) 1118 .Attach(f1.name(), "Definition of '%s'"_en_US, f1Name) 1119 .Attach(f2.name(), "Definition of '%s'"_en_US, f2Name); 1120 } 1121 } 1122 return false; 1123 } 1124 1125 void CheckHelper::CheckHostAssoc( 1126 const Symbol &symbol, const HostAssocDetails &details) { 1127 const Symbol &hostSymbol{details.symbol()}; 1128 if (hostSymbol.test(Symbol::Flag::ImplicitOrError)) { 1129 if (details.implicitOrSpecExprError) { 1130 messages_.Say("Implicitly typed local entity '%s' not allowed in" 1131 " specification expression"_err_en_US, 1132 symbol.name()); 1133 } else if (details.implicitOrExplicitTypeError) { 1134 messages_.Say( 1135 "No explicit type declared for '%s'"_err_en_US, symbol.name()); 1136 } 1137 } 1138 } 1139 1140 void CheckHelper::CheckGeneric( 1141 const Symbol &symbol, const GenericDetails &details) { 1142 CheckSpecificsAreDistinguishable(symbol, details); 1143 std::visit(common::visitors{ 1144 [&](const GenericKind::DefinedIo &io) { 1145 CheckDefinedIoProc(symbol, details, io); 1146 }, 1147 [](const auto &) {}, 1148 }, 1149 details.kind().u); 1150 } 1151 1152 // Check that the specifics of this generic are distinguishable from each other 1153 void CheckHelper::CheckSpecificsAreDistinguishable( 1154 const Symbol &generic, const GenericDetails &details) { 1155 GenericKind kind{details.kind()}; 1156 const SymbolVector &specifics{details.specificProcs()}; 1157 std::size_t count{specifics.size()}; 1158 if (count < 2 || !kind.IsName()) { 1159 return; 1160 } 1161 DistinguishabilityHelper helper{context_}; 1162 for (const Symbol &specific : specifics) { 1163 if (const Procedure * procedure{Characterize(specific)}) { 1164 helper.Add(generic, kind, specific, *procedure); 1165 } 1166 } 1167 helper.Check(generic.owner()); 1168 } 1169 1170 static bool ConflictsWithIntrinsicAssignment(const Procedure &proc) { 1171 auto lhs{std::get<DummyDataObject>(proc.dummyArguments[0].u).type}; 1172 auto rhs{std::get<DummyDataObject>(proc.dummyArguments[1].u).type}; 1173 return Tristate::No == 1174 IsDefinedAssignment(lhs.type(), lhs.Rank(), rhs.type(), rhs.Rank()); 1175 } 1176 1177 static bool ConflictsWithIntrinsicOperator( 1178 const GenericKind &kind, const Procedure &proc) { 1179 if (!kind.IsIntrinsicOperator()) { 1180 return false; 1181 } 1182 auto arg0{std::get<DummyDataObject>(proc.dummyArguments[0].u).type}; 1183 auto type0{arg0.type()}; 1184 if (proc.dummyArguments.size() == 1) { // unary 1185 return std::visit( 1186 common::visitors{ 1187 [&](common::NumericOperator) { return IsIntrinsicNumeric(type0); }, 1188 [&](common::LogicalOperator) { return IsIntrinsicLogical(type0); }, 1189 [](const auto &) -> bool { DIE("bad generic kind"); }, 1190 }, 1191 kind.u); 1192 } else { // binary 1193 int rank0{arg0.Rank()}; 1194 auto arg1{std::get<DummyDataObject>(proc.dummyArguments[1].u).type}; 1195 auto type1{arg1.type()}; 1196 int rank1{arg1.Rank()}; 1197 return std::visit( 1198 common::visitors{ 1199 [&](common::NumericOperator) { 1200 return IsIntrinsicNumeric(type0, rank0, type1, rank1); 1201 }, 1202 [&](common::LogicalOperator) { 1203 return IsIntrinsicLogical(type0, rank0, type1, rank1); 1204 }, 1205 [&](common::RelationalOperator opr) { 1206 return IsIntrinsicRelational(opr, type0, rank0, type1, rank1); 1207 }, 1208 [&](GenericKind::OtherKind x) { 1209 CHECK(x == GenericKind::OtherKind::Concat); 1210 return IsIntrinsicConcat(type0, rank0, type1, rank1); 1211 }, 1212 [](const auto &) -> bool { DIE("bad generic kind"); }, 1213 }, 1214 kind.u); 1215 } 1216 } 1217 1218 // Check if this procedure can be used for defined operators (see 15.4.3.4.2). 1219 bool CheckHelper::CheckDefinedOperator(SourceName opName, GenericKind kind, 1220 const Symbol &specific, const Procedure &proc) { 1221 if (context_.HasError(specific)) { 1222 return false; 1223 } 1224 std::optional<parser::MessageFixedText> msg; 1225 auto checkDefinedOperatorArgs{ 1226 [&](SourceName opName, const Symbol &specific, const Procedure &proc) { 1227 bool arg0Defined{CheckDefinedOperatorArg(opName, specific, proc, 0)}; 1228 bool arg1Defined{CheckDefinedOperatorArg(opName, specific, proc, 1)}; 1229 return arg0Defined && arg1Defined; 1230 }}; 1231 if (specific.attrs().test(Attr::NOPASS)) { // C774 1232 msg = "%s procedure '%s' may not have NOPASS attribute"_err_en_US; 1233 } else if (!proc.functionResult.has_value()) { 1234 msg = "%s procedure '%s' must be a function"_err_en_US; 1235 } else if (proc.functionResult->IsAssumedLengthCharacter()) { 1236 msg = "%s function '%s' may not have assumed-length CHARACTER(*)" 1237 " result"_err_en_US; 1238 } else if (auto m{CheckNumberOfArgs(kind, proc.dummyArguments.size())}) { 1239 msg = std::move(m); 1240 } else if (!checkDefinedOperatorArgs(opName, specific, proc)) { 1241 return false; // error was reported 1242 } else if (ConflictsWithIntrinsicOperator(kind, proc)) { 1243 msg = "%s function '%s' conflicts with intrinsic operator"_err_en_US; 1244 } else { 1245 return true; // OK 1246 } 1247 SayWithDeclaration( 1248 specific, std::move(*msg), MakeOpName(opName), specific.name()); 1249 context_.SetError(specific); 1250 return false; 1251 } 1252 1253 // If the number of arguments is wrong for this intrinsic operator, return 1254 // false and return the error message in msg. 1255 std::optional<parser::MessageFixedText> CheckHelper::CheckNumberOfArgs( 1256 const GenericKind &kind, std::size_t nargs) { 1257 if (!kind.IsIntrinsicOperator()) { 1258 return std::nullopt; 1259 } 1260 std::size_t min{2}, max{2}; // allowed number of args; default is binary 1261 std::visit(common::visitors{ 1262 [&](const common::NumericOperator &x) { 1263 if (x == common::NumericOperator::Add || 1264 x == common::NumericOperator::Subtract) { 1265 min = 1; // + and - are unary or binary 1266 } 1267 }, 1268 [&](const common::LogicalOperator &x) { 1269 if (x == common::LogicalOperator::Not) { 1270 min = 1; // .NOT. is unary 1271 max = 1; 1272 } 1273 }, 1274 [](const common::RelationalOperator &) { 1275 // all are binary 1276 }, 1277 [](const GenericKind::OtherKind &x) { 1278 CHECK(x == GenericKind::OtherKind::Concat); 1279 }, 1280 [](const auto &) { DIE("expected intrinsic operator"); }, 1281 }, 1282 kind.u); 1283 if (nargs >= min && nargs <= max) { 1284 return std::nullopt; 1285 } else if (max == 1) { 1286 return "%s function '%s' must have one dummy argument"_err_en_US; 1287 } else if (min == 2) { 1288 return "%s function '%s' must have two dummy arguments"_err_en_US; 1289 } else { 1290 return "%s function '%s' must have one or two dummy arguments"_err_en_US; 1291 } 1292 } 1293 1294 bool CheckHelper::CheckDefinedOperatorArg(const SourceName &opName, 1295 const Symbol &symbol, const Procedure &proc, std::size_t pos) { 1296 if (pos >= proc.dummyArguments.size()) { 1297 return true; 1298 } 1299 auto &arg{proc.dummyArguments.at(pos)}; 1300 std::optional<parser::MessageFixedText> msg; 1301 if (arg.IsOptional()) { 1302 msg = "In %s function '%s', dummy argument '%s' may not be" 1303 " OPTIONAL"_err_en_US; 1304 } else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)}; 1305 dataObject == nullptr) { 1306 msg = "In %s function '%s', dummy argument '%s' must be a" 1307 " data object"_err_en_US; 1308 } else if (dataObject->intent != common::Intent::In && 1309 !dataObject->attrs.test(DummyDataObject::Attr::Value)) { 1310 msg = "In %s function '%s', dummy argument '%s' must have INTENT(IN)" 1311 " or VALUE attribute"_err_en_US; 1312 } 1313 if (msg) { 1314 SayWithDeclaration(symbol, std::move(*msg), 1315 parser::ToUpperCaseLetters(opName.ToString()), symbol.name(), arg.name); 1316 return false; 1317 } 1318 return true; 1319 } 1320 1321 // Check if this procedure can be used for defined assignment (see 15.4.3.4.3). 1322 bool CheckHelper::CheckDefinedAssignment( 1323 const Symbol &specific, const Procedure &proc) { 1324 if (context_.HasError(specific)) { 1325 return false; 1326 } 1327 std::optional<parser::MessageFixedText> msg; 1328 if (specific.attrs().test(Attr::NOPASS)) { // C774 1329 msg = "Defined assignment procedure '%s' may not have" 1330 " NOPASS attribute"_err_en_US; 1331 } else if (!proc.IsSubroutine()) { 1332 msg = "Defined assignment procedure '%s' must be a subroutine"_err_en_US; 1333 } else if (proc.dummyArguments.size() != 2) { 1334 msg = "Defined assignment subroutine '%s' must have" 1335 " two dummy arguments"_err_en_US; 1336 } else { 1337 // Check both arguments even if the first has an error. 1338 bool ok0{CheckDefinedAssignmentArg(specific, proc.dummyArguments[0], 0)}; 1339 bool ok1{CheckDefinedAssignmentArg(specific, proc.dummyArguments[1], 1)}; 1340 if (!(ok0 && ok1)) { 1341 return false; // error was reported 1342 } else if (ConflictsWithIntrinsicAssignment(proc)) { 1343 msg = "Defined assignment subroutine '%s' conflicts with" 1344 " intrinsic assignment"_err_en_US; 1345 } else { 1346 return true; // OK 1347 } 1348 } 1349 SayWithDeclaration(specific, std::move(msg.value()), specific.name()); 1350 context_.SetError(specific); 1351 return false; 1352 } 1353 1354 bool CheckHelper::CheckDefinedAssignmentArg( 1355 const Symbol &symbol, const DummyArgument &arg, int pos) { 1356 std::optional<parser::MessageFixedText> msg; 1357 if (arg.IsOptional()) { 1358 msg = "In defined assignment subroutine '%s', dummy argument '%s'" 1359 " may not be OPTIONAL"_err_en_US; 1360 } else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)}) { 1361 if (pos == 0) { 1362 if (dataObject->intent != common::Intent::Out && 1363 dataObject->intent != common::Intent::InOut) { 1364 msg = "In defined assignment subroutine '%s', first dummy argument '%s'" 1365 " must have INTENT(OUT) or INTENT(INOUT)"_err_en_US; 1366 } 1367 } else if (pos == 1) { 1368 if (dataObject->intent != common::Intent::In && 1369 !dataObject->attrs.test(DummyDataObject::Attr::Value)) { 1370 msg = 1371 "In defined assignment subroutine '%s', second dummy" 1372 " argument '%s' must have INTENT(IN) or VALUE attribute"_err_en_US; 1373 } 1374 } else { 1375 DIE("pos must be 0 or 1"); 1376 } 1377 } else { 1378 msg = "In defined assignment subroutine '%s', dummy argument '%s'" 1379 " must be a data object"_err_en_US; 1380 } 1381 if (msg) { 1382 SayWithDeclaration(symbol, std::move(*msg), symbol.name(), arg.name); 1383 context_.SetError(symbol); 1384 return false; 1385 } 1386 return true; 1387 } 1388 1389 // Report a conflicting attribute error if symbol has both of these attributes 1390 bool CheckHelper::CheckConflicting(const Symbol &symbol, Attr a1, Attr a2) { 1391 if (symbol.attrs().test(a1) && symbol.attrs().test(a2)) { 1392 messages_.Say("'%s' may not have both the %s and %s attributes"_err_en_US, 1393 symbol.name(), AttrToString(a1), AttrToString(a2)); 1394 return true; 1395 } else { 1396 return false; 1397 } 1398 } 1399 1400 void CheckHelper::WarnMissingFinal(const Symbol &symbol) { 1401 const auto *object{symbol.detailsIf<ObjectEntityDetails>()}; 1402 if (!object || IsPointer(symbol)) { 1403 return; 1404 } 1405 const DeclTypeSpec *type{object->type()}; 1406 const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr}; 1407 const Symbol *derivedSym{derived ? &derived->typeSymbol() : nullptr}; 1408 int rank{object->shape().Rank()}; 1409 const Symbol *initialDerivedSym{derivedSym}; 1410 while (const auto *derivedDetails{ 1411 derivedSym ? derivedSym->detailsIf<DerivedTypeDetails>() : nullptr}) { 1412 if (!derivedDetails->finals().empty() && 1413 !derivedDetails->GetFinalForRank(rank)) { 1414 if (auto *msg{derivedSym == initialDerivedSym 1415 ? messages_.Say(symbol.name(), 1416 "'%s' of derived type '%s' does not have a FINAL subroutine for its rank (%d)"_en_US, 1417 symbol.name(), derivedSym->name(), rank) 1418 : messages_.Say(symbol.name(), 1419 "'%s' of derived type '%s' extended from '%s' does not have a FINAL subroutine for its rank (%d)"_en_US, 1420 symbol.name(), initialDerivedSym->name(), 1421 derivedSym->name(), rank)}) { 1422 msg->Attach(derivedSym->name(), 1423 "Declaration of derived type '%s'"_en_US, derivedSym->name()); 1424 } 1425 return; 1426 } 1427 derived = derivedSym->GetParentTypeSpec(); 1428 derivedSym = derived ? &derived->typeSymbol() : nullptr; 1429 } 1430 } 1431 1432 const Procedure *CheckHelper::Characterize(const Symbol &symbol) { 1433 auto it{characterizeCache_.find(symbol)}; 1434 if (it == characterizeCache_.end()) { 1435 auto pair{characterizeCache_.emplace(SymbolRef{symbol}, 1436 Procedure::Characterize(symbol, context_.foldingContext()))}; 1437 it = pair.first; 1438 } 1439 return common::GetPtrFromOptional(it->second); 1440 } 1441 1442 void CheckHelper::CheckVolatile(const Symbol &symbol, 1443 const DerivedTypeSpec *derived) { // C866 - C868 1444 if (IsIntentIn(symbol)) { 1445 messages_.Say( 1446 "VOLATILE attribute may not apply to an INTENT(IN) argument"_err_en_US); 1447 } 1448 if (IsProcedure(symbol)) { 1449 messages_.Say("VOLATILE attribute may apply only to a variable"_err_en_US); 1450 } 1451 if (symbol.has<UseDetails>() || symbol.has<HostAssocDetails>()) { 1452 const Symbol &ultimate{symbol.GetUltimate()}; 1453 if (evaluate::IsCoarray(ultimate)) { 1454 messages_.Say( 1455 "VOLATILE attribute may not apply to a coarray accessed by USE or host association"_err_en_US); 1456 } 1457 if (derived) { 1458 if (FindCoarrayUltimateComponent(*derived)) { 1459 messages_.Say( 1460 "VOLATILE attribute may not apply to a type with a coarray ultimate component accessed by USE or host association"_err_en_US); 1461 } 1462 } 1463 } 1464 } 1465 1466 void CheckHelper::CheckPointer(const Symbol &symbol) { // C852 1467 CheckConflicting(symbol, Attr::POINTER, Attr::TARGET); 1468 CheckConflicting(symbol, Attr::POINTER, Attr::ALLOCATABLE); // C751 1469 CheckConflicting(symbol, Attr::POINTER, Attr::INTRINSIC); 1470 // Prohibit constant pointers. The standard does not explicitly prohibit 1471 // them, but the PARAMETER attribute requires a entity-decl to have an 1472 // initialization that is a constant-expr, and the only form of 1473 // initialization that allows a constant-expr is the one that's not a "=>" 1474 // pointer initialization. See C811, C807, and section 8.5.13. 1475 CheckConflicting(symbol, Attr::POINTER, Attr::PARAMETER); 1476 if (symbol.Corank() > 0) { 1477 messages_.Say( 1478 "'%s' may not have the POINTER attribute because it is a coarray"_err_en_US, 1479 symbol.name()); 1480 } 1481 } 1482 1483 // C760 constraints on the passed-object dummy argument 1484 // C757 constraints on procedure pointer components 1485 void CheckHelper::CheckPassArg( 1486 const Symbol &proc, const Symbol *interface, const WithPassArg &details) { 1487 if (proc.attrs().test(Attr::NOPASS)) { 1488 return; 1489 } 1490 const auto &name{proc.name()}; 1491 if (!interface) { 1492 messages_.Say(name, 1493 "Procedure component '%s' must have NOPASS attribute or explicit interface"_err_en_US, 1494 name); 1495 return; 1496 } 1497 const auto *subprogram{interface->detailsIf<SubprogramDetails>()}; 1498 if (!subprogram) { 1499 messages_.Say(name, 1500 "Procedure component '%s' has invalid interface '%s'"_err_en_US, name, 1501 interface->name()); 1502 return; 1503 } 1504 std::optional<SourceName> passName{details.passName()}; 1505 const auto &dummyArgs{subprogram->dummyArgs()}; 1506 if (!passName) { 1507 if (dummyArgs.empty()) { 1508 messages_.Say(name, 1509 proc.has<ProcEntityDetails>() 1510 ? "Procedure component '%s' with no dummy arguments" 1511 " must have NOPASS attribute"_err_en_US 1512 : "Procedure binding '%s' with no dummy arguments" 1513 " must have NOPASS attribute"_err_en_US, 1514 name); 1515 context_.SetError(*interface); 1516 return; 1517 } 1518 Symbol *argSym{dummyArgs[0]}; 1519 if (!argSym) { 1520 messages_.Say(interface->name(), 1521 "Cannot use an alternate return as the passed-object dummy " 1522 "argument"_err_en_US); 1523 return; 1524 } 1525 passName = dummyArgs[0]->name(); 1526 } 1527 std::optional<int> passArgIndex{}; 1528 for (std::size_t i{0}; i < dummyArgs.size(); ++i) { 1529 if (dummyArgs[i] && dummyArgs[i]->name() == *passName) { 1530 passArgIndex = i; 1531 break; 1532 } 1533 } 1534 if (!passArgIndex) { // C758 1535 messages_.Say(*passName, 1536 "'%s' is not a dummy argument of procedure interface '%s'"_err_en_US, 1537 *passName, interface->name()); 1538 return; 1539 } 1540 const Symbol &passArg{*dummyArgs[*passArgIndex]}; 1541 std::optional<parser::MessageFixedText> msg; 1542 if (!passArg.has<ObjectEntityDetails>()) { 1543 msg = "Passed-object dummy argument '%s' of procedure '%s'" 1544 " must be a data object"_err_en_US; 1545 } else if (passArg.attrs().test(Attr::POINTER)) { 1546 msg = "Passed-object dummy argument '%s' of procedure '%s'" 1547 " may not have the POINTER attribute"_err_en_US; 1548 } else if (passArg.attrs().test(Attr::ALLOCATABLE)) { 1549 msg = "Passed-object dummy argument '%s' of procedure '%s'" 1550 " may not have the ALLOCATABLE attribute"_err_en_US; 1551 } else if (passArg.attrs().test(Attr::VALUE)) { 1552 msg = "Passed-object dummy argument '%s' of procedure '%s'" 1553 " may not have the VALUE attribute"_err_en_US; 1554 } else if (passArg.Rank() > 0) { 1555 msg = "Passed-object dummy argument '%s' of procedure '%s'" 1556 " must be scalar"_err_en_US; 1557 } 1558 if (msg) { 1559 messages_.Say(name, std::move(*msg), passName.value(), name); 1560 return; 1561 } 1562 const DeclTypeSpec *type{passArg.GetType()}; 1563 if (!type) { 1564 return; // an error already occurred 1565 } 1566 const Symbol &typeSymbol{*proc.owner().GetSymbol()}; 1567 const DerivedTypeSpec *derived{type->AsDerived()}; 1568 if (!derived || derived->typeSymbol() != typeSymbol) { 1569 messages_.Say(name, 1570 "Passed-object dummy argument '%s' of procedure '%s'" 1571 " must be of type '%s' but is '%s'"_err_en_US, 1572 passName.value(), name, typeSymbol.name(), type->AsFortran()); 1573 return; 1574 } 1575 if (IsExtensibleType(derived) != type->IsPolymorphic()) { 1576 messages_.Say(name, 1577 type->IsPolymorphic() 1578 ? "Passed-object dummy argument '%s' of procedure '%s'" 1579 " may not be polymorphic because '%s' is not extensible"_err_en_US 1580 : "Passed-object dummy argument '%s' of procedure '%s'" 1581 " must be polymorphic because '%s' is extensible"_err_en_US, 1582 passName.value(), name, typeSymbol.name()); 1583 return; 1584 } 1585 for (const auto &[paramName, paramValue] : derived->parameters()) { 1586 if (paramValue.isLen() && !paramValue.isAssumed()) { 1587 messages_.Say(name, 1588 "Passed-object dummy argument '%s' of procedure '%s'" 1589 " has non-assumed length parameter '%s'"_err_en_US, 1590 passName.value(), name, paramName); 1591 } 1592 } 1593 } 1594 1595 void CheckHelper::CheckProcBinding( 1596 const Symbol &symbol, const ProcBindingDetails &binding) { 1597 const Scope &dtScope{symbol.owner()}; 1598 CHECK(dtScope.kind() == Scope::Kind::DerivedType); 1599 if (symbol.attrs().test(Attr::DEFERRED)) { 1600 if (const Symbol * dtSymbol{dtScope.symbol()}) { 1601 if (!dtSymbol->attrs().test(Attr::ABSTRACT)) { // C733 1602 SayWithDeclaration(*dtSymbol, 1603 "Procedure bound to non-ABSTRACT derived type '%s' may not be DEFERRED"_err_en_US, 1604 dtSymbol->name()); 1605 } 1606 } 1607 if (symbol.attrs().test(Attr::NON_OVERRIDABLE)) { 1608 messages_.Say( 1609 "Type-bound procedure '%s' may not be both DEFERRED and NON_OVERRIDABLE"_err_en_US, 1610 symbol.name()); 1611 } 1612 } 1613 if (binding.symbol().attrs().test(Attr::INTRINSIC) && 1614 !context_.intrinsics().IsSpecificIntrinsicFunction( 1615 binding.symbol().name().ToString())) { 1616 messages_.Say( 1617 "Intrinsic procedure '%s' is not a specific intrinsic permitted for use in the definition of binding '%s'"_err_en_US, 1618 binding.symbol().name(), symbol.name()); 1619 } 1620 if (const Symbol * overridden{FindOverriddenBinding(symbol)}) { 1621 if (overridden->attrs().test(Attr::NON_OVERRIDABLE)) { 1622 SayWithDeclaration(*overridden, 1623 "Override of NON_OVERRIDABLE '%s' is not permitted"_err_en_US, 1624 symbol.name()); 1625 } 1626 if (const auto *overriddenBinding{ 1627 overridden->detailsIf<ProcBindingDetails>()}) { 1628 if (!IsPureProcedure(symbol) && IsPureProcedure(*overridden)) { 1629 SayWithDeclaration(*overridden, 1630 "An overridden pure type-bound procedure binding must also be pure"_err_en_US); 1631 return; 1632 } 1633 if (!binding.symbol().attrs().test(Attr::ELEMENTAL) && 1634 overriddenBinding->symbol().attrs().test(Attr::ELEMENTAL)) { 1635 SayWithDeclaration(*overridden, 1636 "A type-bound procedure and its override must both, or neither, be ELEMENTAL"_err_en_US); 1637 return; 1638 } 1639 bool isNopass{symbol.attrs().test(Attr::NOPASS)}; 1640 if (isNopass != overridden->attrs().test(Attr::NOPASS)) { 1641 SayWithDeclaration(*overridden, 1642 isNopass 1643 ? "A NOPASS type-bound procedure may not override a passed-argument procedure"_err_en_US 1644 : "A passed-argument type-bound procedure may not override a NOPASS procedure"_err_en_US); 1645 } else { 1646 const auto *bindingChars{Characterize(binding.symbol())}; 1647 const auto *overriddenChars{Characterize(overriddenBinding->symbol())}; 1648 if (bindingChars && overriddenChars) { 1649 if (isNopass) { 1650 if (!bindingChars->CanOverride(*overriddenChars, std::nullopt)) { 1651 SayWithDeclaration(*overridden, 1652 "A type-bound procedure and its override must have compatible interfaces"_err_en_US); 1653 } 1654 } else if (!context_.HasError(binding.symbol())) { 1655 int passIndex{bindingChars->FindPassIndex(binding.passName())}; 1656 int overriddenPassIndex{ 1657 overriddenChars->FindPassIndex(overriddenBinding->passName())}; 1658 if (passIndex != overriddenPassIndex) { 1659 SayWithDeclaration(*overridden, 1660 "A type-bound procedure and its override must use the same PASS argument"_err_en_US); 1661 } else if (!bindingChars->CanOverride( 1662 *overriddenChars, passIndex)) { 1663 SayWithDeclaration(*overridden, 1664 "A type-bound procedure and its override must have compatible interfaces apart from their passed argument"_err_en_US); 1665 } 1666 } 1667 } 1668 } 1669 if (symbol.attrs().test(Attr::PRIVATE) && 1670 overridden->attrs().test(Attr::PUBLIC)) { 1671 SayWithDeclaration(*overridden, 1672 "A PRIVATE procedure may not override a PUBLIC procedure"_err_en_US); 1673 } 1674 } else { 1675 SayWithDeclaration(*overridden, 1676 "A type-bound procedure binding may not have the same name as a parent component"_err_en_US); 1677 } 1678 } 1679 CheckPassArg(symbol, &binding.symbol(), binding); 1680 } 1681 1682 void CheckHelper::Check(const Scope &scope) { 1683 scope_ = &scope; 1684 common::Restorer<const Symbol *> restorer{innermostSymbol_, innermostSymbol_}; 1685 if (const Symbol * symbol{scope.symbol()}) { 1686 innermostSymbol_ = symbol; 1687 } 1688 if (scope.IsParameterizedDerivedTypeInstantiation()) { 1689 auto restorer{common::ScopedSet(scopeIsUninstantiatedPDT_, false)}; 1690 auto restorer2{context_.foldingContext().messages().SetContext( 1691 scope.instantiationContext().get())}; 1692 for (const auto &pair : scope) { 1693 CheckPointerInitialization(*pair.second); 1694 } 1695 } else { 1696 auto restorer{common::ScopedSet( 1697 scopeIsUninstantiatedPDT_, scope.IsParameterizedDerivedType())}; 1698 for (const auto &set : scope.equivalenceSets()) { 1699 CheckEquivalenceSet(set); 1700 } 1701 for (const auto &pair : scope) { 1702 Check(*pair.second); 1703 } 1704 for (const Scope &child : scope.children()) { 1705 Check(child); 1706 } 1707 if (scope.kind() == Scope::Kind::BlockData) { 1708 CheckBlockData(scope); 1709 } 1710 CheckGenericOps(scope); 1711 } 1712 } 1713 1714 void CheckHelper::CheckEquivalenceSet(const EquivalenceSet &set) { 1715 auto iter{ 1716 std::find_if(set.begin(), set.end(), [](const EquivalenceObject &object) { 1717 return FindCommonBlockContaining(object.symbol) != nullptr; 1718 })}; 1719 if (iter != set.end()) { 1720 const Symbol &commonBlock{DEREF(FindCommonBlockContaining(iter->symbol))}; 1721 for (auto &object : set) { 1722 if (&object != &*iter) { 1723 if (auto *details{object.symbol.detailsIf<ObjectEntityDetails>()}) { 1724 if (details->commonBlock()) { 1725 if (details->commonBlock() != &commonBlock) { // 8.10.3 paragraph 1 1726 if (auto *msg{messages_.Say(object.symbol.name(), 1727 "Two objects in the same EQUIVALENCE set may not be members of distinct COMMON blocks"_err_en_US)}) { 1728 msg->Attach(iter->symbol.name(), 1729 "Other object in EQUIVALENCE set"_en_US) 1730 .Attach(details->commonBlock()->name(), 1731 "COMMON block containing '%s'"_en_US, 1732 object.symbol.name()) 1733 .Attach(commonBlock.name(), 1734 "COMMON block containing '%s'"_en_US, 1735 iter->symbol.name()); 1736 } 1737 } 1738 } else { 1739 // Mark all symbols in the equivalence set with the same COMMON 1740 // block to prevent spurious error messages about initialization 1741 // in BLOCK DATA outside COMMON 1742 details->set_commonBlock(commonBlock); 1743 } 1744 } 1745 } 1746 } 1747 } 1748 // TODO: Move C8106 (&al.) checks here from resolve-names-utils.cpp 1749 } 1750 1751 void CheckHelper::CheckBlockData(const Scope &scope) { 1752 // BLOCK DATA subprograms should contain only named common blocks. 1753 // C1415 presents a list of statements that shouldn't appear in 1754 // BLOCK DATA, but so long as the subprogram contains no executable 1755 // code and allocates no storage outside named COMMON, we're happy 1756 // (e.g., an ENUM is strictly not allowed). 1757 for (const auto &pair : scope) { 1758 const Symbol &symbol{*pair.second}; 1759 if (!(symbol.has<CommonBlockDetails>() || symbol.has<UseDetails>() || 1760 symbol.has<UseErrorDetails>() || symbol.has<DerivedTypeDetails>() || 1761 symbol.has<SubprogramDetails>() || 1762 symbol.has<ObjectEntityDetails>() || 1763 (symbol.has<ProcEntityDetails>() && 1764 !symbol.attrs().test(Attr::POINTER)))) { 1765 messages_.Say(symbol.name(), 1766 "'%s' may not appear in a BLOCK DATA subprogram"_err_en_US, 1767 symbol.name()); 1768 } 1769 } 1770 } 1771 1772 // Check distinguishability of generic assignment and operators. 1773 // For these, generics and generic bindings must be considered together. 1774 void CheckHelper::CheckGenericOps(const Scope &scope) { 1775 DistinguishabilityHelper helper{context_}; 1776 auto addSpecifics{[&](const Symbol &generic) { 1777 const auto *details{generic.GetUltimate().detailsIf<GenericDetails>()}; 1778 if (!details) { 1779 return; 1780 } 1781 GenericKind kind{details->kind()}; 1782 if (!kind.IsAssignment() && !kind.IsOperator()) { 1783 return; 1784 } 1785 const SymbolVector &specifics{details->specificProcs()}; 1786 const std::vector<SourceName> &bindingNames{details->bindingNames()}; 1787 for (std::size_t i{0}; i < specifics.size(); ++i) { 1788 const Symbol &specific{*specifics[i]}; 1789 if (const Procedure * proc{Characterize(specific)}) { 1790 auto restorer{messages_.SetLocation(bindingNames[i])}; 1791 if (kind.IsAssignment()) { 1792 if (!CheckDefinedAssignment(specific, *proc)) { 1793 continue; 1794 } 1795 } else { 1796 if (!CheckDefinedOperator(generic.name(), kind, specific, *proc)) { 1797 continue; 1798 } 1799 } 1800 helper.Add(generic, kind, specific, *proc); 1801 } 1802 } 1803 }}; 1804 for (const auto &pair : scope) { 1805 const Symbol &symbol{*pair.second}; 1806 addSpecifics(symbol); 1807 const Symbol &ultimate{symbol.GetUltimate()}; 1808 if (ultimate.has<DerivedTypeDetails>()) { 1809 if (const Scope * typeScope{ultimate.scope()}) { 1810 for (const auto &pair2 : *typeScope) { 1811 addSpecifics(*pair2.second); 1812 } 1813 } 1814 } 1815 } 1816 helper.Check(scope); 1817 } 1818 1819 static const std::string *DefinesBindCName(const Symbol &symbol) { 1820 const auto *subp{symbol.detailsIf<SubprogramDetails>()}; 1821 if ((subp && !subp->isInterface()) || symbol.has<ObjectEntityDetails>()) { 1822 // Symbol defines data or entry point 1823 return symbol.GetBindName(); 1824 } else { 1825 return nullptr; 1826 } 1827 } 1828 1829 // Check that BIND(C) names are distinct 1830 void CheckHelper::CheckBindCName(const Symbol &symbol) { 1831 if (const std::string * name{DefinesBindCName(symbol)}) { 1832 auto pair{bindC_.emplace(*name, symbol)}; 1833 if (!pair.second) { 1834 const Symbol &other{*pair.first->second}; 1835 if (DefinesBindCName(other) && !context_.HasError(other)) { 1836 if (auto *msg{messages_.Say( 1837 "Two symbols have the same BIND(C) name '%s'"_err_en_US, 1838 *name)}) { 1839 msg->Attach(other.name(), "Conflicting symbol"_en_US); 1840 } 1841 context_.SetError(symbol); 1842 context_.SetError(other); 1843 } 1844 } 1845 } 1846 } 1847 1848 bool CheckHelper::CheckDioDummyIsData( 1849 const Symbol &subp, const Symbol *arg, std::size_t position) { 1850 if (arg && arg->detailsIf<ObjectEntityDetails>()) { 1851 return true; 1852 } else { 1853 if (arg) { 1854 messages_.Say(arg->name(), 1855 "Dummy argument '%s' must be a data object"_err_en_US, arg->name()); 1856 } else { 1857 messages_.Say(subp.name(), 1858 "Dummy argument %d of '%s' must be a data object"_err_en_US, position, 1859 subp.name()); 1860 } 1861 return false; 1862 } 1863 } 1864 1865 void CheckHelper::CheckAlreadySeenDefinedIo(const DerivedTypeSpec *derivedType, 1866 GenericKind::DefinedIo ioKind, const Symbol &proc) { 1867 for (TypeWithDefinedIo definedIoType : seenDefinedIoTypes_) { 1868 if (*derivedType == *definedIoType.type && ioKind == definedIoType.ioKind && 1869 proc != definedIoType.proc) { 1870 SayWithDeclaration(proc, definedIoType.proc.name(), 1871 "Derived type '%s' already has defined input/output procedure" 1872 " '%s'"_err_en_US, 1873 derivedType->name(), 1874 parser::ToUpperCaseLetters(GenericKind::EnumToString(ioKind))); 1875 return; 1876 } 1877 } 1878 seenDefinedIoTypes_.emplace_back( 1879 TypeWithDefinedIo{derivedType, ioKind, proc}); 1880 } 1881 1882 void CheckHelper::CheckDioDummyIsDerived( 1883 const Symbol &subp, const Symbol &arg, GenericKind::DefinedIo ioKind) { 1884 if (const DeclTypeSpec * type{arg.GetType()}) { 1885 if (const DerivedTypeSpec * derivedType{type->AsDerived()}) { 1886 CheckAlreadySeenDefinedIo(derivedType, ioKind, subp); 1887 bool isPolymorphic{type->IsPolymorphic()}; 1888 if (isPolymorphic != IsExtensibleType(derivedType)) { 1889 messages_.Say(arg.name(), 1890 "Dummy argument '%s' of a defined input/output procedure must be %s when the derived type is %s"_err_en_US, 1891 arg.name(), isPolymorphic ? "TYPE()" : "CLASS()", 1892 isPolymorphic ? "not extensible" : "extensible"); 1893 } 1894 } else { 1895 messages_.Say(arg.name(), 1896 "Dummy argument '%s' of a defined input/output procedure must have a" 1897 " derived type"_err_en_US, 1898 arg.name()); 1899 } 1900 } 1901 } 1902 1903 void CheckHelper::CheckDioDummyIsDefaultInteger( 1904 const Symbol &subp, const Symbol &arg) { 1905 if (const DeclTypeSpec * type{arg.GetType()}; 1906 type && type->IsNumeric(TypeCategory::Integer)) { 1907 if (const auto kind{evaluate::ToInt64(type->numericTypeSpec().kind())}; 1908 kind && *kind == context_.GetDefaultKind(TypeCategory::Integer)) { 1909 return; 1910 } 1911 } 1912 messages_.Say(arg.name(), 1913 "Dummy argument '%s' of a defined input/output procedure" 1914 " must be an INTEGER of default KIND"_err_en_US, 1915 arg.name()); 1916 } 1917 1918 void CheckHelper::CheckDioDummyIsScalar(const Symbol &subp, const Symbol &arg) { 1919 if (arg.Rank() > 0 || arg.Corank() > 0) { 1920 messages_.Say(arg.name(), 1921 "Dummy argument '%s' of a defined input/output procedure" 1922 " must be a scalar"_err_en_US, 1923 arg.name()); 1924 } 1925 } 1926 1927 void CheckHelper::CheckDioDtvArg( 1928 const Symbol &subp, const Symbol *arg, GenericKind::DefinedIo ioKind) { 1929 // Dtv argument looks like: dtv-type-spec, INTENT(INOUT) :: dtv 1930 if (CheckDioDummyIsData(subp, arg, 0)) { 1931 CheckDioDummyIsDerived(subp, *arg, ioKind); 1932 CheckDioDummyAttrs(subp, *arg, 1933 ioKind == GenericKind::DefinedIo::ReadFormatted || 1934 ioKind == GenericKind::DefinedIo::ReadUnformatted 1935 ? Attr::INTENT_INOUT 1936 : Attr::INTENT_IN); 1937 } 1938 } 1939 1940 void CheckHelper::CheckDefaultIntegerArg( 1941 const Symbol &subp, const Symbol *arg, Attr intent) { 1942 // Argument looks like: INTEGER, INTENT(intent) :: arg 1943 if (CheckDioDummyIsData(subp, arg, 1)) { 1944 CheckDioDummyIsDefaultInteger(subp, *arg); 1945 CheckDioDummyIsScalar(subp, *arg); 1946 CheckDioDummyAttrs(subp, *arg, intent); 1947 } 1948 } 1949 1950 void CheckHelper::CheckDioAssumedLenCharacterArg(const Symbol &subp, 1951 const Symbol *arg, std::size_t argPosition, Attr intent) { 1952 // Argument looks like: CHARACTER (LEN=*), INTENT(intent) :: (iotype OR iomsg) 1953 if (CheckDioDummyIsData(subp, arg, argPosition)) { 1954 CheckDioDummyAttrs(subp, *arg, intent); 1955 if (!IsAssumedLengthCharacter(*arg)) { 1956 messages_.Say(arg->name(), 1957 "Dummy argument '%s' of a defined input/output procedure" 1958 " must be assumed-length CHARACTER"_err_en_US, 1959 arg->name()); 1960 } 1961 } 1962 } 1963 1964 void CheckHelper::CheckDioVlistArg( 1965 const Symbol &subp, const Symbol *arg, std::size_t argPosition) { 1966 // Vlist argument looks like: INTEGER, INTENT(IN) :: v_list(:) 1967 if (CheckDioDummyIsData(subp, arg, argPosition)) { 1968 CheckDioDummyIsDefaultInteger(subp, *arg); 1969 CheckDioDummyAttrs(subp, *arg, Attr::INTENT_IN); 1970 const auto *objectDetails{arg->detailsIf<ObjectEntityDetails>()}; 1971 if (!objectDetails || !objectDetails->shape().CanBeDeferredShape()) { 1972 messages_.Say(arg->name(), 1973 "Dummy argument '%s' of a defined input/output procedure must be" 1974 " deferred shape"_err_en_US, 1975 arg->name()); 1976 } 1977 } 1978 } 1979 1980 void CheckHelper::CheckDioArgCount( 1981 const Symbol &subp, GenericKind::DefinedIo ioKind, std::size_t argCount) { 1982 const std::size_t requiredArgCount{ 1983 (std::size_t)(ioKind == GenericKind::DefinedIo::ReadFormatted || 1984 ioKind == GenericKind::DefinedIo::WriteFormatted 1985 ? 6 1986 : 4)}; 1987 if (argCount != requiredArgCount) { 1988 SayWithDeclaration(subp, 1989 "Defined input/output procedure '%s' must have" 1990 " %d dummy arguments rather than %d"_err_en_US, 1991 subp.name(), requiredArgCount, argCount); 1992 context_.SetError(subp); 1993 } 1994 } 1995 1996 void CheckHelper::CheckDioDummyAttrs( 1997 const Symbol &subp, const Symbol &arg, Attr goodIntent) { 1998 // Defined I/O procedures can't have attributes other than INTENT 1999 Attrs attrs{arg.attrs()}; 2000 if (!attrs.test(goodIntent)) { 2001 messages_.Say(arg.name(), 2002 "Dummy argument '%s' of a defined input/output procedure" 2003 " must have intent '%s'"_err_en_US, 2004 arg.name(), AttrToString(goodIntent)); 2005 } 2006 attrs = attrs - Attr::INTENT_IN - Attr::INTENT_OUT - Attr::INTENT_INOUT; 2007 if (!attrs.empty()) { 2008 messages_.Say(arg.name(), 2009 "Dummy argument '%s' of a defined input/output procedure may not have" 2010 " any attributes"_err_en_US, 2011 arg.name()); 2012 } 2013 } 2014 2015 // Enforce semantics for defined input/output procedures (12.6.4.8.2) and C777 2016 void CheckHelper::CheckDefinedIoProc(const Symbol &symbol, 2017 const GenericDetails &details, GenericKind::DefinedIo ioKind) { 2018 for (auto ref : details.specificProcs()) { 2019 const auto *binding{ref->detailsIf<ProcBindingDetails>()}; 2020 const Symbol &specific{*(binding ? &binding->symbol() : &*ref)}; 2021 if (ref->attrs().test(Attr::NOPASS)) { // C774 2022 messages_.Say("Defined input/output procedure '%s' may not have NOPASS " 2023 "attribute"_err_en_US, 2024 ref->name()); 2025 context_.SetError(*ref); 2026 } 2027 if (const auto *subpDetails{specific.detailsIf<SubprogramDetails>()}) { 2028 const std::vector<Symbol *> &dummyArgs{subpDetails->dummyArgs()}; 2029 CheckDioArgCount(specific, ioKind, dummyArgs.size()); 2030 int argCount{0}; 2031 for (auto *arg : dummyArgs) { 2032 switch (argCount++) { 2033 case 0: 2034 // dtv-type-spec, INTENT(INOUT) :: dtv 2035 CheckDioDtvArg(specific, arg, ioKind); 2036 break; 2037 case 1: 2038 // INTEGER, INTENT(IN) :: unit 2039 CheckDefaultIntegerArg(specific, arg, Attr::INTENT_IN); 2040 break; 2041 case 2: 2042 if (ioKind == GenericKind::DefinedIo::ReadFormatted || 2043 ioKind == GenericKind::DefinedIo::WriteFormatted) { 2044 // CHARACTER (LEN=*), INTENT(IN) :: iotype 2045 CheckDioAssumedLenCharacterArg( 2046 specific, arg, argCount, Attr::INTENT_IN); 2047 } else { 2048 // INTEGER, INTENT(OUT) :: iostat 2049 CheckDefaultIntegerArg(specific, arg, Attr::INTENT_OUT); 2050 } 2051 break; 2052 case 3: 2053 if (ioKind == GenericKind::DefinedIo::ReadFormatted || 2054 ioKind == GenericKind::DefinedIo::WriteFormatted) { 2055 // INTEGER, INTENT(IN) :: v_list(:) 2056 CheckDioVlistArg(specific, arg, argCount); 2057 } else { 2058 // CHARACTER (LEN=*), INTENT(INOUT) :: iomsg 2059 CheckDioAssumedLenCharacterArg( 2060 specific, arg, argCount, Attr::INTENT_INOUT); 2061 } 2062 break; 2063 case 4: 2064 // INTEGER, INTENT(OUT) :: iostat 2065 CheckDefaultIntegerArg(specific, arg, Attr::INTENT_OUT); 2066 break; 2067 case 5: 2068 // CHARACTER (LEN=*), INTENT(INOUT) :: iomsg 2069 CheckDioAssumedLenCharacterArg( 2070 specific, arg, argCount, Attr::INTENT_INOUT); 2071 break; 2072 default:; 2073 } 2074 } 2075 } 2076 } 2077 } 2078 2079 void SubprogramMatchHelper::Check( 2080 const Symbol &symbol1, const Symbol &symbol2) { 2081 const auto details1{symbol1.get<SubprogramDetails>()}; 2082 const auto details2{symbol2.get<SubprogramDetails>()}; 2083 if (details1.isFunction() != details2.isFunction()) { 2084 Say(symbol1, symbol2, 2085 details1.isFunction() 2086 ? "Module function '%s' was declared as a subroutine in the" 2087 " corresponding interface body"_err_en_US 2088 : "Module subroutine '%s' was declared as a function in the" 2089 " corresponding interface body"_err_en_US); 2090 return; 2091 } 2092 const auto &args1{details1.dummyArgs()}; 2093 const auto &args2{details2.dummyArgs()}; 2094 int nargs1{static_cast<int>(args1.size())}; 2095 int nargs2{static_cast<int>(args2.size())}; 2096 if (nargs1 != nargs2) { 2097 Say(symbol1, symbol2, 2098 "Module subprogram '%s' has %d args but the corresponding interface" 2099 " body has %d"_err_en_US, 2100 nargs1, nargs2); 2101 return; 2102 } 2103 bool nonRecursive1{symbol1.attrs().test(Attr::NON_RECURSIVE)}; 2104 if (nonRecursive1 != symbol2.attrs().test(Attr::NON_RECURSIVE)) { // C1551 2105 Say(symbol1, symbol2, 2106 nonRecursive1 2107 ? "Module subprogram '%s' has NON_RECURSIVE prefix but" 2108 " the corresponding interface body does not"_err_en_US 2109 : "Module subprogram '%s' does not have NON_RECURSIVE prefix but " 2110 "the corresponding interface body does"_err_en_US); 2111 } 2112 const std::string *bindName1{details1.bindName()}; 2113 const std::string *bindName2{details2.bindName()}; 2114 if (!bindName1 && !bindName2) { 2115 // OK - neither has a binding label 2116 } else if (!bindName1) { 2117 Say(symbol1, symbol2, 2118 "Module subprogram '%s' does not have a binding label but the" 2119 " corresponding interface body does"_err_en_US); 2120 } else if (!bindName2) { 2121 Say(symbol1, symbol2, 2122 "Module subprogram '%s' has a binding label but the" 2123 " corresponding interface body does not"_err_en_US); 2124 } else if (*bindName1 != *bindName2) { 2125 Say(symbol1, symbol2, 2126 "Module subprogram '%s' has binding label '%s' but the corresponding" 2127 " interface body has '%s'"_err_en_US, 2128 *details1.bindName(), *details2.bindName()); 2129 } 2130 const Procedure *proc1{checkHelper.Characterize(symbol1)}; 2131 const Procedure *proc2{checkHelper.Characterize(symbol2)}; 2132 if (!proc1 || !proc2) { 2133 return; 2134 } 2135 if (proc1->functionResult && proc2->functionResult && 2136 *proc1->functionResult != *proc2->functionResult) { 2137 Say(symbol1, symbol2, 2138 "Return type of function '%s' does not match return type of" 2139 " the corresponding interface body"_err_en_US); 2140 } 2141 for (int i{0}; i < nargs1; ++i) { 2142 const Symbol *arg1{args1[i]}; 2143 const Symbol *arg2{args2[i]}; 2144 if (arg1 && !arg2) { 2145 Say(symbol1, symbol2, 2146 "Dummy argument %2$d of '%1$s' is not an alternate return indicator" 2147 " but the corresponding argument in the interface body is"_err_en_US, 2148 i + 1); 2149 } else if (!arg1 && arg2) { 2150 Say(symbol1, symbol2, 2151 "Dummy argument %2$d of '%1$s' is an alternate return indicator but" 2152 " the corresponding argument in the interface body is not"_err_en_US, 2153 i + 1); 2154 } else if (arg1 && arg2) { 2155 SourceName name1{arg1->name()}; 2156 SourceName name2{arg2->name()}; 2157 if (name1 != name2) { 2158 Say(*arg1, *arg2, 2159 "Dummy argument name '%s' does not match corresponding name '%s'" 2160 " in interface body"_err_en_US, 2161 name2); 2162 } else { 2163 CheckDummyArg( 2164 *arg1, *arg2, proc1->dummyArguments[i], proc2->dummyArguments[i]); 2165 } 2166 } 2167 } 2168 } 2169 2170 void SubprogramMatchHelper::CheckDummyArg(const Symbol &symbol1, 2171 const Symbol &symbol2, const DummyArgument &arg1, 2172 const DummyArgument &arg2) { 2173 std::visit(common::visitors{ 2174 [&](const DummyDataObject &obj1, const DummyDataObject &obj2) { 2175 CheckDummyDataObject(symbol1, symbol2, obj1, obj2); 2176 }, 2177 [&](const DummyProcedure &proc1, const DummyProcedure &proc2) { 2178 CheckDummyProcedure(symbol1, symbol2, proc1, proc2); 2179 }, 2180 [&](const DummyDataObject &, const auto &) { 2181 Say(symbol1, symbol2, 2182 "Dummy argument '%s' is a data object; the corresponding" 2183 " argument in the interface body is not"_err_en_US); 2184 }, 2185 [&](const DummyProcedure &, const auto &) { 2186 Say(symbol1, symbol2, 2187 "Dummy argument '%s' is a procedure; the corresponding" 2188 " argument in the interface body is not"_err_en_US); 2189 }, 2190 [&](const auto &, const auto &) { 2191 llvm_unreachable("Dummy arguments are not data objects or" 2192 "procedures"); 2193 }, 2194 }, 2195 arg1.u, arg2.u); 2196 } 2197 2198 void SubprogramMatchHelper::CheckDummyDataObject(const Symbol &symbol1, 2199 const Symbol &symbol2, const DummyDataObject &obj1, 2200 const DummyDataObject &obj2) { 2201 if (!CheckSameIntent(symbol1, symbol2, obj1.intent, obj2.intent)) { 2202 } else if (!CheckSameAttrs(symbol1, symbol2, obj1.attrs, obj2.attrs)) { 2203 } else if (obj1.type.type() != obj2.type.type()) { 2204 Say(symbol1, symbol2, 2205 "Dummy argument '%s' has type %s; the corresponding argument in the" 2206 " interface body has type %s"_err_en_US, 2207 obj1.type.type().AsFortran(), obj2.type.type().AsFortran()); 2208 } else if (!ShapesAreCompatible(obj1, obj2)) { 2209 Say(symbol1, symbol2, 2210 "The shape of dummy argument '%s' does not match the shape of the" 2211 " corresponding argument in the interface body"_err_en_US); 2212 } 2213 // TODO: coshape 2214 } 2215 2216 void SubprogramMatchHelper::CheckDummyProcedure(const Symbol &symbol1, 2217 const Symbol &symbol2, const DummyProcedure &proc1, 2218 const DummyProcedure &proc2) { 2219 if (!CheckSameIntent(symbol1, symbol2, proc1.intent, proc2.intent)) { 2220 } else if (!CheckSameAttrs(symbol1, symbol2, proc1.attrs, proc2.attrs)) { 2221 } else if (proc1 != proc2) { 2222 Say(symbol1, symbol2, 2223 "Dummy procedure '%s' does not match the corresponding argument in" 2224 " the interface body"_err_en_US); 2225 } 2226 } 2227 2228 bool SubprogramMatchHelper::CheckSameIntent(const Symbol &symbol1, 2229 const Symbol &symbol2, common::Intent intent1, common::Intent intent2) { 2230 if (intent1 == intent2) { 2231 return true; 2232 } else { 2233 Say(symbol1, symbol2, 2234 "The intent of dummy argument '%s' does not match the intent" 2235 " of the corresponding argument in the interface body"_err_en_US); 2236 return false; 2237 } 2238 } 2239 2240 // Report an error referring to first symbol with declaration of second symbol 2241 template <typename... A> 2242 void SubprogramMatchHelper::Say(const Symbol &symbol1, const Symbol &symbol2, 2243 parser::MessageFixedText &&text, A &&...args) { 2244 auto &message{context().Say(symbol1.name(), std::move(text), symbol1.name(), 2245 std::forward<A>(args)...)}; 2246 evaluate::AttachDeclaration(message, symbol2); 2247 } 2248 2249 template <typename ATTRS> 2250 bool SubprogramMatchHelper::CheckSameAttrs( 2251 const Symbol &symbol1, const Symbol &symbol2, ATTRS attrs1, ATTRS attrs2) { 2252 if (attrs1 == attrs2) { 2253 return true; 2254 } 2255 attrs1.IterateOverMembers([&](auto attr) { 2256 if (!attrs2.test(attr)) { 2257 Say(symbol1, symbol2, 2258 "Dummy argument '%s' has the %s attribute; the corresponding" 2259 " argument in the interface body does not"_err_en_US, 2260 AsFortran(attr)); 2261 } 2262 }); 2263 attrs2.IterateOverMembers([&](auto attr) { 2264 if (!attrs1.test(attr)) { 2265 Say(symbol1, symbol2, 2266 "Dummy argument '%s' does not have the %s attribute; the" 2267 " corresponding argument in the interface body does"_err_en_US, 2268 AsFortran(attr)); 2269 } 2270 }); 2271 return false; 2272 } 2273 2274 bool SubprogramMatchHelper::ShapesAreCompatible( 2275 const DummyDataObject &obj1, const DummyDataObject &obj2) { 2276 return characteristics::ShapesAreCompatible( 2277 FoldShape(obj1.type.shape()), FoldShape(obj2.type.shape())); 2278 } 2279 2280 evaluate::Shape SubprogramMatchHelper::FoldShape(const evaluate::Shape &shape) { 2281 evaluate::Shape result; 2282 for (const auto &extent : shape) { 2283 result.emplace_back( 2284 evaluate::Fold(context().foldingContext(), common::Clone(extent))); 2285 } 2286 return result; 2287 } 2288 2289 void DistinguishabilityHelper::Add(const Symbol &generic, GenericKind kind, 2290 const Symbol &specific, const Procedure &procedure) { 2291 if (!context_.HasError(specific)) { 2292 nameToInfo_[generic.name()].emplace_back( 2293 ProcedureInfo{kind, specific, procedure}); 2294 } 2295 } 2296 2297 void DistinguishabilityHelper::Check(const Scope &scope) { 2298 for (const auto &[name, info] : nameToInfo_) { 2299 auto count{info.size()}; 2300 for (std::size_t i1{0}; i1 < count - 1; ++i1) { 2301 const auto &[kind, symbol, proc]{info[i1]}; 2302 for (std::size_t i2{i1 + 1}; i2 < count; ++i2) { 2303 auto distinguishable{kind.IsName() 2304 ? evaluate::characteristics::Distinguishable 2305 : evaluate::characteristics::DistinguishableOpOrAssign}; 2306 if (!distinguishable( 2307 context_.languageFeatures(), proc, info[i2].procedure)) { 2308 SayNotDistinguishable(GetTopLevelUnitContaining(scope), name, kind, 2309 symbol, info[i2].symbol); 2310 } 2311 } 2312 } 2313 } 2314 } 2315 2316 void DistinguishabilityHelper::SayNotDistinguishable(const Scope &scope, 2317 const SourceName &name, GenericKind kind, const Symbol &proc1, 2318 const Symbol &proc2) { 2319 std::string name1{proc1.name().ToString()}; 2320 std::string name2{proc2.name().ToString()}; 2321 if (kind.IsOperator() || kind.IsAssignment()) { 2322 // proc1 and proc2 may come from different scopes so qualify their names 2323 if (proc1.owner().IsDerivedType()) { 2324 name1 = proc1.owner().GetName()->ToString() + '%' + name1; 2325 } 2326 if (proc2.owner().IsDerivedType()) { 2327 name2 = proc2.owner().GetName()->ToString() + '%' + name2; 2328 } 2329 } 2330 parser::Message *msg; 2331 if (scope.sourceRange().Contains(name)) { 2332 msg = &context_.Say(name, 2333 "Generic '%s' may not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_err_en_US, 2334 MakeOpName(name), name1, name2); 2335 } else { 2336 msg = &context_.Say(*GetTopLevelUnitContaining(proc1).GetName(), 2337 "USE-associated generic '%s' may not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_err_en_US, 2338 MakeOpName(name), name1, name2); 2339 } 2340 AttachDeclaration(*msg, scope, proc1); 2341 AttachDeclaration(*msg, scope, proc2); 2342 } 2343 2344 // `evaluate::AttachDeclaration` doesn't handle the generic case where `proc` 2345 // comes from a different module but is not necessarily use-associated. 2346 void DistinguishabilityHelper::AttachDeclaration( 2347 parser::Message &msg, const Scope &scope, const Symbol &proc) { 2348 const Scope &unit{GetTopLevelUnitContaining(proc)}; 2349 if (unit == scope) { 2350 evaluate::AttachDeclaration(msg, proc); 2351 } else { 2352 msg.Attach(unit.GetName().value(), 2353 "'%s' is USE-associated from module '%s'"_en_US, proc.name(), 2354 unit.GetName().value()); 2355 } 2356 } 2357 2358 void CheckDeclarations(SemanticsContext &context) { 2359 CheckHelper{context}.Check(); 2360 } 2361 } // namespace Fortran::semantics 2362