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