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