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