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