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