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