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