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