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