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