1 //===-- lib/Semantics/resolve-names.cpp -----------------------------------===// 2 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. 3 // See https://llvm.org/LICENSE.txt for license information. 4 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 5 // 6 //===----------------------------------------------------------------------===// 7 8 #include "resolve-names.h" 9 #include "assignment.h" 10 #include "mod-file.h" 11 #include "pointer-assignment.h" 12 #include "program-tree.h" 13 #include "resolve-directives.h" 14 #include "resolve-names-utils.h" 15 #include "rewrite-parse-tree.h" 16 #include "flang/Common/Fortran.h" 17 #include "flang/Common/default-kinds.h" 18 #include "flang/Common/indirection.h" 19 #include "flang/Common/restorer.h" 20 #include "flang/Evaluate/characteristics.h" 21 #include "flang/Evaluate/check-expression.h" 22 #include "flang/Evaluate/common.h" 23 #include "flang/Evaluate/fold-designator.h" 24 #include "flang/Evaluate/fold.h" 25 #include "flang/Evaluate/intrinsics.h" 26 #include "flang/Evaluate/tools.h" 27 #include "flang/Evaluate/type.h" 28 #include "flang/Parser/parse-tree-visitor.h" 29 #include "flang/Parser/parse-tree.h" 30 #include "flang/Parser/tools.h" 31 #include "flang/Semantics/attr.h" 32 #include "flang/Semantics/expression.h" 33 #include "flang/Semantics/scope.h" 34 #include "flang/Semantics/semantics.h" 35 #include "flang/Semantics/symbol.h" 36 #include "flang/Semantics/tools.h" 37 #include "flang/Semantics/type.h" 38 #include "llvm/Support/raw_ostream.h" 39 #include <list> 40 #include <map> 41 #include <set> 42 #include <stack> 43 44 namespace Fortran::semantics { 45 46 using namespace parser::literals; 47 48 template <typename T> using Indirection = common::Indirection<T>; 49 using Message = parser::Message; 50 using Messages = parser::Messages; 51 using MessageFixedText = parser::MessageFixedText; 52 using MessageFormattedText = parser::MessageFormattedText; 53 54 class ResolveNamesVisitor; 55 56 // ImplicitRules maps initial character of identifier to the DeclTypeSpec 57 // representing the implicit type; std::nullopt if none. 58 // It also records the presence of IMPLICIT NONE statements. 59 // When inheritFromParent is set, defaults come from the parent rules. 60 class ImplicitRules { 61 public: 62 ImplicitRules(SemanticsContext &context, ImplicitRules *parent) 63 : parent_{parent}, context_{context} { 64 inheritFromParent_ = parent != nullptr; 65 } 66 bool isImplicitNoneType() const; 67 bool isImplicitNoneExternal() const; 68 void set_isImplicitNoneType(bool x) { isImplicitNoneType_ = x; } 69 void set_isImplicitNoneExternal(bool x) { isImplicitNoneExternal_ = x; } 70 void set_inheritFromParent(bool x) { inheritFromParent_ = x; } 71 // Get the implicit type for this name. May be null. 72 const DeclTypeSpec *GetType( 73 SourceName, bool respectImplicitNone = true) const; 74 // Record the implicit type for the range of characters [fromLetter, 75 // toLetter]. 76 void SetTypeMapping(const DeclTypeSpec &type, parser::Location fromLetter, 77 parser::Location toLetter); 78 79 private: 80 static char Incr(char ch); 81 82 ImplicitRules *parent_; 83 SemanticsContext &context_; 84 bool inheritFromParent_{false}; // look in parent if not specified here 85 bool isImplicitNoneType_{ 86 context_.IsEnabled(common::LanguageFeature::ImplicitNoneTypeAlways)}; 87 bool isImplicitNoneExternal_{false}; 88 // map_ contains the mapping between letters and types that were defined 89 // by the IMPLICIT statements of the related scope. It does not contain 90 // the default Fortran mappings nor the mapping defined in parents. 91 std::map<char, common::Reference<const DeclTypeSpec>> map_; 92 93 friend llvm::raw_ostream &operator<<( 94 llvm::raw_ostream &, const ImplicitRules &); 95 friend void ShowImplicitRule( 96 llvm::raw_ostream &, const ImplicitRules &, char); 97 }; 98 99 // scope -> implicit rules for that scope 100 using ImplicitRulesMap = std::map<const Scope *, ImplicitRules>; 101 102 // Track statement source locations and save messages. 103 class MessageHandler { 104 public: 105 MessageHandler() { DIE("MessageHandler: default-constructed"); } 106 explicit MessageHandler(SemanticsContext &c) : context_{&c} {} 107 Messages &messages() { return context_->messages(); }; 108 const std::optional<SourceName> &currStmtSource() { 109 return context_->location(); 110 } 111 void set_currStmtSource(const std::optional<SourceName> &source) { 112 context_->set_location(source); 113 } 114 115 // Emit a message associated with the current statement source. 116 Message &Say(MessageFixedText &&); 117 Message &Say(MessageFormattedText &&); 118 // Emit a message about a SourceName 119 Message &Say(const SourceName &, MessageFixedText &&); 120 // Emit a formatted message associated with a source location. 121 template <typename... A> 122 Message &Say(const SourceName &source, MessageFixedText &&msg, A &&...args) { 123 return context_->Say(source, std::move(msg), std::forward<A>(args)...); 124 } 125 126 private: 127 SemanticsContext *context_; 128 }; 129 130 // Inheritance graph for the parse tree visitation classes that follow: 131 // BaseVisitor 132 // + AttrsVisitor 133 // | + DeclTypeSpecVisitor 134 // | + ImplicitRulesVisitor 135 // | + ScopeHandler -----------+--+ 136 // | + ModuleVisitor ========|==+ 137 // | + InterfaceVisitor | | 138 // | +-+ SubprogramVisitor ==|==+ 139 // + ArraySpecVisitor | | 140 // + DeclarationVisitor <--------+ | 141 // + ConstructVisitor | 142 // + ResolveNamesVisitor <------+ 143 144 class BaseVisitor { 145 public: 146 BaseVisitor() { DIE("BaseVisitor: default-constructed"); } 147 BaseVisitor( 148 SemanticsContext &c, ResolveNamesVisitor &v, ImplicitRulesMap &rules) 149 : implicitRulesMap_{&rules}, this_{&v}, context_{&c}, messageHandler_{c} { 150 } 151 template <typename T> void Walk(const T &); 152 153 MessageHandler &messageHandler() { return messageHandler_; } 154 const std::optional<SourceName> &currStmtSource() { 155 return context_->location(); 156 } 157 SemanticsContext &context() const { return *context_; } 158 evaluate::FoldingContext &GetFoldingContext() const { 159 return context_->foldingContext(); 160 } 161 bool IsIntrinsic( 162 const SourceName &name, std::optional<Symbol::Flag> flag) const { 163 if (!flag) { 164 return context_->intrinsics().IsIntrinsic(name.ToString()); 165 } else if (flag == Symbol::Flag::Function) { 166 return context_->intrinsics().IsIntrinsicFunction(name.ToString()); 167 } else if (flag == Symbol::Flag::Subroutine) { 168 return context_->intrinsics().IsIntrinsicSubroutine(name.ToString()); 169 } else { 170 DIE("expected Subroutine or Function flag"); 171 } 172 } 173 174 // Make a placeholder symbol for a Name that otherwise wouldn't have one. 175 // It is not in any scope and always has MiscDetails. 176 void MakePlaceholder(const parser::Name &, MiscDetails::Kind); 177 178 template <typename T> common::IfNoLvalue<T, T> FoldExpr(T &&expr) { 179 return evaluate::Fold(GetFoldingContext(), std::move(expr)); 180 } 181 182 template <typename T> MaybeExpr EvaluateExpr(const T &expr) { 183 return FoldExpr(AnalyzeExpr(*context_, expr)); 184 } 185 186 template <typename T> 187 MaybeExpr EvaluateNonPointerInitializer( 188 const Symbol &symbol, const T &expr, parser::CharBlock source) { 189 if (!context().HasError(symbol)) { 190 if (auto maybeExpr{AnalyzeExpr(*context_, expr)}) { 191 auto restorer{GetFoldingContext().messages().SetLocation(source)}; 192 return evaluate::NonPointerInitializationExpr( 193 symbol, std::move(*maybeExpr), GetFoldingContext()); 194 } 195 } 196 return std::nullopt; 197 } 198 199 template <typename T> MaybeIntExpr EvaluateIntExpr(const T &expr) { 200 return semantics::EvaluateIntExpr(*context_, expr); 201 } 202 203 template <typename T> 204 MaybeSubscriptIntExpr EvaluateSubscriptIntExpr(const T &expr) { 205 if (MaybeIntExpr maybeIntExpr{EvaluateIntExpr(expr)}) { 206 return FoldExpr(evaluate::ConvertToType<evaluate::SubscriptInteger>( 207 std::move(*maybeIntExpr))); 208 } else { 209 return std::nullopt; 210 } 211 } 212 213 template <typename... A> Message &Say(A &&...args) { 214 return messageHandler_.Say(std::forward<A>(args)...); 215 } 216 template <typename... A> 217 Message &Say( 218 const parser::Name &name, MessageFixedText &&text, const A &...args) { 219 return messageHandler_.Say(name.source, std::move(text), args...); 220 } 221 222 protected: 223 ImplicitRulesMap *implicitRulesMap_{nullptr}; 224 225 private: 226 ResolveNamesVisitor *this_; 227 SemanticsContext *context_; 228 MessageHandler messageHandler_; 229 }; 230 231 // Provide Post methods to collect attributes into a member variable. 232 class AttrsVisitor : public virtual BaseVisitor { 233 public: 234 bool BeginAttrs(); // always returns true 235 Attrs GetAttrs(); 236 Attrs EndAttrs(); 237 bool SetPassNameOn(Symbol &); 238 bool SetBindNameOn(Symbol &); 239 void Post(const parser::LanguageBindingSpec &); 240 bool Pre(const parser::IntentSpec &); 241 bool Pre(const parser::Pass &); 242 243 bool CheckAndSet(Attr); 244 245 // Simple case: encountering CLASSNAME causes ATTRNAME to be set. 246 #define HANDLE_ATTR_CLASS(CLASSNAME, ATTRNAME) \ 247 bool Pre(const parser::CLASSNAME &) { \ 248 CheckAndSet(Attr::ATTRNAME); \ 249 return false; \ 250 } 251 HANDLE_ATTR_CLASS(PrefixSpec::Elemental, ELEMENTAL) 252 HANDLE_ATTR_CLASS(PrefixSpec::Impure, IMPURE) 253 HANDLE_ATTR_CLASS(PrefixSpec::Module, MODULE) 254 HANDLE_ATTR_CLASS(PrefixSpec::Non_Recursive, NON_RECURSIVE) 255 HANDLE_ATTR_CLASS(PrefixSpec::Pure, PURE) 256 HANDLE_ATTR_CLASS(PrefixSpec::Recursive, RECURSIVE) 257 HANDLE_ATTR_CLASS(TypeAttrSpec::BindC, BIND_C) 258 HANDLE_ATTR_CLASS(BindAttr::Deferred, DEFERRED) 259 HANDLE_ATTR_CLASS(BindAttr::Non_Overridable, NON_OVERRIDABLE) 260 HANDLE_ATTR_CLASS(Abstract, ABSTRACT) 261 HANDLE_ATTR_CLASS(Allocatable, ALLOCATABLE) 262 HANDLE_ATTR_CLASS(Asynchronous, ASYNCHRONOUS) 263 HANDLE_ATTR_CLASS(Contiguous, CONTIGUOUS) 264 HANDLE_ATTR_CLASS(External, EXTERNAL) 265 HANDLE_ATTR_CLASS(Intrinsic, INTRINSIC) 266 HANDLE_ATTR_CLASS(NoPass, NOPASS) 267 HANDLE_ATTR_CLASS(Optional, OPTIONAL) 268 HANDLE_ATTR_CLASS(Parameter, PARAMETER) 269 HANDLE_ATTR_CLASS(Pointer, POINTER) 270 HANDLE_ATTR_CLASS(Protected, PROTECTED) 271 HANDLE_ATTR_CLASS(Save, SAVE) 272 HANDLE_ATTR_CLASS(Target, TARGET) 273 HANDLE_ATTR_CLASS(Value, VALUE) 274 HANDLE_ATTR_CLASS(Volatile, VOLATILE) 275 #undef HANDLE_ATTR_CLASS 276 277 protected: 278 std::optional<Attrs> attrs_; 279 280 Attr AccessSpecToAttr(const parser::AccessSpec &x) { 281 switch (x.v) { 282 case parser::AccessSpec::Kind::Public: 283 return Attr::PUBLIC; 284 case parser::AccessSpec::Kind::Private: 285 return Attr::PRIVATE; 286 } 287 llvm_unreachable("Switch covers all cases"); // suppress g++ warning 288 } 289 Attr IntentSpecToAttr(const parser::IntentSpec &x) { 290 switch (x.v) { 291 case parser::IntentSpec::Intent::In: 292 return Attr::INTENT_IN; 293 case parser::IntentSpec::Intent::Out: 294 return Attr::INTENT_OUT; 295 case parser::IntentSpec::Intent::InOut: 296 return Attr::INTENT_INOUT; 297 } 298 llvm_unreachable("Switch covers all cases"); // suppress g++ warning 299 } 300 301 private: 302 bool IsDuplicateAttr(Attr); 303 bool HaveAttrConflict(Attr, Attr, Attr); 304 bool IsConflictingAttr(Attr); 305 306 MaybeExpr bindName_; // from BIND(C, NAME="...") 307 std::optional<SourceName> passName_; // from PASS(...) 308 }; 309 310 // Find and create types from declaration-type-spec nodes. 311 class DeclTypeSpecVisitor : public AttrsVisitor { 312 public: 313 using AttrsVisitor::Post; 314 using AttrsVisitor::Pre; 315 void Post(const parser::IntrinsicTypeSpec::DoublePrecision &); 316 void Post(const parser::IntrinsicTypeSpec::DoubleComplex &); 317 void Post(const parser::DeclarationTypeSpec::ClassStar &); 318 void Post(const parser::DeclarationTypeSpec::TypeStar &); 319 bool Pre(const parser::TypeGuardStmt &); 320 void Post(const parser::TypeGuardStmt &); 321 void Post(const parser::TypeSpec &); 322 323 protected: 324 struct State { 325 bool expectDeclTypeSpec{false}; // should see decl-type-spec only when true 326 const DeclTypeSpec *declTypeSpec{nullptr}; 327 struct { 328 DerivedTypeSpec *type{nullptr}; 329 DeclTypeSpec::Category category{DeclTypeSpec::TypeDerived}; 330 } derived; 331 bool allowForwardReferenceToDerivedType{false}; 332 }; 333 334 bool allowForwardReferenceToDerivedType() const { 335 return state_.allowForwardReferenceToDerivedType; 336 } 337 void set_allowForwardReferenceToDerivedType(bool yes) { 338 state_.allowForwardReferenceToDerivedType = yes; 339 } 340 341 // Walk the parse tree of a type spec and return the DeclTypeSpec for it. 342 template <typename T> 343 const DeclTypeSpec *ProcessTypeSpec(const T &x, bool allowForward = false) { 344 auto restorer{common::ScopedSet(state_, State{})}; 345 set_allowForwardReferenceToDerivedType(allowForward); 346 BeginDeclTypeSpec(); 347 Walk(x); 348 const auto *type{GetDeclTypeSpec()}; 349 EndDeclTypeSpec(); 350 return type; 351 } 352 353 const DeclTypeSpec *GetDeclTypeSpec(); 354 void BeginDeclTypeSpec(); 355 void EndDeclTypeSpec(); 356 void SetDeclTypeSpec(const DeclTypeSpec &); 357 void SetDeclTypeSpecCategory(DeclTypeSpec::Category); 358 DeclTypeSpec::Category GetDeclTypeSpecCategory() const { 359 return state_.derived.category; 360 } 361 KindExpr GetKindParamExpr( 362 TypeCategory, const std::optional<parser::KindSelector> &); 363 void CheckForAbstractType(const Symbol &typeSymbol); 364 365 private: 366 State state_; 367 368 void MakeNumericType(TypeCategory, int kind); 369 }; 370 371 // Visit ImplicitStmt and related parse tree nodes and updates implicit rules. 372 class ImplicitRulesVisitor : public DeclTypeSpecVisitor { 373 public: 374 using DeclTypeSpecVisitor::Post; 375 using DeclTypeSpecVisitor::Pre; 376 using ImplicitNoneNameSpec = parser::ImplicitStmt::ImplicitNoneNameSpec; 377 378 void Post(const parser::ParameterStmt &); 379 bool Pre(const parser::ImplicitStmt &); 380 bool Pre(const parser::LetterSpec &); 381 bool Pre(const parser::ImplicitSpec &); 382 void Post(const parser::ImplicitSpec &); 383 384 const DeclTypeSpec *GetType( 385 SourceName name, bool respectImplicitNoneType = true) { 386 return implicitRules_->GetType(name, respectImplicitNoneType); 387 } 388 bool isImplicitNoneType() const { 389 return implicitRules_->isImplicitNoneType(); 390 } 391 bool isImplicitNoneType(const Scope &scope) const { 392 return implicitRulesMap_->at(&scope).isImplicitNoneType(); 393 } 394 bool isImplicitNoneExternal() const { 395 return implicitRules_->isImplicitNoneExternal(); 396 } 397 void set_inheritFromParent(bool x) { 398 implicitRules_->set_inheritFromParent(x); 399 } 400 401 protected: 402 void BeginScope(const Scope &); 403 void SetScope(const Scope &); 404 405 private: 406 // implicit rules in effect for current scope 407 ImplicitRules *implicitRules_{nullptr}; 408 std::optional<SourceName> prevImplicit_; 409 std::optional<SourceName> prevImplicitNone_; 410 std::optional<SourceName> prevImplicitNoneType_; 411 std::optional<SourceName> prevParameterStmt_; 412 413 bool HandleImplicitNone(const std::list<ImplicitNoneNameSpec> &nameSpecs); 414 }; 415 416 // Track array specifications. They can occur in AttrSpec, EntityDecl, 417 // ObjectDecl, DimensionStmt, CommonBlockObject, or BasedPointerStmt. 418 // 1. INTEGER, DIMENSION(10) :: x 419 // 2. INTEGER :: x(10) 420 // 3. ALLOCATABLE :: x(:) 421 // 4. DIMENSION :: x(10) 422 // 5. COMMON x(10) 423 // 6. BasedPointerStmt 424 class ArraySpecVisitor : public virtual BaseVisitor { 425 public: 426 void Post(const parser::ArraySpec &); 427 void Post(const parser::ComponentArraySpec &); 428 void Post(const parser::CoarraySpec &); 429 void Post(const parser::AttrSpec &) { PostAttrSpec(); } 430 void Post(const parser::ComponentAttrSpec &) { PostAttrSpec(); } 431 432 protected: 433 const ArraySpec &arraySpec(); 434 void set_arraySpec(const ArraySpec arraySpec) { arraySpec_ = arraySpec; } 435 const ArraySpec &coarraySpec(); 436 void BeginArraySpec(); 437 void EndArraySpec(); 438 void ClearArraySpec() { arraySpec_.clear(); } 439 void ClearCoarraySpec() { coarraySpec_.clear(); } 440 441 private: 442 // arraySpec_/coarraySpec_ are populated from any ArraySpec/CoarraySpec 443 ArraySpec arraySpec_; 444 ArraySpec coarraySpec_; 445 // When an ArraySpec is under an AttrSpec or ComponentAttrSpec, it is moved 446 // into attrArraySpec_ 447 ArraySpec attrArraySpec_; 448 ArraySpec attrCoarraySpec_; 449 450 void PostAttrSpec(); 451 }; 452 453 // Manage a stack of Scopes 454 class ScopeHandler : public ImplicitRulesVisitor { 455 public: 456 using ImplicitRulesVisitor::Post; 457 using ImplicitRulesVisitor::Pre; 458 459 Scope &currScope() { return DEREF(currScope_); } 460 // The enclosing host procedure if current scope is in an internal procedure 461 Scope *GetHostProcedure(); 462 // The enclosing scope, skipping blocks and derived types. 463 // TODO: Will return the scope of a FORALL or implied DO loop; is this ok? 464 // If not, should call FindProgramUnitContaining() instead. 465 Scope &InclusiveScope(); 466 // The enclosing scope, skipping derived types. 467 Scope &NonDerivedTypeScope(); 468 469 // Create a new scope and push it on the scope stack. 470 void PushScope(Scope::Kind kind, Symbol *symbol); 471 void PushScope(Scope &scope); 472 void PopScope(); 473 void SetScope(Scope &); 474 475 template <typename T> bool Pre(const parser::Statement<T> &x) { 476 messageHandler().set_currStmtSource(x.source); 477 currScope_->AddSourceRange(x.source); 478 return true; 479 } 480 template <typename T> void Post(const parser::Statement<T> &) { 481 messageHandler().set_currStmtSource(std::nullopt); 482 } 483 484 // Special messages: already declared; referencing symbol's declaration; 485 // about a type; two names & locations 486 void SayAlreadyDeclared(const parser::Name &, Symbol &); 487 void SayAlreadyDeclared(const SourceName &, Symbol &); 488 void SayAlreadyDeclared(const SourceName &, const SourceName &); 489 void SayWithReason( 490 const parser::Name &, Symbol &, MessageFixedText &&, MessageFixedText &&); 491 void SayWithDecl(const parser::Name &, Symbol &, MessageFixedText &&); 492 void SayLocalMustBeVariable(const parser::Name &, Symbol &); 493 void SayDerivedType(const SourceName &, MessageFixedText &&, const Scope &); 494 void Say2(const SourceName &, MessageFixedText &&, const SourceName &, 495 MessageFixedText &&); 496 void Say2( 497 const SourceName &, MessageFixedText &&, Symbol &, MessageFixedText &&); 498 void Say2( 499 const parser::Name &, MessageFixedText &&, Symbol &, MessageFixedText &&); 500 501 // Search for symbol by name in current, parent derived type, and 502 // containing scopes 503 Symbol *FindSymbol(const parser::Name &); 504 Symbol *FindSymbol(const Scope &, const parser::Name &); 505 // Search for name only in scope, not in enclosing scopes. 506 Symbol *FindInScope(const Scope &, const parser::Name &); 507 Symbol *FindInScope(const Scope &, const SourceName &); 508 template <typename T> Symbol *FindInScope(const T &name) { 509 return FindInScope(currScope(), name); 510 } 511 // Search for name in a derived type scope and its parents. 512 Symbol *FindInTypeOrParents(const Scope &, const parser::Name &); 513 Symbol *FindInTypeOrParents(const parser::Name &); 514 void EraseSymbol(const parser::Name &); 515 void EraseSymbol(const Symbol &symbol) { currScope().erase(symbol.name()); } 516 // Make a new symbol with the name and attrs of an existing one 517 Symbol &CopySymbol(const SourceName &, const Symbol &); 518 519 // Make symbols in the current or named scope 520 Symbol &MakeSymbol(Scope &, const SourceName &, Attrs); 521 Symbol &MakeSymbol(const SourceName &, Attrs = Attrs{}); 522 Symbol &MakeSymbol(const parser::Name &, Attrs = Attrs{}); 523 Symbol &MakeHostAssocSymbol(const parser::Name &, const Symbol &); 524 525 template <typename D> 526 common::IfNoLvalue<Symbol &, D> MakeSymbol( 527 const parser::Name &name, D &&details) { 528 return MakeSymbol(name, Attrs{}, std::move(details)); 529 } 530 531 template <typename D> 532 common::IfNoLvalue<Symbol &, D> MakeSymbol( 533 const parser::Name &name, const Attrs &attrs, D &&details) { 534 return Resolve(name, MakeSymbol(name.source, attrs, std::move(details))); 535 } 536 537 template <typename D> 538 common::IfNoLvalue<Symbol &, D> MakeSymbol( 539 const SourceName &name, const Attrs &attrs, D &&details) { 540 // Note: don't use FindSymbol here. If this is a derived type scope, 541 // we want to detect whether the name is already declared as a component. 542 auto *symbol{FindInScope(name)}; 543 if (!symbol) { 544 symbol = &MakeSymbol(name, attrs); 545 symbol->set_details(std::move(details)); 546 return *symbol; 547 } 548 if constexpr (std::is_same_v<DerivedTypeDetails, D>) { 549 if (auto *d{symbol->detailsIf<GenericDetails>()}) { 550 if (!d->specific()) { 551 // derived type with same name as a generic 552 auto *derivedType{d->derivedType()}; 553 if (!derivedType) { 554 derivedType = 555 &currScope().MakeSymbol(name, attrs, std::move(details)); 556 d->set_derivedType(*derivedType); 557 } else { 558 SayAlreadyDeclared(name, *derivedType); 559 } 560 return *derivedType; 561 } 562 } 563 } 564 if (symbol->CanReplaceDetails(details)) { 565 // update the existing symbol 566 symbol->attrs() |= attrs; 567 symbol->set_details(std::move(details)); 568 return *symbol; 569 } else if constexpr (std::is_same_v<UnknownDetails, D>) { 570 symbol->attrs() |= attrs; 571 return *symbol; 572 } else { 573 if (!CheckPossibleBadForwardRef(*symbol)) { 574 SayAlreadyDeclared(name, *symbol); 575 } 576 // replace the old symbol with a new one with correct details 577 EraseSymbol(*symbol); 578 auto &result{MakeSymbol(name, attrs, std::move(details))}; 579 context().SetError(result); 580 return result; 581 } 582 } 583 584 void MakeExternal(Symbol &); 585 586 protected: 587 // Apply the implicit type rules to this symbol. 588 void ApplyImplicitRules(Symbol &, bool allowForwardReference = false); 589 bool ImplicitlyTypeForwardRef(Symbol &); 590 void AcquireIntrinsicProcedureFlags(Symbol &); 591 const DeclTypeSpec *GetImplicitType( 592 Symbol &, bool respectImplicitNoneType = true); 593 bool ConvertToObjectEntity(Symbol &); 594 bool ConvertToProcEntity(Symbol &); 595 596 const DeclTypeSpec &MakeNumericType( 597 TypeCategory, const std::optional<parser::KindSelector> &); 598 const DeclTypeSpec &MakeLogicalType( 599 const std::optional<parser::KindSelector> &); 600 void NotePossibleBadForwardRef(const parser::Name &); 601 std::optional<SourceName> HadForwardRef(const Symbol &) const; 602 bool CheckPossibleBadForwardRef(const Symbol &); 603 604 bool inExecutionPart_{false}; 605 bool inSpecificationPart_{false}; 606 bool inEquivalenceStmt_{false}; 607 608 // Some information is collected from a specification part for deferred 609 // processing in DeclarationPartVisitor functions (e.g., CheckSaveStmts()) 610 // that are called by ResolveNamesVisitor::FinishSpecificationPart(). Since 611 // specification parts can nest (e.g., INTERFACE bodies), the collected 612 // information that is not contained in the scope needs to be packaged 613 // and restorable. 614 struct SpecificationPartState { 615 std::set<SourceName> forwardRefs; 616 // Collect equivalence sets and process at end of specification part 617 std::vector<const std::list<parser::EquivalenceObject> *> equivalenceSets; 618 // Names of all common block objects in the scope 619 std::set<SourceName> commonBlockObjects; 620 // Info about about SAVE statements and attributes in current scope 621 struct { 622 std::optional<SourceName> saveAll; // "SAVE" without entity list 623 std::set<SourceName> entities; // names of entities with save attr 624 std::set<SourceName> commons; // names of common blocks with save attr 625 } saveInfo; 626 } specPartState_; 627 628 private: 629 Scope *currScope_{nullptr}; 630 }; 631 632 class ModuleVisitor : public virtual ScopeHandler { 633 public: 634 bool Pre(const parser::AccessStmt &); 635 bool Pre(const parser::Only &); 636 bool Pre(const parser::Rename::Names &); 637 bool Pre(const parser::Rename::Operators &); 638 bool Pre(const parser::UseStmt &); 639 void Post(const parser::UseStmt &); 640 641 void BeginModule(const parser::Name &, bool isSubmodule); 642 bool BeginSubmodule(const parser::Name &, const parser::ParentIdentifier &); 643 void ApplyDefaultAccess(); 644 void AddGenericUse(GenericDetails &, const SourceName &, const Symbol &); 645 646 private: 647 // The default access spec for this module. 648 Attr defaultAccess_{Attr::PUBLIC}; 649 // The location of the last AccessStmt without access-ids, if any. 650 std::optional<SourceName> prevAccessStmt_; 651 // The scope of the module during a UseStmt 652 Scope *useModuleScope_{nullptr}; 653 654 Symbol &SetAccess(const SourceName &, Attr attr, Symbol * = nullptr); 655 // A rename in a USE statement: local => use 656 struct SymbolRename { 657 Symbol *local{nullptr}; 658 Symbol *use{nullptr}; 659 }; 660 // Record a use from useModuleScope_ of use Name/Symbol as local Name/Symbol 661 SymbolRename AddUse(const SourceName &localName, const SourceName &useName); 662 SymbolRename AddUse(const SourceName &, const SourceName &, Symbol *); 663 void DoAddUse(const SourceName &, const SourceName &, Symbol &localSymbol, 664 const Symbol &useSymbol); 665 void AddUse(const GenericSpecInfo &); 666 Scope *FindModule(const parser::Name &, Scope *ancestor = nullptr); 667 }; 668 669 class InterfaceVisitor : public virtual ScopeHandler { 670 public: 671 bool Pre(const parser::InterfaceStmt &); 672 void Post(const parser::InterfaceStmt &); 673 void Post(const parser::EndInterfaceStmt &); 674 bool Pre(const parser::GenericSpec &); 675 bool Pre(const parser::ProcedureStmt &); 676 bool Pre(const parser::GenericStmt &); 677 void Post(const parser::GenericStmt &); 678 679 bool inInterfaceBlock() const; 680 bool isGeneric() const; 681 bool isAbstract() const; 682 683 protected: 684 Symbol &GetGenericSymbol() { 685 return DEREF(genericInfo_.top().symbol); 686 } 687 // Add to generic the symbol for the subprogram with the same name 688 void CheckGenericProcedures(Symbol &); 689 690 private: 691 // A new GenericInfo is pushed for each interface block and generic stmt 692 struct GenericInfo { 693 GenericInfo(bool isInterface, bool isAbstract = false) 694 : isInterface{isInterface}, isAbstract{isAbstract} {} 695 bool isInterface; // in interface block 696 bool isAbstract; // in abstract interface block 697 Symbol *symbol{nullptr}; // the generic symbol being defined 698 }; 699 std::stack<GenericInfo> genericInfo_; 700 const GenericInfo &GetGenericInfo() const { return genericInfo_.top(); } 701 void SetGenericSymbol(Symbol &symbol) { genericInfo_.top().symbol = &symbol; } 702 703 using ProcedureKind = parser::ProcedureStmt::Kind; 704 // mapping of generic to its specific proc names and kinds 705 std::multimap<Symbol *, std::pair<const parser::Name *, ProcedureKind>> 706 specificProcs_; 707 708 void AddSpecificProcs(const std::list<parser::Name> &, ProcedureKind); 709 void ResolveSpecificsInGeneric(Symbol &generic); 710 }; 711 712 class SubprogramVisitor : public virtual ScopeHandler, public InterfaceVisitor { 713 public: 714 bool HandleStmtFunction(const parser::StmtFunctionStmt &); 715 bool Pre(const parser::SubroutineStmt &); 716 void Post(const parser::SubroutineStmt &); 717 bool Pre(const parser::FunctionStmt &); 718 void Post(const parser::FunctionStmt &); 719 bool Pre(const parser::EntryStmt &); 720 void Post(const parser::EntryStmt &); 721 bool Pre(const parser::InterfaceBody::Subroutine &); 722 void Post(const parser::InterfaceBody::Subroutine &); 723 bool Pre(const parser::InterfaceBody::Function &); 724 void Post(const parser::InterfaceBody::Function &); 725 bool Pre(const parser::Suffix &); 726 bool Pre(const parser::PrefixSpec &); 727 void Post(const parser::ImplicitPart &); 728 729 bool BeginSubprogram( 730 const parser::Name &, Symbol::Flag, bool hasModulePrefix = false); 731 bool BeginMpSubprogram(const parser::Name &); 732 void PushBlockDataScope(const parser::Name &); 733 void EndSubprogram(); 734 735 protected: 736 // Set when we see a stmt function that is really an array element assignment 737 bool badStmtFuncFound_{false}; 738 739 private: 740 // Info about the current function: parse tree of the type in the PrefixSpec; 741 // name and symbol of the function result from the Suffix; source location. 742 struct { 743 const parser::DeclarationTypeSpec *parsedType{nullptr}; 744 const parser::Name *resultName{nullptr}; 745 Symbol *resultSymbol{nullptr}; 746 std::optional<SourceName> source; 747 } funcInfo_; 748 749 // Create a subprogram symbol in the current scope and push a new scope. 750 void CheckExtantProc(const parser::Name &, Symbol::Flag); 751 Symbol &PushSubprogramScope(const parser::Name &, Symbol::Flag); 752 Symbol *GetSpecificFromGeneric(const parser::Name &); 753 SubprogramDetails &PostSubprogramStmt(const parser::Name &); 754 }; 755 756 class DeclarationVisitor : public ArraySpecVisitor, 757 public virtual ScopeHandler { 758 public: 759 using ArraySpecVisitor::Post; 760 using ScopeHandler::Post; 761 using ScopeHandler::Pre; 762 763 bool Pre(const parser::Initialization &); 764 void Post(const parser::EntityDecl &); 765 void Post(const parser::ObjectDecl &); 766 void Post(const parser::PointerDecl &); 767 bool Pre(const parser::BindStmt &) { return BeginAttrs(); } 768 void Post(const parser::BindStmt &) { EndAttrs(); } 769 bool Pre(const parser::BindEntity &); 770 bool Pre(const parser::OldParameterStmt &); 771 bool Pre(const parser::NamedConstantDef &); 772 bool Pre(const parser::NamedConstant &); 773 void Post(const parser::EnumDef &); 774 bool Pre(const parser::Enumerator &); 775 bool Pre(const parser::AccessSpec &); 776 bool Pre(const parser::AsynchronousStmt &); 777 bool Pre(const parser::ContiguousStmt &); 778 bool Pre(const parser::ExternalStmt &); 779 bool Pre(const parser::IntentStmt &); 780 bool Pre(const parser::IntrinsicStmt &); 781 bool Pre(const parser::OptionalStmt &); 782 bool Pre(const parser::ProtectedStmt &); 783 bool Pre(const parser::ValueStmt &); 784 bool Pre(const parser::VolatileStmt &); 785 bool Pre(const parser::AllocatableStmt &) { 786 objectDeclAttr_ = Attr::ALLOCATABLE; 787 return true; 788 } 789 void Post(const parser::AllocatableStmt &) { objectDeclAttr_ = std::nullopt; } 790 bool Pre(const parser::TargetStmt &) { 791 objectDeclAttr_ = Attr::TARGET; 792 return true; 793 } 794 void Post(const parser::TargetStmt &) { objectDeclAttr_ = std::nullopt; } 795 void Post(const parser::DimensionStmt::Declaration &); 796 void Post(const parser::CodimensionDecl &); 797 bool Pre(const parser::TypeDeclarationStmt &) { return BeginDecl(); } 798 void Post(const parser::TypeDeclarationStmt &); 799 void Post(const parser::IntegerTypeSpec &); 800 void Post(const parser::IntrinsicTypeSpec::Real &); 801 void Post(const parser::IntrinsicTypeSpec::Complex &); 802 void Post(const parser::IntrinsicTypeSpec::Logical &); 803 void Post(const parser::IntrinsicTypeSpec::Character &); 804 void Post(const parser::CharSelector::LengthAndKind &); 805 void Post(const parser::CharLength &); 806 void Post(const parser::LengthSelector &); 807 bool Pre(const parser::KindParam &); 808 bool Pre(const parser::DeclarationTypeSpec::Type &); 809 void Post(const parser::DeclarationTypeSpec::Type &); 810 bool Pre(const parser::DeclarationTypeSpec::Class &); 811 void Post(const parser::DeclarationTypeSpec::Class &); 812 bool Pre(const parser::DeclarationTypeSpec::Record &); 813 void Post(const parser::DerivedTypeSpec &); 814 bool Pre(const parser::DerivedTypeDef &); 815 bool Pre(const parser::DerivedTypeStmt &); 816 void Post(const parser::DerivedTypeStmt &); 817 bool Pre(const parser::TypeParamDefStmt &) { return BeginDecl(); } 818 void Post(const parser::TypeParamDefStmt &); 819 bool Pre(const parser::TypeAttrSpec::Extends &); 820 bool Pre(const parser::PrivateStmt &); 821 bool Pre(const parser::SequenceStmt &); 822 bool Pre(const parser::ComponentDefStmt &) { return BeginDecl(); } 823 void Post(const parser::ComponentDefStmt &) { EndDecl(); } 824 void Post(const parser::ComponentDecl &); 825 bool Pre(const parser::ProcedureDeclarationStmt &); 826 void Post(const parser::ProcedureDeclarationStmt &); 827 bool Pre(const parser::DataComponentDefStmt &); // returns false 828 bool Pre(const parser::ProcComponentDefStmt &); 829 void Post(const parser::ProcComponentDefStmt &); 830 bool Pre(const parser::ProcPointerInit &); 831 void Post(const parser::ProcInterface &); 832 void Post(const parser::ProcDecl &); 833 bool Pre(const parser::TypeBoundProcedurePart &); 834 void Post(const parser::TypeBoundProcedurePart &); 835 void Post(const parser::ContainsStmt &); 836 bool Pre(const parser::TypeBoundProcBinding &) { return BeginAttrs(); } 837 void Post(const parser::TypeBoundProcBinding &) { EndAttrs(); } 838 void Post(const parser::TypeBoundProcedureStmt::WithoutInterface &); 839 void Post(const parser::TypeBoundProcedureStmt::WithInterface &); 840 void Post(const parser::FinalProcedureStmt &); 841 bool Pre(const parser::TypeBoundGenericStmt &); 842 bool Pre(const parser::AllocateStmt &); 843 void Post(const parser::AllocateStmt &); 844 bool Pre(const parser::StructureConstructor &); 845 bool Pre(const parser::NamelistStmt::Group &); 846 bool Pre(const parser::IoControlSpec &); 847 bool Pre(const parser::CommonStmt::Block &); 848 bool Pre(const parser::CommonBlockObject &); 849 void Post(const parser::CommonBlockObject &); 850 bool Pre(const parser::EquivalenceStmt &); 851 bool Pre(const parser::SaveStmt &); 852 bool Pre(const parser::BasedPointerStmt &); 853 854 void PointerInitialization( 855 const parser::Name &, const parser::InitialDataTarget &); 856 void PointerInitialization( 857 const parser::Name &, const parser::ProcPointerInit &); 858 void NonPointerInitialization( 859 const parser::Name &, const parser::ConstantExpr &); 860 void CheckExplicitInterface(const parser::Name &); 861 void CheckBindings(const parser::TypeBoundProcedureStmt::WithoutInterface &); 862 863 const parser::Name *ResolveDesignator(const parser::Designator &); 864 865 protected: 866 bool BeginDecl(); 867 void EndDecl(); 868 Symbol &DeclareObjectEntity(const parser::Name &, Attrs = Attrs{}); 869 // Make sure that there's an entity in an enclosing scope called Name 870 Symbol &FindOrDeclareEnclosingEntity(const parser::Name &); 871 // Declare a LOCAL/LOCAL_INIT entity. If there isn't a type specified 872 // it comes from the entity in the containing scope, or implicit rules. 873 // Return pointer to the new symbol, or nullptr on error. 874 Symbol *DeclareLocalEntity(const parser::Name &); 875 // Declare a statement entity (e.g., an implied DO loop index). 876 // If there isn't a type specified, implicit rules apply. 877 // Return pointer to the new symbol, or nullptr on error. 878 Symbol *DeclareStatementEntity( 879 const parser::Name &, const std::optional<parser::IntegerTypeSpec> &); 880 Symbol &MakeCommonBlockSymbol(const parser::Name &); 881 Symbol &MakeCommonBlockSymbol(const std::optional<parser::Name> &); 882 bool CheckUseError(const parser::Name &); 883 void CheckAccessibility(const SourceName &, bool, Symbol &); 884 void CheckCommonBlocks(); 885 void CheckSaveStmts(); 886 void CheckEquivalenceSets(); 887 bool CheckNotInBlock(const char *); 888 bool NameIsKnownOrIntrinsic(const parser::Name &); 889 890 // Each of these returns a pointer to a resolved Name (i.e. with symbol) 891 // or nullptr in case of error. 892 const parser::Name *ResolveStructureComponent( 893 const parser::StructureComponent &); 894 const parser::Name *ResolveDataRef(const parser::DataRef &); 895 const parser::Name *ResolveName(const parser::Name &); 896 bool PassesSharedLocalityChecks(const parser::Name &name, Symbol &symbol); 897 Symbol *NoteInterfaceName(const parser::Name &); 898 899 private: 900 // The attribute corresponding to the statement containing an ObjectDecl 901 std::optional<Attr> objectDeclAttr_; 902 // Info about current character type while walking DeclTypeSpec. 903 // Also captures any "*length" specifier on an individual declaration. 904 struct { 905 std::optional<ParamValue> length; 906 std::optional<KindExpr> kind; 907 } charInfo_; 908 // Info about current derived type while walking DerivedTypeDef 909 struct { 910 const parser::Name *extends{nullptr}; // EXTENDS(name) 911 bool privateComps{false}; // components are private by default 912 bool privateBindings{false}; // bindings are private by default 913 bool sawContains{false}; // currently processing bindings 914 bool sequence{false}; // is a sequence type 915 const Symbol *type{nullptr}; // derived type being defined 916 } derivedTypeInfo_; 917 // In a ProcedureDeclarationStmt or ProcComponentDefStmt, this is 918 // the interface name, if any. 919 const parser::Name *interfaceName_{nullptr}; 920 // Map type-bound generic to binding names of its specific bindings 921 std::multimap<Symbol *, const parser::Name *> genericBindings_; 922 // Info about current ENUM 923 struct EnumeratorState { 924 // Enum value must hold inside a C_INT (7.6.2). 925 std::optional<int> value{0}; 926 } enumerationState_; 927 // Set for OldParameterStmt processing 928 bool inOldStyleParameterStmt_{false}; 929 930 bool HandleAttributeStmt(Attr, const std::list<parser::Name> &); 931 Symbol &HandleAttributeStmt(Attr, const parser::Name &); 932 Symbol &DeclareUnknownEntity(const parser::Name &, Attrs); 933 Symbol &DeclareProcEntity(const parser::Name &, Attrs, const ProcInterface &); 934 void SetType(const parser::Name &, const DeclTypeSpec &); 935 std::optional<DerivedTypeSpec> ResolveDerivedType(const parser::Name &); 936 std::optional<DerivedTypeSpec> ResolveExtendsType( 937 const parser::Name &, const parser::Name *); 938 Symbol *MakeTypeSymbol(const SourceName &, Details &&); 939 Symbol *MakeTypeSymbol(const parser::Name &, Details &&); 940 bool OkToAddComponent(const parser::Name &, const Symbol * = nullptr); 941 ParamValue GetParamValue( 942 const parser::TypeParamValue &, common::TypeParamAttr attr); 943 void CheckCommonBlockDerivedType(const SourceName &, const Symbol &); 944 std::optional<MessageFixedText> CheckSaveAttr(const Symbol &); 945 Attrs HandleSaveName(const SourceName &, Attrs); 946 void AddSaveName(std::set<SourceName> &, const SourceName &); 947 void SetSaveAttr(Symbol &); 948 bool HandleUnrestrictedSpecificIntrinsicFunction(const parser::Name &); 949 bool IsUplevelReference(const Symbol &); 950 const parser::Name *FindComponent(const parser::Name *, const parser::Name &); 951 void Initialization(const parser::Name &, const parser::Initialization &, 952 bool inComponentDecl); 953 bool PassesLocalityChecks(const parser::Name &name, Symbol &symbol); 954 bool CheckForHostAssociatedImplicit(const parser::Name &); 955 956 // Declare an object or procedure entity. 957 // T is one of: EntityDetails, ObjectEntityDetails, ProcEntityDetails 958 template <typename T> 959 Symbol &DeclareEntity(const parser::Name &name, Attrs attrs) { 960 Symbol &symbol{MakeSymbol(name, attrs)}; 961 if (context().HasError(symbol) || symbol.has<T>()) { 962 return symbol; // OK or error already reported 963 } else if (symbol.has<UnknownDetails>()) { 964 symbol.set_details(T{}); 965 return symbol; 966 } else if (auto *details{symbol.detailsIf<EntityDetails>()}) { 967 symbol.set_details(T{std::move(*details)}); 968 return symbol; 969 } else if (std::is_same_v<EntityDetails, T> && 970 (symbol.has<ObjectEntityDetails>() || 971 symbol.has<ProcEntityDetails>())) { 972 return symbol; // OK 973 } else if (auto *details{symbol.detailsIf<UseDetails>()}) { 974 Say(name.source, 975 "'%s' is use-associated from module '%s' and cannot be re-declared"_err_en_US, 976 name.source, GetUsedModule(*details).name()); 977 } else if (auto *details{symbol.detailsIf<SubprogramNameDetails>()}) { 978 if (details->kind() == SubprogramKind::Module) { 979 Say2(name, 980 "Declaration of '%s' conflicts with its use as module procedure"_err_en_US, 981 symbol, "Module procedure definition"_en_US); 982 } else if (details->kind() == SubprogramKind::Internal) { 983 Say2(name, 984 "Declaration of '%s' conflicts with its use as internal procedure"_err_en_US, 985 symbol, "Internal procedure definition"_en_US); 986 } else { 987 DIE("unexpected kind"); 988 } 989 } else if (std::is_same_v<ObjectEntityDetails, T> && 990 symbol.has<ProcEntityDetails>()) { 991 SayWithDecl( 992 name, symbol, "'%s' is already declared as a procedure"_err_en_US); 993 } else if (std::is_same_v<ProcEntityDetails, T> && 994 symbol.has<ObjectEntityDetails>()) { 995 if (InCommonBlock(symbol)) { 996 SayWithDecl(name, symbol, 997 "'%s' may not be a procedure as it is in a COMMON block"_err_en_US); 998 } else { 999 SayWithDecl( 1000 name, symbol, "'%s' is already declared as an object"_err_en_US); 1001 } 1002 } else if (!CheckPossibleBadForwardRef(symbol)) { 1003 SayAlreadyDeclared(name, symbol); 1004 } 1005 context().SetError(symbol); 1006 return symbol; 1007 } 1008 bool HasCycle(const Symbol &, const ProcInterface &); 1009 }; 1010 1011 // Resolve construct entities and statement entities. 1012 // Check that construct names don't conflict with other names. 1013 class ConstructVisitor : public virtual DeclarationVisitor { 1014 public: 1015 bool Pre(const parser::ConcurrentHeader &); 1016 bool Pre(const parser::LocalitySpec::Local &); 1017 bool Pre(const parser::LocalitySpec::LocalInit &); 1018 bool Pre(const parser::LocalitySpec::Shared &); 1019 bool Pre(const parser::AcSpec &); 1020 bool Pre(const parser::AcImpliedDo &); 1021 bool Pre(const parser::DataImpliedDo &); 1022 bool Pre(const parser::DataIDoObject &); 1023 bool Pre(const parser::DataStmtObject &); 1024 bool Pre(const parser::DataStmtValue &); 1025 bool Pre(const parser::DoConstruct &); 1026 void Post(const parser::DoConstruct &); 1027 bool Pre(const parser::ForallConstruct &); 1028 void Post(const parser::ForallConstruct &); 1029 bool Pre(const parser::ForallStmt &); 1030 void Post(const parser::ForallStmt &); 1031 bool Pre(const parser::BlockStmt &); 1032 bool Pre(const parser::EndBlockStmt &); 1033 void Post(const parser::Selector &); 1034 void Post(const parser::AssociateStmt &); 1035 void Post(const parser::EndAssociateStmt &); 1036 bool Pre(const parser::Association &); 1037 void Post(const parser::SelectTypeStmt &); 1038 void Post(const parser::SelectRankStmt &); 1039 bool Pre(const parser::SelectTypeConstruct &); 1040 void Post(const parser::SelectTypeConstruct &); 1041 bool Pre(const parser::SelectTypeConstruct::TypeCase &); 1042 void Post(const parser::SelectTypeConstruct::TypeCase &); 1043 // Creates Block scopes with neither symbol name nor symbol details. 1044 bool Pre(const parser::SelectRankConstruct::RankCase &); 1045 void Post(const parser::SelectRankConstruct::RankCase &); 1046 void Post(const parser::TypeGuardStmt::Guard &); 1047 void Post(const parser::SelectRankCaseStmt::Rank &); 1048 bool Pre(const parser::ChangeTeamStmt &); 1049 void Post(const parser::EndChangeTeamStmt &); 1050 void Post(const parser::CoarrayAssociation &); 1051 1052 // Definitions of construct names 1053 bool Pre(const parser::WhereConstructStmt &x) { return CheckDef(x.t); } 1054 bool Pre(const parser::ForallConstructStmt &x) { return CheckDef(x.t); } 1055 bool Pre(const parser::CriticalStmt &x) { return CheckDef(x.t); } 1056 bool Pre(const parser::LabelDoStmt &) { 1057 return false; // error recovery 1058 } 1059 bool Pre(const parser::NonLabelDoStmt &x) { return CheckDef(x.t); } 1060 bool Pre(const parser::IfThenStmt &x) { return CheckDef(x.t); } 1061 bool Pre(const parser::SelectCaseStmt &x) { return CheckDef(x.t); } 1062 bool Pre(const parser::SelectRankConstruct &); 1063 void Post(const parser::SelectRankConstruct &); 1064 bool Pre(const parser::SelectRankStmt &x) { 1065 return CheckDef(std::get<0>(x.t)); 1066 } 1067 bool Pre(const parser::SelectTypeStmt &x) { 1068 return CheckDef(std::get<0>(x.t)); 1069 } 1070 1071 // References to construct names 1072 void Post(const parser::MaskedElsewhereStmt &x) { CheckRef(x.t); } 1073 void Post(const parser::ElsewhereStmt &x) { CheckRef(x.v); } 1074 void Post(const parser::EndWhereStmt &x) { CheckRef(x.v); } 1075 void Post(const parser::EndForallStmt &x) { CheckRef(x.v); } 1076 void Post(const parser::EndCriticalStmt &x) { CheckRef(x.v); } 1077 void Post(const parser::EndDoStmt &x) { CheckRef(x.v); } 1078 void Post(const parser::ElseIfStmt &x) { CheckRef(x.t); } 1079 void Post(const parser::ElseStmt &x) { CheckRef(x.v); } 1080 void Post(const parser::EndIfStmt &x) { CheckRef(x.v); } 1081 void Post(const parser::CaseStmt &x) { CheckRef(x.t); } 1082 void Post(const parser::EndSelectStmt &x) { CheckRef(x.v); } 1083 void Post(const parser::SelectRankCaseStmt &x) { CheckRef(x.t); } 1084 void Post(const parser::TypeGuardStmt &x) { CheckRef(x.t); } 1085 void Post(const parser::CycleStmt &x) { CheckRef(x.v); } 1086 void Post(const parser::ExitStmt &x) { CheckRef(x.v); } 1087 1088 private: 1089 // R1105 selector -> expr | variable 1090 // expr is set in either case unless there were errors 1091 struct Selector { 1092 Selector() {} 1093 Selector(const SourceName &source, MaybeExpr &&expr) 1094 : source{source}, expr{std::move(expr)} {} 1095 operator bool() const { return expr.has_value(); } 1096 parser::CharBlock source; 1097 MaybeExpr expr; 1098 }; 1099 // association -> [associate-name =>] selector 1100 struct Association { 1101 const parser::Name *name{nullptr}; 1102 Selector selector; 1103 }; 1104 std::vector<Association> associationStack_; 1105 Association *currentAssociation_{nullptr}; 1106 1107 template <typename T> bool CheckDef(const T &t) { 1108 return CheckDef(std::get<std::optional<parser::Name>>(t)); 1109 } 1110 template <typename T> void CheckRef(const T &t) { 1111 CheckRef(std::get<std::optional<parser::Name>>(t)); 1112 } 1113 bool CheckDef(const std::optional<parser::Name> &); 1114 void CheckRef(const std::optional<parser::Name> &); 1115 const DeclTypeSpec &ToDeclTypeSpec(evaluate::DynamicType &&); 1116 const DeclTypeSpec &ToDeclTypeSpec( 1117 evaluate::DynamicType &&, MaybeSubscriptIntExpr &&length); 1118 Symbol *MakeAssocEntity(); 1119 void SetTypeFromAssociation(Symbol &); 1120 void SetAttrsFromAssociation(Symbol &); 1121 Selector ResolveSelector(const parser::Selector &); 1122 void ResolveIndexName(const parser::ConcurrentControl &control); 1123 void SetCurrentAssociation(std::size_t n); 1124 Association &GetCurrentAssociation(); 1125 void PushAssociation(); 1126 void PopAssociation(std::size_t count = 1); 1127 }; 1128 1129 // Create scopes for OpenACC constructs 1130 class AccVisitor : public virtual DeclarationVisitor { 1131 public: 1132 void AddAccSourceRange(const parser::CharBlock &); 1133 1134 static bool NeedsScope(const parser::OpenACCBlockConstruct &); 1135 1136 bool Pre(const parser::OpenACCBlockConstruct &); 1137 void Post(const parser::OpenACCBlockConstruct &); 1138 bool Pre(const parser::AccBeginBlockDirective &x) { 1139 AddAccSourceRange(x.source); 1140 return true; 1141 } 1142 void Post(const parser::AccBeginBlockDirective &) { 1143 messageHandler().set_currStmtSource(std::nullopt); 1144 } 1145 bool Pre(const parser::AccEndBlockDirective &x) { 1146 AddAccSourceRange(x.source); 1147 return true; 1148 } 1149 void Post(const parser::AccEndBlockDirective &) { 1150 messageHandler().set_currStmtSource(std::nullopt); 1151 } 1152 bool Pre(const parser::AccBeginLoopDirective &x) { 1153 AddAccSourceRange(x.source); 1154 return true; 1155 } 1156 void Post(const parser::AccBeginLoopDirective &x) { 1157 messageHandler().set_currStmtSource(std::nullopt); 1158 } 1159 }; 1160 1161 bool AccVisitor::NeedsScope(const parser::OpenACCBlockConstruct &x) { 1162 const auto &beginBlockDir{std::get<parser::AccBeginBlockDirective>(x.t)}; 1163 const auto &beginDir{std::get<parser::AccBlockDirective>(beginBlockDir.t)}; 1164 switch (beginDir.v) { 1165 case llvm::acc::Directive::ACCD_data: 1166 case llvm::acc::Directive::ACCD_host_data: 1167 case llvm::acc::Directive::ACCD_kernels: 1168 case llvm::acc::Directive::ACCD_parallel: 1169 case llvm::acc::Directive::ACCD_serial: 1170 return true; 1171 default: 1172 return false; 1173 } 1174 } 1175 1176 void AccVisitor::AddAccSourceRange(const parser::CharBlock &source) { 1177 messageHandler().set_currStmtSource(source); 1178 currScope().AddSourceRange(source); 1179 } 1180 1181 bool AccVisitor::Pre(const parser::OpenACCBlockConstruct &x) { 1182 if (NeedsScope(x)) { 1183 PushScope(Scope::Kind::Block, nullptr); 1184 } 1185 return true; 1186 } 1187 1188 void AccVisitor::Post(const parser::OpenACCBlockConstruct &x) { 1189 if (NeedsScope(x)) { 1190 PopScope(); 1191 } 1192 } 1193 1194 // Create scopes for OpenMP constructs 1195 class OmpVisitor : public virtual DeclarationVisitor { 1196 public: 1197 void AddOmpSourceRange(const parser::CharBlock &); 1198 1199 static bool NeedsScope(const parser::OpenMPBlockConstruct &); 1200 1201 bool Pre(const parser::OpenMPBlockConstruct &); 1202 void Post(const parser::OpenMPBlockConstruct &); 1203 bool Pre(const parser::OmpBeginBlockDirective &x) { 1204 AddOmpSourceRange(x.source); 1205 return true; 1206 } 1207 void Post(const parser::OmpBeginBlockDirective &) { 1208 messageHandler().set_currStmtSource(std::nullopt); 1209 } 1210 bool Pre(const parser::OmpEndBlockDirective &x) { 1211 AddOmpSourceRange(x.source); 1212 return true; 1213 } 1214 void Post(const parser::OmpEndBlockDirective &) { 1215 messageHandler().set_currStmtSource(std::nullopt); 1216 } 1217 1218 bool Pre(const parser::OpenMPLoopConstruct &) { 1219 PushScope(Scope::Kind::Block, nullptr); 1220 return true; 1221 } 1222 void Post(const parser::OpenMPLoopConstruct &) { PopScope(); } 1223 bool Pre(const parser::OmpBeginLoopDirective &x) { 1224 AddOmpSourceRange(x.source); 1225 return true; 1226 } 1227 void Post(const parser::OmpBeginLoopDirective &) { 1228 messageHandler().set_currStmtSource(std::nullopt); 1229 } 1230 bool Pre(const parser::OmpEndLoopDirective &x) { 1231 AddOmpSourceRange(x.source); 1232 return true; 1233 } 1234 void Post(const parser::OmpEndLoopDirective &) { 1235 messageHandler().set_currStmtSource(std::nullopt); 1236 } 1237 1238 bool Pre(const parser::OpenMPSectionsConstruct &) { 1239 PushScope(Scope::Kind::Block, nullptr); 1240 return true; 1241 } 1242 void Post(const parser::OpenMPSectionsConstruct &) { PopScope(); } 1243 bool Pre(const parser::OmpBeginSectionsDirective &x) { 1244 AddOmpSourceRange(x.source); 1245 return true; 1246 } 1247 void Post(const parser::OmpBeginSectionsDirective &) { 1248 messageHandler().set_currStmtSource(std::nullopt); 1249 } 1250 bool Pre(const parser::OmpEndSectionsDirective &x) { 1251 AddOmpSourceRange(x.source); 1252 return true; 1253 } 1254 void Post(const parser::OmpEndSectionsDirective &) { 1255 messageHandler().set_currStmtSource(std::nullopt); 1256 } 1257 }; 1258 1259 bool OmpVisitor::NeedsScope(const parser::OpenMPBlockConstruct &x) { 1260 const auto &beginBlockDir{std::get<parser::OmpBeginBlockDirective>(x.t)}; 1261 const auto &beginDir{std::get<parser::OmpBlockDirective>(beginBlockDir.t)}; 1262 switch (beginDir.v) { 1263 case llvm::omp::Directive::OMPD_target_data: 1264 case llvm::omp::Directive::OMPD_master: 1265 case llvm::omp::Directive::OMPD_ordered: 1266 return false; 1267 default: 1268 return true; 1269 } 1270 } 1271 1272 void OmpVisitor::AddOmpSourceRange(const parser::CharBlock &source) { 1273 messageHandler().set_currStmtSource(source); 1274 currScope().AddSourceRange(source); 1275 } 1276 1277 bool OmpVisitor::Pre(const parser::OpenMPBlockConstruct &x) { 1278 if (NeedsScope(x)) { 1279 PushScope(Scope::Kind::Block, nullptr); 1280 } 1281 return true; 1282 } 1283 1284 void OmpVisitor::Post(const parser::OpenMPBlockConstruct &x) { 1285 if (NeedsScope(x)) { 1286 PopScope(); 1287 } 1288 } 1289 1290 // Walk the parse tree and resolve names to symbols. 1291 class ResolveNamesVisitor : public virtual ScopeHandler, 1292 public ModuleVisitor, 1293 public SubprogramVisitor, 1294 public ConstructVisitor, 1295 public OmpVisitor, 1296 public AccVisitor { 1297 public: 1298 using AccVisitor::Post; 1299 using AccVisitor::Pre; 1300 using ArraySpecVisitor::Post; 1301 using ConstructVisitor::Post; 1302 using ConstructVisitor::Pre; 1303 using DeclarationVisitor::Post; 1304 using DeclarationVisitor::Pre; 1305 using ImplicitRulesVisitor::Post; 1306 using ImplicitRulesVisitor::Pre; 1307 using InterfaceVisitor::Post; 1308 using InterfaceVisitor::Pre; 1309 using ModuleVisitor::Post; 1310 using ModuleVisitor::Pre; 1311 using OmpVisitor::Post; 1312 using OmpVisitor::Pre; 1313 using ScopeHandler::Post; 1314 using ScopeHandler::Pre; 1315 using SubprogramVisitor::Post; 1316 using SubprogramVisitor::Pre; 1317 1318 ResolveNamesVisitor(SemanticsContext &context, ImplicitRulesMap &rules) 1319 : BaseVisitor{context, *this, rules} { 1320 PushScope(context.globalScope()); 1321 } 1322 1323 // Default action for a parse tree node is to visit children. 1324 template <typename T> bool Pre(const T &) { return true; } 1325 template <typename T> void Post(const T &) {} 1326 1327 bool Pre(const parser::SpecificationPart &); 1328 void Post(const parser::Program &); 1329 bool Pre(const parser::ImplicitStmt &); 1330 void Post(const parser::PointerObject &); 1331 void Post(const parser::AllocateObject &); 1332 bool Pre(const parser::PointerAssignmentStmt &); 1333 void Post(const parser::Designator &); 1334 template <typename A, typename B> 1335 void Post(const parser::LoopBounds<A, B> &x) { 1336 ResolveName(*parser::Unwrap<parser::Name>(x.name)); 1337 } 1338 void Post(const parser::ProcComponentRef &); 1339 bool Pre(const parser::FunctionReference &); 1340 bool Pre(const parser::CallStmt &); 1341 bool Pre(const parser::ImportStmt &); 1342 void Post(const parser::TypeGuardStmt &); 1343 bool Pre(const parser::StmtFunctionStmt &); 1344 bool Pre(const parser::DefinedOpName &); 1345 bool Pre(const parser::ProgramUnit &); 1346 void Post(const parser::AssignStmt &); 1347 void Post(const parser::AssignedGotoStmt &); 1348 1349 // These nodes should never be reached: they are handled in ProgramUnit 1350 bool Pre(const parser::MainProgram &) { 1351 llvm_unreachable("This node is handled in ProgramUnit"); 1352 } 1353 bool Pre(const parser::FunctionSubprogram &) { 1354 llvm_unreachable("This node is handled in ProgramUnit"); 1355 } 1356 bool Pre(const parser::SubroutineSubprogram &) { 1357 llvm_unreachable("This node is handled in ProgramUnit"); 1358 } 1359 bool Pre(const parser::SeparateModuleSubprogram &) { 1360 llvm_unreachable("This node is handled in ProgramUnit"); 1361 } 1362 bool Pre(const parser::Module &) { 1363 llvm_unreachable("This node is handled in ProgramUnit"); 1364 } 1365 bool Pre(const parser::Submodule &) { 1366 llvm_unreachable("This node is handled in ProgramUnit"); 1367 } 1368 bool Pre(const parser::BlockData &) { 1369 llvm_unreachable("This node is handled in ProgramUnit"); 1370 } 1371 1372 void NoteExecutablePartCall(Symbol::Flag, const parser::Call &); 1373 1374 friend void ResolveSpecificationParts(SemanticsContext &, const Symbol &); 1375 1376 private: 1377 // Kind of procedure we are expecting to see in a ProcedureDesignator 1378 std::optional<Symbol::Flag> expectedProcFlag_; 1379 std::optional<SourceName> prevImportStmt_; 1380 1381 void PreSpecificationConstruct(const parser::SpecificationConstruct &); 1382 void CreateCommonBlockSymbols(const parser::CommonStmt &); 1383 void CreateGeneric(const parser::GenericSpec &); 1384 void FinishSpecificationPart(const std::list<parser::DeclarationConstruct> &); 1385 void AnalyzeStmtFunctionStmt(const parser::StmtFunctionStmt &); 1386 void CheckImports(); 1387 void CheckImport(const SourceName &, const SourceName &); 1388 void HandleCall(Symbol::Flag, const parser::Call &); 1389 void HandleProcedureName(Symbol::Flag, const parser::Name &); 1390 bool CheckImplicitNoneExternal(const SourceName &, const Symbol &); 1391 bool SetProcFlag(const parser::Name &, Symbol &, Symbol::Flag); 1392 void ResolveSpecificationParts(ProgramTree &); 1393 void AddSubpNames(ProgramTree &); 1394 bool BeginScopeForNode(const ProgramTree &); 1395 void FinishSpecificationParts(const ProgramTree &); 1396 void FinishDerivedTypeInstantiation(Scope &); 1397 void ResolveExecutionParts(const ProgramTree &); 1398 }; 1399 1400 // ImplicitRules implementation 1401 1402 bool ImplicitRules::isImplicitNoneType() const { 1403 if (isImplicitNoneType_) { 1404 return true; 1405 } else if (map_.empty() && inheritFromParent_) { 1406 return parent_->isImplicitNoneType(); 1407 } else { 1408 return false; // default if not specified 1409 } 1410 } 1411 1412 bool ImplicitRules::isImplicitNoneExternal() const { 1413 if (isImplicitNoneExternal_) { 1414 return true; 1415 } else if (inheritFromParent_) { 1416 return parent_->isImplicitNoneExternal(); 1417 } else { 1418 return false; // default if not specified 1419 } 1420 } 1421 1422 const DeclTypeSpec *ImplicitRules::GetType( 1423 SourceName name, bool respectImplicitNoneType) const { 1424 char ch{name.begin()[0]}; 1425 if (isImplicitNoneType_ && respectImplicitNoneType) { 1426 return nullptr; 1427 } else if (auto it{map_.find(ch)}; it != map_.end()) { 1428 return &*it->second; 1429 } else if (inheritFromParent_) { 1430 return parent_->GetType(name, respectImplicitNoneType); 1431 } else if (ch >= 'i' && ch <= 'n') { 1432 return &context_.MakeNumericType(TypeCategory::Integer); 1433 } else if (ch >= 'a' && ch <= 'z') { 1434 return &context_.MakeNumericType(TypeCategory::Real); 1435 } else { 1436 return nullptr; 1437 } 1438 } 1439 1440 void ImplicitRules::SetTypeMapping(const DeclTypeSpec &type, 1441 parser::Location fromLetter, parser::Location toLetter) { 1442 for (char ch = *fromLetter; ch; ch = ImplicitRules::Incr(ch)) { 1443 auto res{map_.emplace(ch, type)}; 1444 if (!res.second) { 1445 context_.Say(parser::CharBlock{fromLetter}, 1446 "More than one implicit type specified for '%c'"_err_en_US, ch); 1447 } 1448 if (ch == *toLetter) { 1449 break; 1450 } 1451 } 1452 } 1453 1454 // Return the next char after ch in a way that works for ASCII or EBCDIC. 1455 // Return '\0' for the char after 'z'. 1456 char ImplicitRules::Incr(char ch) { 1457 switch (ch) { 1458 case 'i': 1459 return 'j'; 1460 case 'r': 1461 return 's'; 1462 case 'z': 1463 return '\0'; 1464 default: 1465 return ch + 1; 1466 } 1467 } 1468 1469 llvm::raw_ostream &operator<<( 1470 llvm::raw_ostream &o, const ImplicitRules &implicitRules) { 1471 o << "ImplicitRules:\n"; 1472 for (char ch = 'a'; ch; ch = ImplicitRules::Incr(ch)) { 1473 ShowImplicitRule(o, implicitRules, ch); 1474 } 1475 ShowImplicitRule(o, implicitRules, '_'); 1476 ShowImplicitRule(o, implicitRules, '$'); 1477 ShowImplicitRule(o, implicitRules, '@'); 1478 return o; 1479 } 1480 void ShowImplicitRule( 1481 llvm::raw_ostream &o, const ImplicitRules &implicitRules, char ch) { 1482 auto it{implicitRules.map_.find(ch)}; 1483 if (it != implicitRules.map_.end()) { 1484 o << " " << ch << ": " << *it->second << '\n'; 1485 } 1486 } 1487 1488 template <typename T> void BaseVisitor::Walk(const T &x) { 1489 parser::Walk(x, *this_); 1490 } 1491 1492 void BaseVisitor::MakePlaceholder( 1493 const parser::Name &name, MiscDetails::Kind kind) { 1494 if (!name.symbol) { 1495 name.symbol = &context_->globalScope().MakeSymbol( 1496 name.source, Attrs{}, MiscDetails{kind}); 1497 } 1498 } 1499 1500 // AttrsVisitor implementation 1501 1502 bool AttrsVisitor::BeginAttrs() { 1503 CHECK(!attrs_); 1504 attrs_ = std::make_optional<Attrs>(); 1505 return true; 1506 } 1507 Attrs AttrsVisitor::GetAttrs() { 1508 CHECK(attrs_); 1509 return *attrs_; 1510 } 1511 Attrs AttrsVisitor::EndAttrs() { 1512 Attrs result{GetAttrs()}; 1513 attrs_.reset(); 1514 passName_ = std::nullopt; 1515 bindName_.reset(); 1516 return result; 1517 } 1518 1519 bool AttrsVisitor::SetPassNameOn(Symbol &symbol) { 1520 if (!passName_) { 1521 return false; 1522 } 1523 std::visit(common::visitors{ 1524 [&](ProcEntityDetails &x) { x.set_passName(*passName_); }, 1525 [&](ProcBindingDetails &x) { x.set_passName(*passName_); }, 1526 [](auto &) { common::die("unexpected pass name"); }, 1527 }, 1528 symbol.details()); 1529 return true; 1530 } 1531 1532 bool AttrsVisitor::SetBindNameOn(Symbol &symbol) { 1533 if (!attrs_ || !attrs_->test(Attr::BIND_C)) { 1534 return false; 1535 } 1536 std::optional<std::string> label{evaluate::GetScalarConstantValue< 1537 evaluate::Type<TypeCategory::Character, 1>>(bindName_)}; 1538 // 18.9.2(2): discard leading and trailing blanks, ignore if all blank 1539 if (label) { 1540 auto first{label->find_first_not_of(" ")}; 1541 auto last{label->find_last_not_of(" ")}; 1542 if (first == std::string::npos) { 1543 Say(currStmtSource().value(), "Blank binding label ignored"_en_US); 1544 label.reset(); 1545 } else { 1546 label = label->substr(first, last - first + 1); 1547 } 1548 } 1549 if (!label) { 1550 label = parser::ToLowerCaseLetters(symbol.name().ToString()); 1551 } 1552 symbol.SetBindName(std::move(*label)); 1553 return true; 1554 } 1555 1556 void AttrsVisitor::Post(const parser::LanguageBindingSpec &x) { 1557 CHECK(attrs_); 1558 if (CheckAndSet(Attr::BIND_C)) { 1559 if (x.v) { 1560 bindName_ = EvaluateExpr(*x.v); 1561 } 1562 } 1563 } 1564 bool AttrsVisitor::Pre(const parser::IntentSpec &x) { 1565 CHECK(attrs_); 1566 CheckAndSet(IntentSpecToAttr(x)); 1567 return false; 1568 } 1569 bool AttrsVisitor::Pre(const parser::Pass &x) { 1570 if (CheckAndSet(Attr::PASS)) { 1571 if (x.v) { 1572 passName_ = x.v->source; 1573 MakePlaceholder(*x.v, MiscDetails::Kind::PassName); 1574 } 1575 } 1576 return false; 1577 } 1578 1579 // C730, C743, C755, C778, C1543 say no attribute or prefix repetitions 1580 bool AttrsVisitor::IsDuplicateAttr(Attr attrName) { 1581 if (attrs_->test(attrName)) { 1582 Say(currStmtSource().value(), 1583 "Attribute '%s' cannot be used more than once"_en_US, 1584 AttrToString(attrName)); 1585 return true; 1586 } 1587 return false; 1588 } 1589 1590 // See if attrName violates a constraint cause by a conflict. attr1 and attr2 1591 // name attributes that cannot be used on the same declaration 1592 bool AttrsVisitor::HaveAttrConflict(Attr attrName, Attr attr1, Attr attr2) { 1593 if ((attrName == attr1 && attrs_->test(attr2)) || 1594 (attrName == attr2 && attrs_->test(attr1))) { 1595 Say(currStmtSource().value(), 1596 "Attributes '%s' and '%s' conflict with each other"_err_en_US, 1597 AttrToString(attr1), AttrToString(attr2)); 1598 return true; 1599 } 1600 return false; 1601 } 1602 // C759, C1543 1603 bool AttrsVisitor::IsConflictingAttr(Attr attrName) { 1604 return HaveAttrConflict(attrName, Attr::INTENT_IN, Attr::INTENT_INOUT) || 1605 HaveAttrConflict(attrName, Attr::INTENT_IN, Attr::INTENT_OUT) || 1606 HaveAttrConflict(attrName, Attr::INTENT_INOUT, Attr::INTENT_OUT) || 1607 HaveAttrConflict(attrName, Attr::PASS, Attr::NOPASS) || // C781 1608 HaveAttrConflict(attrName, Attr::PURE, Attr::IMPURE) || 1609 HaveAttrConflict(attrName, Attr::PUBLIC, Attr::PRIVATE) || 1610 HaveAttrConflict(attrName, Attr::RECURSIVE, Attr::NON_RECURSIVE); 1611 } 1612 bool AttrsVisitor::CheckAndSet(Attr attrName) { 1613 CHECK(attrs_); 1614 if (IsConflictingAttr(attrName) || IsDuplicateAttr(attrName)) { 1615 return false; 1616 } 1617 attrs_->set(attrName); 1618 return true; 1619 } 1620 1621 // DeclTypeSpecVisitor implementation 1622 1623 const DeclTypeSpec *DeclTypeSpecVisitor::GetDeclTypeSpec() { 1624 return state_.declTypeSpec; 1625 } 1626 1627 void DeclTypeSpecVisitor::BeginDeclTypeSpec() { 1628 CHECK(!state_.expectDeclTypeSpec); 1629 CHECK(!state_.declTypeSpec); 1630 state_.expectDeclTypeSpec = true; 1631 } 1632 void DeclTypeSpecVisitor::EndDeclTypeSpec() { 1633 CHECK(state_.expectDeclTypeSpec); 1634 state_ = {}; 1635 } 1636 1637 void DeclTypeSpecVisitor::SetDeclTypeSpecCategory( 1638 DeclTypeSpec::Category category) { 1639 CHECK(state_.expectDeclTypeSpec); 1640 state_.derived.category = category; 1641 } 1642 1643 bool DeclTypeSpecVisitor::Pre(const parser::TypeGuardStmt &) { 1644 BeginDeclTypeSpec(); 1645 return true; 1646 } 1647 void DeclTypeSpecVisitor::Post(const parser::TypeGuardStmt &) { 1648 EndDeclTypeSpec(); 1649 } 1650 1651 void DeclTypeSpecVisitor::Post(const parser::TypeSpec &typeSpec) { 1652 // Record the resolved DeclTypeSpec in the parse tree for use by 1653 // expression semantics if the DeclTypeSpec is a valid TypeSpec. 1654 // The grammar ensures that it's an intrinsic or derived type spec, 1655 // not TYPE(*) or CLASS(*) or CLASS(T). 1656 if (const DeclTypeSpec * spec{state_.declTypeSpec}) { 1657 switch (spec->category()) { 1658 case DeclTypeSpec::Numeric: 1659 case DeclTypeSpec::Logical: 1660 case DeclTypeSpec::Character: 1661 typeSpec.declTypeSpec = spec; 1662 break; 1663 case DeclTypeSpec::TypeDerived: 1664 if (const DerivedTypeSpec * derived{spec->AsDerived()}) { 1665 CheckForAbstractType(derived->typeSymbol()); // C703 1666 typeSpec.declTypeSpec = spec; 1667 } 1668 break; 1669 default: 1670 CRASH_NO_CASE; 1671 } 1672 } 1673 } 1674 1675 void DeclTypeSpecVisitor::Post( 1676 const parser::IntrinsicTypeSpec::DoublePrecision &) { 1677 MakeNumericType(TypeCategory::Real, context().doublePrecisionKind()); 1678 } 1679 void DeclTypeSpecVisitor::Post( 1680 const parser::IntrinsicTypeSpec::DoubleComplex &) { 1681 MakeNumericType(TypeCategory::Complex, context().doublePrecisionKind()); 1682 } 1683 void DeclTypeSpecVisitor::MakeNumericType(TypeCategory category, int kind) { 1684 SetDeclTypeSpec(context().MakeNumericType(category, kind)); 1685 } 1686 1687 void DeclTypeSpecVisitor::CheckForAbstractType(const Symbol &typeSymbol) { 1688 if (typeSymbol.attrs().test(Attr::ABSTRACT)) { 1689 Say("ABSTRACT derived type may not be used here"_err_en_US); 1690 } 1691 } 1692 1693 void DeclTypeSpecVisitor::Post(const parser::DeclarationTypeSpec::ClassStar &) { 1694 SetDeclTypeSpec(context().globalScope().MakeClassStarType()); 1695 } 1696 void DeclTypeSpecVisitor::Post(const parser::DeclarationTypeSpec::TypeStar &) { 1697 SetDeclTypeSpec(context().globalScope().MakeTypeStarType()); 1698 } 1699 1700 // Check that we're expecting to see a DeclTypeSpec (and haven't seen one yet) 1701 // and save it in state_.declTypeSpec. 1702 void DeclTypeSpecVisitor::SetDeclTypeSpec(const DeclTypeSpec &declTypeSpec) { 1703 CHECK(state_.expectDeclTypeSpec); 1704 CHECK(!state_.declTypeSpec); 1705 state_.declTypeSpec = &declTypeSpec; 1706 } 1707 1708 KindExpr DeclTypeSpecVisitor::GetKindParamExpr( 1709 TypeCategory category, const std::optional<parser::KindSelector> &kind) { 1710 return AnalyzeKindSelector(context(), category, kind); 1711 } 1712 1713 // MessageHandler implementation 1714 1715 Message &MessageHandler::Say(MessageFixedText &&msg) { 1716 return context_->Say(currStmtSource().value(), std::move(msg)); 1717 } 1718 Message &MessageHandler::Say(MessageFormattedText &&msg) { 1719 return context_->Say(currStmtSource().value(), std::move(msg)); 1720 } 1721 Message &MessageHandler::Say(const SourceName &name, MessageFixedText &&msg) { 1722 return Say(name, std::move(msg), name); 1723 } 1724 1725 // ImplicitRulesVisitor implementation 1726 1727 void ImplicitRulesVisitor::Post(const parser::ParameterStmt &) { 1728 prevParameterStmt_ = currStmtSource(); 1729 } 1730 1731 bool ImplicitRulesVisitor::Pre(const parser::ImplicitStmt &x) { 1732 bool result{ 1733 std::visit(common::visitors{ 1734 [&](const std::list<ImplicitNoneNameSpec> &y) { 1735 return HandleImplicitNone(y); 1736 }, 1737 [&](const std::list<parser::ImplicitSpec> &) { 1738 if (prevImplicitNoneType_) { 1739 Say("IMPLICIT statement after IMPLICIT NONE or " 1740 "IMPLICIT NONE(TYPE) statement"_err_en_US); 1741 return false; 1742 } 1743 implicitRules_->set_isImplicitNoneType(false); 1744 return true; 1745 }, 1746 }, 1747 x.u)}; 1748 prevImplicit_ = currStmtSource(); 1749 return result; 1750 } 1751 1752 bool ImplicitRulesVisitor::Pre(const parser::LetterSpec &x) { 1753 auto loLoc{std::get<parser::Location>(x.t)}; 1754 auto hiLoc{loLoc}; 1755 if (auto hiLocOpt{std::get<std::optional<parser::Location>>(x.t)}) { 1756 hiLoc = *hiLocOpt; 1757 if (*hiLoc < *loLoc) { 1758 Say(hiLoc, "'%s' does not follow '%s' alphabetically"_err_en_US, 1759 std::string(hiLoc, 1), std::string(loLoc, 1)); 1760 return false; 1761 } 1762 } 1763 implicitRules_->SetTypeMapping(*GetDeclTypeSpec(), loLoc, hiLoc); 1764 return false; 1765 } 1766 1767 bool ImplicitRulesVisitor::Pre(const parser::ImplicitSpec &) { 1768 BeginDeclTypeSpec(); 1769 set_allowForwardReferenceToDerivedType(true); 1770 return true; 1771 } 1772 1773 void ImplicitRulesVisitor::Post(const parser::ImplicitSpec &) { 1774 EndDeclTypeSpec(); 1775 } 1776 1777 void ImplicitRulesVisitor::SetScope(const Scope &scope) { 1778 implicitRules_ = &DEREF(implicitRulesMap_).at(&scope); 1779 prevImplicit_ = std::nullopt; 1780 prevImplicitNone_ = std::nullopt; 1781 prevImplicitNoneType_ = std::nullopt; 1782 prevParameterStmt_ = std::nullopt; 1783 } 1784 void ImplicitRulesVisitor::BeginScope(const Scope &scope) { 1785 // find or create implicit rules for this scope 1786 DEREF(implicitRulesMap_).try_emplace(&scope, context(), implicitRules_); 1787 SetScope(scope); 1788 } 1789 1790 // TODO: for all of these errors, reference previous statement too 1791 bool ImplicitRulesVisitor::HandleImplicitNone( 1792 const std::list<ImplicitNoneNameSpec> &nameSpecs) { 1793 if (prevImplicitNone_) { 1794 Say("More than one IMPLICIT NONE statement"_err_en_US); 1795 Say(*prevImplicitNone_, "Previous IMPLICIT NONE statement"_en_US); 1796 return false; 1797 } 1798 if (prevParameterStmt_) { 1799 Say("IMPLICIT NONE statement after PARAMETER statement"_err_en_US); 1800 return false; 1801 } 1802 prevImplicitNone_ = currStmtSource(); 1803 bool implicitNoneTypeNever{ 1804 context().IsEnabled(common::LanguageFeature::ImplicitNoneTypeNever)}; 1805 if (nameSpecs.empty()) { 1806 if (!implicitNoneTypeNever) { 1807 prevImplicitNoneType_ = currStmtSource(); 1808 implicitRules_->set_isImplicitNoneType(true); 1809 if (prevImplicit_) { 1810 Say("IMPLICIT NONE statement after IMPLICIT statement"_err_en_US); 1811 return false; 1812 } 1813 } 1814 } else { 1815 int sawType{0}; 1816 int sawExternal{0}; 1817 for (const auto noneSpec : nameSpecs) { 1818 switch (noneSpec) { 1819 case ImplicitNoneNameSpec::External: 1820 implicitRules_->set_isImplicitNoneExternal(true); 1821 ++sawExternal; 1822 break; 1823 case ImplicitNoneNameSpec::Type: 1824 if (!implicitNoneTypeNever) { 1825 prevImplicitNoneType_ = currStmtSource(); 1826 implicitRules_->set_isImplicitNoneType(true); 1827 if (prevImplicit_) { 1828 Say("IMPLICIT NONE(TYPE) after IMPLICIT statement"_err_en_US); 1829 return false; 1830 } 1831 ++sawType; 1832 } 1833 break; 1834 } 1835 } 1836 if (sawType > 1) { 1837 Say("TYPE specified more than once in IMPLICIT NONE statement"_err_en_US); 1838 return false; 1839 } 1840 if (sawExternal > 1) { 1841 Say("EXTERNAL specified more than once in IMPLICIT NONE statement"_err_en_US); 1842 return false; 1843 } 1844 } 1845 return true; 1846 } 1847 1848 // ArraySpecVisitor implementation 1849 1850 void ArraySpecVisitor::Post(const parser::ArraySpec &x) { 1851 CHECK(arraySpec_.empty()); 1852 arraySpec_ = AnalyzeArraySpec(context(), x); 1853 } 1854 void ArraySpecVisitor::Post(const parser::ComponentArraySpec &x) { 1855 CHECK(arraySpec_.empty()); 1856 arraySpec_ = AnalyzeArraySpec(context(), x); 1857 } 1858 void ArraySpecVisitor::Post(const parser::CoarraySpec &x) { 1859 CHECK(coarraySpec_.empty()); 1860 coarraySpec_ = AnalyzeCoarraySpec(context(), x); 1861 } 1862 1863 const ArraySpec &ArraySpecVisitor::arraySpec() { 1864 return !arraySpec_.empty() ? arraySpec_ : attrArraySpec_; 1865 } 1866 const ArraySpec &ArraySpecVisitor::coarraySpec() { 1867 return !coarraySpec_.empty() ? coarraySpec_ : attrCoarraySpec_; 1868 } 1869 void ArraySpecVisitor::BeginArraySpec() { 1870 CHECK(arraySpec_.empty()); 1871 CHECK(coarraySpec_.empty()); 1872 CHECK(attrArraySpec_.empty()); 1873 CHECK(attrCoarraySpec_.empty()); 1874 } 1875 void ArraySpecVisitor::EndArraySpec() { 1876 CHECK(arraySpec_.empty()); 1877 CHECK(coarraySpec_.empty()); 1878 attrArraySpec_.clear(); 1879 attrCoarraySpec_.clear(); 1880 } 1881 void ArraySpecVisitor::PostAttrSpec() { 1882 // Save dimension/codimension from attrs so we can process array/coarray-spec 1883 // on the entity-decl 1884 if (!arraySpec_.empty()) { 1885 if (attrArraySpec_.empty()) { 1886 attrArraySpec_ = arraySpec_; 1887 arraySpec_.clear(); 1888 } else { 1889 Say(currStmtSource().value(), 1890 "Attribute 'DIMENSION' cannot be used more than once"_err_en_US); 1891 } 1892 } 1893 if (!coarraySpec_.empty()) { 1894 if (attrCoarraySpec_.empty()) { 1895 attrCoarraySpec_ = coarraySpec_; 1896 coarraySpec_.clear(); 1897 } else { 1898 Say(currStmtSource().value(), 1899 "Attribute 'CODIMENSION' cannot be used more than once"_err_en_US); 1900 } 1901 } 1902 } 1903 1904 // ScopeHandler implementation 1905 1906 void ScopeHandler::SayAlreadyDeclared(const parser::Name &name, Symbol &prev) { 1907 SayAlreadyDeclared(name.source, prev); 1908 } 1909 void ScopeHandler::SayAlreadyDeclared(const SourceName &name, Symbol &prev) { 1910 if (context().HasError(prev)) { 1911 // don't report another error about prev 1912 } else { 1913 if (const auto *details{prev.detailsIf<UseDetails>()}) { 1914 Say(name, "'%s' is already declared in this scoping unit"_err_en_US) 1915 .Attach(details->location(), 1916 "It is use-associated with '%s' in module '%s'"_err_en_US, 1917 details->symbol().name(), GetUsedModule(*details).name()); 1918 } else { 1919 SayAlreadyDeclared(name, prev.name()); 1920 } 1921 context().SetError(prev); 1922 } 1923 } 1924 void ScopeHandler::SayAlreadyDeclared( 1925 const SourceName &name1, const SourceName &name2) { 1926 if (name1.begin() < name2.begin()) { 1927 SayAlreadyDeclared(name2, name1); 1928 } else { 1929 Say(name1, "'%s' is already declared in this scoping unit"_err_en_US) 1930 .Attach(name2, "Previous declaration of '%s'"_en_US, name2); 1931 } 1932 } 1933 1934 void ScopeHandler::SayWithReason(const parser::Name &name, Symbol &symbol, 1935 MessageFixedText &&msg1, MessageFixedText &&msg2) { 1936 Say2(name, std::move(msg1), symbol, std::move(msg2)); 1937 context().SetError(symbol, msg1.isFatal()); 1938 } 1939 1940 void ScopeHandler::SayWithDecl( 1941 const parser::Name &name, Symbol &symbol, MessageFixedText &&msg) { 1942 SayWithReason(name, symbol, std::move(msg), 1943 symbol.test(Symbol::Flag::Implicit) ? "Implicit declaration of '%s'"_en_US 1944 : "Declaration of '%s'"_en_US); 1945 } 1946 1947 void ScopeHandler::SayLocalMustBeVariable( 1948 const parser::Name &name, Symbol &symbol) { 1949 SayWithDecl(name, symbol, 1950 "The name '%s' must be a variable to appear" 1951 " in a locality-spec"_err_en_US); 1952 } 1953 1954 void ScopeHandler::SayDerivedType( 1955 const SourceName &name, MessageFixedText &&msg, const Scope &type) { 1956 const Symbol &typeSymbol{DEREF(type.GetSymbol())}; 1957 Say(name, std::move(msg), name, typeSymbol.name()) 1958 .Attach(typeSymbol.name(), "Declaration of derived type '%s'"_en_US, 1959 typeSymbol.name()); 1960 } 1961 void ScopeHandler::Say2(const SourceName &name1, MessageFixedText &&msg1, 1962 const SourceName &name2, MessageFixedText &&msg2) { 1963 Say(name1, std::move(msg1)).Attach(name2, std::move(msg2), name2); 1964 } 1965 void ScopeHandler::Say2(const SourceName &name, MessageFixedText &&msg1, 1966 Symbol &symbol, MessageFixedText &&msg2) { 1967 Say2(name, std::move(msg1), symbol.name(), std::move(msg2)); 1968 context().SetError(symbol, msg1.isFatal()); 1969 } 1970 void ScopeHandler::Say2(const parser::Name &name, MessageFixedText &&msg1, 1971 Symbol &symbol, MessageFixedText &&msg2) { 1972 Say2(name.source, std::move(msg1), symbol.name(), std::move(msg2)); 1973 context().SetError(symbol, msg1.isFatal()); 1974 } 1975 1976 // T may be `Scope` or `const Scope` 1977 template <typename T> static T &GetInclusiveScope(T &scope) { 1978 for (T *s{&scope}; !s->IsGlobal(); s = &s->parent()) { 1979 if (s->kind() != Scope::Kind::Block && !s->IsDerivedType() && 1980 !s->IsStmtFunction()) { 1981 return *s; 1982 } 1983 } 1984 return scope; 1985 } 1986 1987 Scope &ScopeHandler::InclusiveScope() { return GetInclusiveScope(currScope()); } 1988 1989 Scope *ScopeHandler::GetHostProcedure() { 1990 Scope &parent{InclusiveScope().parent()}; 1991 return parent.kind() == Scope::Kind::Subprogram ? &parent : nullptr; 1992 } 1993 1994 Scope &ScopeHandler::NonDerivedTypeScope() { 1995 return currScope_->IsDerivedType() ? currScope_->parent() : *currScope_; 1996 } 1997 1998 void ScopeHandler::PushScope(Scope::Kind kind, Symbol *symbol) { 1999 PushScope(currScope().MakeScope(kind, symbol)); 2000 } 2001 void ScopeHandler::PushScope(Scope &scope) { 2002 currScope_ = &scope; 2003 auto kind{currScope_->kind()}; 2004 if (kind != Scope::Kind::Block) { 2005 BeginScope(scope); 2006 } 2007 // The name of a module or submodule cannot be "used" in its scope, 2008 // as we read 19.3.1(2), so we allow the name to be used as a local 2009 // identifier in the module or submodule too. Same with programs 2010 // (14.1(3)) and BLOCK DATA. 2011 if (!currScope_->IsDerivedType() && kind != Scope::Kind::Module && 2012 kind != Scope::Kind::MainProgram && kind != Scope::Kind::BlockData) { 2013 if (auto *symbol{scope.symbol()}) { 2014 // Create a dummy symbol so we can't create another one with the same 2015 // name. It might already be there if we previously pushed the scope. 2016 if (!FindInScope(scope, symbol->name())) { 2017 auto &newSymbol{MakeSymbol(symbol->name())}; 2018 if (kind == Scope::Kind::Subprogram) { 2019 // Allow for recursive references. If this symbol is a function 2020 // without an explicit RESULT(), this new symbol will be discarded 2021 // and replaced with an object of the same name. 2022 newSymbol.set_details(HostAssocDetails{*symbol}); 2023 } else { 2024 newSymbol.set_details(MiscDetails{MiscDetails::Kind::ScopeName}); 2025 } 2026 } 2027 } 2028 } 2029 } 2030 void ScopeHandler::PopScope() { 2031 // Entities that are not yet classified as objects or procedures are now 2032 // assumed to be objects. 2033 // TODO: Statement functions 2034 for (auto &pair : currScope()) { 2035 ConvertToObjectEntity(*pair.second); 2036 } 2037 SetScope(currScope_->parent()); 2038 } 2039 void ScopeHandler::SetScope(Scope &scope) { 2040 currScope_ = &scope; 2041 ImplicitRulesVisitor::SetScope(InclusiveScope()); 2042 } 2043 2044 Symbol *ScopeHandler::FindSymbol(const parser::Name &name) { 2045 return FindSymbol(currScope(), name); 2046 } 2047 Symbol *ScopeHandler::FindSymbol(const Scope &scope, const parser::Name &name) { 2048 if (scope.IsDerivedType()) { 2049 if (Symbol * symbol{scope.FindComponent(name.source)}) { 2050 if (!symbol->has<ProcBindingDetails>() && 2051 !symbol->test(Symbol::Flag::ParentComp)) { 2052 return Resolve(name, symbol); 2053 } 2054 } 2055 return FindSymbol(scope.parent(), name); 2056 } else { 2057 // In EQUIVALENCE statements only resolve names in the local scope, see 2058 // 19.5.1.4, paragraph 2, item (10) 2059 return Resolve(name, 2060 inEquivalenceStmt_ ? FindInScope(scope, name) 2061 : scope.FindSymbol(name.source)); 2062 } 2063 } 2064 2065 Symbol &ScopeHandler::MakeSymbol( 2066 Scope &scope, const SourceName &name, Attrs attrs) { 2067 if (Symbol * symbol{FindInScope(scope, name)}) { 2068 symbol->attrs() |= attrs; 2069 return *symbol; 2070 } else { 2071 const auto pair{scope.try_emplace(name, attrs, UnknownDetails{})}; 2072 CHECK(pair.second); // name was not found, so must be able to add 2073 return *pair.first->second; 2074 } 2075 } 2076 Symbol &ScopeHandler::MakeSymbol(const SourceName &name, Attrs attrs) { 2077 return MakeSymbol(currScope(), name, attrs); 2078 } 2079 Symbol &ScopeHandler::MakeSymbol(const parser::Name &name, Attrs attrs) { 2080 return Resolve(name, MakeSymbol(name.source, attrs)); 2081 } 2082 Symbol &ScopeHandler::MakeHostAssocSymbol( 2083 const parser::Name &name, const Symbol &hostSymbol) { 2084 Symbol &symbol{*NonDerivedTypeScope() 2085 .try_emplace(name.source, HostAssocDetails{hostSymbol}) 2086 .first->second}; 2087 name.symbol = &symbol; 2088 symbol.attrs() = hostSymbol.attrs(); // TODO: except PRIVATE, PUBLIC? 2089 symbol.flags() = hostSymbol.flags(); 2090 return symbol; 2091 } 2092 Symbol &ScopeHandler::CopySymbol(const SourceName &name, const Symbol &symbol) { 2093 CHECK(!FindInScope(name)); 2094 return MakeSymbol(currScope(), name, symbol.attrs()); 2095 } 2096 2097 // Look for name only in scope, not in enclosing scopes. 2098 Symbol *ScopeHandler::FindInScope( 2099 const Scope &scope, const parser::Name &name) { 2100 return Resolve(name, FindInScope(scope, name.source)); 2101 } 2102 Symbol *ScopeHandler::FindInScope(const Scope &scope, const SourceName &name) { 2103 // all variants of names, e.g. "operator(.ne.)" for "operator(/=)" 2104 for (const std::string &n : GetAllNames(context(), name)) { 2105 auto it{scope.find(SourceName{n})}; 2106 if (it != scope.end()) { 2107 return &*it->second; 2108 } 2109 } 2110 return nullptr; 2111 } 2112 2113 // Find a component or type parameter by name in a derived type or its parents. 2114 Symbol *ScopeHandler::FindInTypeOrParents( 2115 const Scope &scope, const parser::Name &name) { 2116 return Resolve(name, scope.FindComponent(name.source)); 2117 } 2118 Symbol *ScopeHandler::FindInTypeOrParents(const parser::Name &name) { 2119 return FindInTypeOrParents(currScope(), name); 2120 } 2121 2122 void ScopeHandler::EraseSymbol(const parser::Name &name) { 2123 currScope().erase(name.source); 2124 name.symbol = nullptr; 2125 } 2126 2127 static bool NeedsType(const Symbol &symbol) { 2128 return !symbol.GetType() && 2129 std::visit(common::visitors{ 2130 [](const EntityDetails &) { return true; }, 2131 [](const ObjectEntityDetails &) { return true; }, 2132 [](const AssocEntityDetails &) { return true; }, 2133 [&](const ProcEntityDetails &p) { 2134 return symbol.test(Symbol::Flag::Function) && 2135 !symbol.attrs().test(Attr::INTRINSIC) && 2136 !p.interface().type() && !p.interface().symbol(); 2137 }, 2138 [](const auto &) { return false; }, 2139 }, 2140 symbol.details()); 2141 } 2142 2143 void ScopeHandler::ApplyImplicitRules( 2144 Symbol &symbol, bool allowForwardReference) { 2145 if (context().HasError(symbol) || !NeedsType(symbol)) { 2146 return; 2147 } 2148 if (const DeclTypeSpec * type{GetImplicitType(symbol)}) { 2149 symbol.set(Symbol::Flag::Implicit); 2150 symbol.SetType(*type); 2151 return; 2152 } 2153 if (symbol.has<ProcEntityDetails>() && !symbol.attrs().test(Attr::EXTERNAL)) { 2154 std::optional<Symbol::Flag> functionOrSubroutineFlag; 2155 if (symbol.test(Symbol::Flag::Function)) { 2156 functionOrSubroutineFlag = Symbol::Flag::Function; 2157 } else if (symbol.test(Symbol::Flag::Subroutine)) { 2158 functionOrSubroutineFlag = Symbol::Flag::Subroutine; 2159 } 2160 if (IsIntrinsic(symbol.name(), functionOrSubroutineFlag)) { 2161 // type will be determined in expression semantics 2162 AcquireIntrinsicProcedureFlags(symbol); 2163 return; 2164 } 2165 } 2166 if (allowForwardReference && ImplicitlyTypeForwardRef(symbol)) { 2167 return; 2168 } 2169 if (!context().HasError(symbol)) { 2170 Say(symbol.name(), "No explicit type declared for '%s'"_err_en_US); 2171 context().SetError(symbol); 2172 } 2173 } 2174 2175 // Extension: Allow forward references to scalar integer dummy arguments 2176 // to appear in specification expressions under IMPLICIT NONE(TYPE) when 2177 // what would otherwise have been their implicit type is default INTEGER. 2178 bool ScopeHandler::ImplicitlyTypeForwardRef(Symbol &symbol) { 2179 if (!inSpecificationPart_ || context().HasError(symbol) || !IsDummy(symbol) || 2180 symbol.Rank() != 0 || 2181 !context().languageFeatures().IsEnabled( 2182 common::LanguageFeature::ForwardRefDummyImplicitNone)) { 2183 return false; 2184 } 2185 const DeclTypeSpec *type{ 2186 GetImplicitType(symbol, false /*ignore IMPLICIT NONE*/)}; 2187 if (!type || !type->IsNumeric(TypeCategory::Integer)) { 2188 return false; 2189 } 2190 auto kind{evaluate::ToInt64(type->numericTypeSpec().kind())}; 2191 if (!kind || *kind != context().GetDefaultKind(TypeCategory::Integer)) { 2192 return false; 2193 } 2194 if (!ConvertToObjectEntity(symbol)) { 2195 return false; 2196 } 2197 // TODO: check no INTENT(OUT)? 2198 if (context().languageFeatures().ShouldWarn( 2199 common::LanguageFeature::ForwardRefDummyImplicitNone)) { 2200 Say(symbol.name(), 2201 "Dummy argument '%s' was used without being explicitly typed"_en_US, 2202 symbol.name()); 2203 } 2204 symbol.set(Symbol::Flag::Implicit); 2205 symbol.SetType(*type); 2206 return true; 2207 } 2208 2209 // Ensure that the symbol for an intrinsic procedure is marked with 2210 // the INTRINSIC attribute. Also set PURE &/or ELEMENTAL as 2211 // appropriate. 2212 void ScopeHandler::AcquireIntrinsicProcedureFlags(Symbol &symbol) { 2213 symbol.attrs().set(Attr::INTRINSIC); 2214 switch (context().intrinsics().GetIntrinsicClass(symbol.name().ToString())) { 2215 case evaluate::IntrinsicClass::elementalFunction: 2216 case evaluate::IntrinsicClass::elementalSubroutine: 2217 symbol.attrs().set(Attr::ELEMENTAL); 2218 symbol.attrs().set(Attr::PURE); 2219 break; 2220 case evaluate::IntrinsicClass::impureSubroutine: 2221 break; 2222 default: 2223 symbol.attrs().set(Attr::PURE); 2224 } 2225 } 2226 2227 const DeclTypeSpec *ScopeHandler::GetImplicitType( 2228 Symbol &symbol, bool respectImplicitNoneType) { 2229 const Scope *scope{&symbol.owner()}; 2230 if (scope->IsGlobal()) { 2231 scope = &currScope(); 2232 } 2233 scope = &GetInclusiveScope(*scope); 2234 const auto *type{implicitRulesMap_->at(scope).GetType( 2235 symbol.name(), respectImplicitNoneType)}; 2236 if (type) { 2237 if (const DerivedTypeSpec * derived{type->AsDerived()}) { 2238 // Resolve any forward-referenced derived type; a quick no-op else. 2239 auto &instantiatable{*const_cast<DerivedTypeSpec *>(derived)}; 2240 instantiatable.Instantiate(currScope(), context()); 2241 } 2242 } 2243 return type; 2244 } 2245 2246 // Convert symbol to be a ObjectEntity or return false if it can't be. 2247 bool ScopeHandler::ConvertToObjectEntity(Symbol &symbol) { 2248 if (symbol.has<ObjectEntityDetails>()) { 2249 // nothing to do 2250 } else if (symbol.has<UnknownDetails>()) { 2251 symbol.set_details(ObjectEntityDetails{}); 2252 } else if (auto *details{symbol.detailsIf<EntityDetails>()}) { 2253 symbol.set_details(ObjectEntityDetails{std::move(*details)}); 2254 } else if (auto *useDetails{symbol.detailsIf<UseDetails>()}) { 2255 return useDetails->symbol().has<ObjectEntityDetails>(); 2256 } else { 2257 return false; 2258 } 2259 return true; 2260 } 2261 // Convert symbol to be a ProcEntity or return false if it can't be. 2262 bool ScopeHandler::ConvertToProcEntity(Symbol &symbol) { 2263 if (symbol.has<ProcEntityDetails>()) { 2264 // nothing to do 2265 } else if (symbol.has<UnknownDetails>()) { 2266 symbol.set_details(ProcEntityDetails{}); 2267 } else if (auto *details{symbol.detailsIf<EntityDetails>()}) { 2268 symbol.set_details(ProcEntityDetails{std::move(*details)}); 2269 if (symbol.GetType() && !symbol.test(Symbol::Flag::Implicit)) { 2270 CHECK(!symbol.test(Symbol::Flag::Subroutine)); 2271 symbol.set(Symbol::Flag::Function); 2272 } 2273 } else { 2274 return false; 2275 } 2276 return true; 2277 } 2278 2279 const DeclTypeSpec &ScopeHandler::MakeNumericType( 2280 TypeCategory category, const std::optional<parser::KindSelector> &kind) { 2281 KindExpr value{GetKindParamExpr(category, kind)}; 2282 if (auto known{evaluate::ToInt64(value)}) { 2283 return context().MakeNumericType(category, static_cast<int>(*known)); 2284 } else { 2285 return currScope_->MakeNumericType(category, std::move(value)); 2286 } 2287 } 2288 2289 const DeclTypeSpec &ScopeHandler::MakeLogicalType( 2290 const std::optional<parser::KindSelector> &kind) { 2291 KindExpr value{GetKindParamExpr(TypeCategory::Logical, kind)}; 2292 if (auto known{evaluate::ToInt64(value)}) { 2293 return context().MakeLogicalType(static_cast<int>(*known)); 2294 } else { 2295 return currScope_->MakeLogicalType(std::move(value)); 2296 } 2297 } 2298 2299 void ScopeHandler::NotePossibleBadForwardRef(const parser::Name &name) { 2300 if (inSpecificationPart_ && name.symbol) { 2301 auto kind{currScope().kind()}; 2302 if ((kind == Scope::Kind::Subprogram && !currScope().IsStmtFunction()) || 2303 kind == Scope::Kind::Block) { 2304 bool isHostAssociated{&name.symbol->owner() == &currScope() 2305 ? name.symbol->has<HostAssocDetails>() 2306 : name.symbol->owner().Contains(currScope())}; 2307 if (isHostAssociated) { 2308 specPartState_.forwardRefs.insert(name.source); 2309 } 2310 } 2311 } 2312 } 2313 2314 std::optional<SourceName> ScopeHandler::HadForwardRef( 2315 const Symbol &symbol) const { 2316 auto iter{specPartState_.forwardRefs.find(symbol.name())}; 2317 if (iter != specPartState_.forwardRefs.end()) { 2318 return *iter; 2319 } 2320 return std::nullopt; 2321 } 2322 2323 bool ScopeHandler::CheckPossibleBadForwardRef(const Symbol &symbol) { 2324 if (!context().HasError(symbol)) { 2325 if (auto fwdRef{HadForwardRef(symbol)}) { 2326 const Symbol *outer{symbol.owner().FindSymbol(symbol.name())}; 2327 if (outer && symbol.has<UseDetails>() && 2328 &symbol.GetUltimate() == &outer->GetUltimate()) { 2329 // e.g. IMPORT of host's USE association 2330 return false; 2331 } 2332 Say(*fwdRef, 2333 "Forward reference to '%s' is not allowed in the same specification part"_err_en_US, 2334 *fwdRef) 2335 .Attach(symbol.name(), "Later declaration of '%s'"_en_US, *fwdRef); 2336 context().SetError(symbol); 2337 return true; 2338 } 2339 if (IsDummy(symbol) && isImplicitNoneType() && 2340 symbol.test(Symbol::Flag::Implicit) && !context().HasError(symbol)) { 2341 // Dummy was implicitly typed despite IMPLICIT NONE(TYPE) in 2342 // ApplyImplicitRules() due to use in a specification expression, 2343 // and no explicit type declaration appeared later. 2344 Say(symbol.name(), 2345 "No explicit type declared for dummy argument '%s'"_err_en_US); 2346 context().SetError(symbol); 2347 return true; 2348 } 2349 } 2350 return false; 2351 } 2352 2353 void ScopeHandler::MakeExternal(Symbol &symbol) { 2354 if (!symbol.attrs().test(Attr::EXTERNAL)) { 2355 symbol.attrs().set(Attr::EXTERNAL); 2356 if (symbol.attrs().test(Attr::INTRINSIC)) { // C840 2357 Say(symbol.name(), 2358 "Symbol '%s' cannot have both EXTERNAL and INTRINSIC attributes"_err_en_US, 2359 symbol.name()); 2360 } 2361 } 2362 } 2363 2364 // ModuleVisitor implementation 2365 2366 bool ModuleVisitor::Pre(const parser::Only &x) { 2367 std::visit(common::visitors{ 2368 [&](const Indirection<parser::GenericSpec> &generic) { 2369 AddUse(GenericSpecInfo{generic.value()}); 2370 }, 2371 [&](const parser::Name &name) { 2372 Resolve(name, AddUse(name.source, name.source).use); 2373 }, 2374 [&](const parser::Rename &rename) { Walk(rename); }, 2375 }, 2376 x.u); 2377 return false; 2378 } 2379 2380 bool ModuleVisitor::Pre(const parser::Rename::Names &x) { 2381 const auto &localName{std::get<0>(x.t)}; 2382 const auto &useName{std::get<1>(x.t)}; 2383 SymbolRename rename{AddUse(localName.source, useName.source)}; 2384 Resolve(useName, rename.use); 2385 Resolve(localName, rename.local); 2386 return false; 2387 } 2388 bool ModuleVisitor::Pre(const parser::Rename::Operators &x) { 2389 const parser::DefinedOpName &local{std::get<0>(x.t)}; 2390 const parser::DefinedOpName &use{std::get<1>(x.t)}; 2391 GenericSpecInfo localInfo{local}; 2392 GenericSpecInfo useInfo{use}; 2393 if (IsIntrinsicOperator(context(), local.v.source)) { 2394 Say(local.v, 2395 "Intrinsic operator '%s' may not be used as a defined operator"_err_en_US); 2396 } else if (IsLogicalConstant(context(), local.v.source)) { 2397 Say(local.v, 2398 "Logical constant '%s' may not be used as a defined operator"_err_en_US); 2399 } else { 2400 SymbolRename rename{AddUse(localInfo.symbolName(), useInfo.symbolName())}; 2401 useInfo.Resolve(rename.use); 2402 localInfo.Resolve(rename.local); 2403 } 2404 return false; 2405 } 2406 2407 // Set useModuleScope_ to the Scope of the module being used. 2408 bool ModuleVisitor::Pre(const parser::UseStmt &x) { 2409 useModuleScope_ = FindModule(x.moduleName); 2410 if (!useModuleScope_) { 2411 return false; 2412 } 2413 // use the name from this source file 2414 useModuleScope_->symbol()->ReplaceName(x.moduleName.source); 2415 return true; 2416 } 2417 2418 void ModuleVisitor::Post(const parser::UseStmt &x) { 2419 if (const auto *list{std::get_if<std::list<parser::Rename>>(&x.u)}) { 2420 // Not a use-only: collect the names that were used in renames, 2421 // then add a use for each public name that was not renamed. 2422 std::set<SourceName> useNames; 2423 for (const auto &rename : *list) { 2424 std::visit(common::visitors{ 2425 [&](const parser::Rename::Names &names) { 2426 useNames.insert(std::get<1>(names.t).source); 2427 }, 2428 [&](const parser::Rename::Operators &ops) { 2429 useNames.insert(std::get<1>(ops.t).v.source); 2430 }, 2431 }, 2432 rename.u); 2433 } 2434 for (const auto &[name, symbol] : *useModuleScope_) { 2435 if (symbol->attrs().test(Attr::PUBLIC) && 2436 (!symbol->attrs().test(Attr::INTRINSIC) || 2437 symbol->has<UseDetails>()) && 2438 !symbol->has<MiscDetails>() && useNames.count(name) == 0) { 2439 SourceName location{x.moduleName.source}; 2440 if (auto *localSymbol{FindInScope(name)}) { 2441 DoAddUse(location, localSymbol->name(), *localSymbol, *symbol); 2442 } else { 2443 DoAddUse(location, location, CopySymbol(name, *symbol), *symbol); 2444 } 2445 } 2446 } 2447 } 2448 useModuleScope_ = nullptr; 2449 } 2450 2451 ModuleVisitor::SymbolRename ModuleVisitor::AddUse( 2452 const SourceName &localName, const SourceName &useName) { 2453 return AddUse(localName, useName, FindInScope(*useModuleScope_, useName)); 2454 } 2455 2456 ModuleVisitor::SymbolRename ModuleVisitor::AddUse( 2457 const SourceName &localName, const SourceName &useName, Symbol *useSymbol) { 2458 if (!useModuleScope_) { 2459 return {}; // error occurred finding module 2460 } 2461 if (!useSymbol) { 2462 Say(useName, "'%s' not found in module '%s'"_err_en_US, MakeOpName(useName), 2463 useModuleScope_->GetName().value()); 2464 return {}; 2465 } 2466 if (useSymbol->attrs().test(Attr::PRIVATE) && 2467 !FindModuleFileContaining(currScope())) { 2468 // Privacy is not enforced in module files so that generic interfaces 2469 // can be resolved to private specific procedures in specification 2470 // expressions. 2471 Say(useName, "'%s' is PRIVATE in '%s'"_err_en_US, MakeOpName(useName), 2472 useModuleScope_->GetName().value()); 2473 return {}; 2474 } 2475 auto &localSymbol{MakeSymbol(localName)}; 2476 DoAddUse(useName, localName, localSymbol, *useSymbol); 2477 return {&localSymbol, useSymbol}; 2478 } 2479 2480 // symbol must be either a Use or a Generic formed by merging two uses. 2481 // Convert it to a UseError with this additional location. 2482 static void ConvertToUseError( 2483 Symbol &symbol, const SourceName &location, const Scope &module) { 2484 const auto *useDetails{symbol.detailsIf<UseDetails>()}; 2485 if (!useDetails) { 2486 auto &genericDetails{symbol.get<GenericDetails>()}; 2487 useDetails = &genericDetails.uses().at(0)->get<UseDetails>(); 2488 } 2489 symbol.set_details( 2490 UseErrorDetails{*useDetails}.add_occurrence(location, module)); 2491 } 2492 2493 void ModuleVisitor::DoAddUse(const SourceName &location, 2494 const SourceName &localName, Symbol &localSymbol, const Symbol &useSymbol) { 2495 localSymbol.attrs() = useSymbol.attrs() & ~Attrs{Attr::PUBLIC, Attr::PRIVATE}; 2496 localSymbol.flags() = useSymbol.flags(); 2497 const Symbol &useUltimate{useSymbol.GetUltimate()}; 2498 if (auto *useDetails{localSymbol.detailsIf<UseDetails>()}) { 2499 const Symbol &localUltimate{localSymbol.GetUltimate()}; 2500 if (localUltimate == useUltimate) { 2501 // use-associating the same symbol again -- ok 2502 } else if (localUltimate.has<GenericDetails>() && 2503 useUltimate.has<GenericDetails>()) { 2504 // use-associating generics with the same names: merge them into a 2505 // new generic in this scope 2506 auto generic1{localUltimate.get<GenericDetails>()}; 2507 AddGenericUse(generic1, localName, useUltimate); 2508 generic1.AddUse(localSymbol); 2509 // useSymbol has specific g and so does generic1 2510 auto &generic2{useUltimate.get<GenericDetails>()}; 2511 if (generic1.derivedType() && generic2.derivedType() && 2512 generic1.derivedType() != generic2.derivedType()) { 2513 Say(location, 2514 "Generic interface '%s' has ambiguous derived types" 2515 " from modules '%s' and '%s'"_err_en_US, 2516 localSymbol.name(), GetUsedModule(*useDetails).name(), 2517 useUltimate.owner().GetName().value()); 2518 context().SetError(localSymbol); 2519 } else { 2520 generic1.CopyFrom(generic2); 2521 } 2522 EraseSymbol(localSymbol); 2523 MakeSymbol(localSymbol.name(), localSymbol.attrs(), std::move(generic1)); 2524 } else { 2525 ConvertToUseError(localSymbol, location, *useModuleScope_); 2526 } 2527 } else if (auto *genericDetails{localSymbol.detailsIf<GenericDetails>()}) { 2528 if (const auto *useDetails{useUltimate.detailsIf<GenericDetails>()}) { 2529 AddGenericUse(*genericDetails, localName, useUltimate); 2530 if (genericDetails->derivedType() && useDetails->derivedType() && 2531 genericDetails->derivedType() != useDetails->derivedType()) { 2532 Say(location, 2533 "Generic interface '%s' has ambiguous derived types" 2534 " from modules '%s' and '%s'"_err_en_US, 2535 localSymbol.name(), 2536 genericDetails->derivedType()->owner().GetName().value(), 2537 useDetails->derivedType()->owner().GetName().value()); 2538 } else { 2539 genericDetails->CopyFrom(*useDetails); 2540 } 2541 } else { 2542 ConvertToUseError(localSymbol, location, *useModuleScope_); 2543 } 2544 } else if (auto *details{localSymbol.detailsIf<UseErrorDetails>()}) { 2545 details->add_occurrence(location, *useModuleScope_); 2546 } else if (!localSymbol.has<UnknownDetails>()) { 2547 Say(location, 2548 "Cannot use-associate '%s'; it is already declared in this scope"_err_en_US, 2549 localName) 2550 .Attach(localSymbol.name(), "Previous declaration of '%s'"_en_US, 2551 localName); 2552 } else { 2553 localSymbol.set_details(UseDetails{localName, useSymbol}); 2554 } 2555 } 2556 2557 void ModuleVisitor::AddUse(const GenericSpecInfo &info) { 2558 if (useModuleScope_) { 2559 const auto &name{info.symbolName()}; 2560 auto rename{AddUse(name, name, FindInScope(*useModuleScope_, name))}; 2561 info.Resolve(rename.use); 2562 } 2563 } 2564 2565 // Create a UseDetails symbol for this USE and add it to generic 2566 void ModuleVisitor::AddGenericUse( 2567 GenericDetails &generic, const SourceName &name, const Symbol &useSymbol) { 2568 generic.AddUse(currScope().MakeSymbol(name, {}, UseDetails{name, useSymbol})); 2569 } 2570 2571 bool ModuleVisitor::BeginSubmodule( 2572 const parser::Name &name, const parser::ParentIdentifier &parentId) { 2573 auto &ancestorName{std::get<parser::Name>(parentId.t)}; 2574 auto &parentName{std::get<std::optional<parser::Name>>(parentId.t)}; 2575 Scope *ancestor{FindModule(ancestorName)}; 2576 if (!ancestor) { 2577 return false; 2578 } 2579 Scope *parentScope{parentName ? FindModule(*parentName, ancestor) : ancestor}; 2580 if (!parentScope) { 2581 return false; 2582 } 2583 PushScope(*parentScope); // submodule is hosted in parent 2584 BeginModule(name, true); 2585 if (!ancestor->AddSubmodule(name.source, currScope())) { 2586 Say(name, "Module '%s' already has a submodule named '%s'"_err_en_US, 2587 ancestorName.source, name.source); 2588 } 2589 return true; 2590 } 2591 2592 void ModuleVisitor::BeginModule(const parser::Name &name, bool isSubmodule) { 2593 auto &symbol{MakeSymbol(name, ModuleDetails{isSubmodule})}; 2594 auto &details{symbol.get<ModuleDetails>()}; 2595 PushScope(Scope::Kind::Module, &symbol); 2596 details.set_scope(&currScope()); 2597 defaultAccess_ = Attr::PUBLIC; 2598 prevAccessStmt_ = std::nullopt; 2599 } 2600 2601 // Find a module or submodule by name and return its scope. 2602 // If ancestor is present, look for a submodule of that ancestor module. 2603 // May have to read a .mod file to find it. 2604 // If an error occurs, report it and return nullptr. 2605 Scope *ModuleVisitor::FindModule(const parser::Name &name, Scope *ancestor) { 2606 ModFileReader reader{context()}; 2607 Scope *scope{reader.Read(name.source, ancestor)}; 2608 if (!scope) { 2609 return nullptr; 2610 } 2611 if (scope->kind() != Scope::Kind::Module) { 2612 Say(name, "'%s' is not a module"_err_en_US); 2613 return nullptr; 2614 } 2615 if (DoesScopeContain(scope, currScope())) { // 14.2.2(1) 2616 Say(name, "Module '%s' cannot USE itself"_err_en_US); 2617 } 2618 Resolve(name, scope->symbol()); 2619 return scope; 2620 } 2621 2622 void ModuleVisitor::ApplyDefaultAccess() { 2623 for (auto &pair : currScope()) { 2624 Symbol &symbol = *pair.second; 2625 if (!symbol.attrs().HasAny({Attr::PUBLIC, Attr::PRIVATE})) { 2626 symbol.attrs().set(defaultAccess_); 2627 } 2628 } 2629 } 2630 2631 // InterfaceVistor implementation 2632 2633 bool InterfaceVisitor::Pre(const parser::InterfaceStmt &x) { 2634 bool isAbstract{std::holds_alternative<parser::Abstract>(x.u)}; 2635 genericInfo_.emplace(/*isInterface*/ true, isAbstract); 2636 return BeginAttrs(); 2637 } 2638 2639 void InterfaceVisitor::Post(const parser::InterfaceStmt &) { EndAttrs(); } 2640 2641 void InterfaceVisitor::Post(const parser::EndInterfaceStmt &) { 2642 genericInfo_.pop(); 2643 } 2644 2645 // Create a symbol in genericSymbol_ for this GenericSpec. 2646 bool InterfaceVisitor::Pre(const parser::GenericSpec &x) { 2647 if (auto *symbol{FindInScope(GenericSpecInfo{x}.symbolName())}) { 2648 SetGenericSymbol(*symbol); 2649 } 2650 return false; 2651 } 2652 2653 bool InterfaceVisitor::Pre(const parser::ProcedureStmt &x) { 2654 if (!isGeneric()) { 2655 Say("A PROCEDURE statement is only allowed in a generic interface block"_err_en_US); 2656 return false; 2657 } 2658 auto kind{std::get<parser::ProcedureStmt::Kind>(x.t)}; 2659 const auto &names{std::get<std::list<parser::Name>>(x.t)}; 2660 AddSpecificProcs(names, kind); 2661 return false; 2662 } 2663 2664 bool InterfaceVisitor::Pre(const parser::GenericStmt &) { 2665 genericInfo_.emplace(/*isInterface*/ false); 2666 return true; 2667 } 2668 void InterfaceVisitor::Post(const parser::GenericStmt &x) { 2669 if (auto &accessSpec{std::get<std::optional<parser::AccessSpec>>(x.t)}) { 2670 GetGenericInfo().symbol->attrs().set(AccessSpecToAttr(*accessSpec)); 2671 } 2672 const auto &names{std::get<std::list<parser::Name>>(x.t)}; 2673 AddSpecificProcs(names, ProcedureKind::Procedure); 2674 genericInfo_.pop(); 2675 } 2676 2677 bool InterfaceVisitor::inInterfaceBlock() const { 2678 return !genericInfo_.empty() && GetGenericInfo().isInterface; 2679 } 2680 bool InterfaceVisitor::isGeneric() const { 2681 return !genericInfo_.empty() && GetGenericInfo().symbol; 2682 } 2683 bool InterfaceVisitor::isAbstract() const { 2684 return !genericInfo_.empty() && GetGenericInfo().isAbstract; 2685 } 2686 2687 void InterfaceVisitor::AddSpecificProcs( 2688 const std::list<parser::Name> &names, ProcedureKind kind) { 2689 for (const auto &name : names) { 2690 specificProcs_.emplace( 2691 GetGenericInfo().symbol, std::make_pair(&name, kind)); 2692 } 2693 } 2694 2695 // By now we should have seen all specific procedures referenced by name in 2696 // this generic interface. Resolve those names to symbols. 2697 void InterfaceVisitor::ResolveSpecificsInGeneric(Symbol &generic) { 2698 auto &details{generic.get<GenericDetails>()}; 2699 UnorderedSymbolSet symbolsSeen; 2700 for (const Symbol &symbol : details.specificProcs()) { 2701 symbolsSeen.insert(symbol); 2702 } 2703 auto range{specificProcs_.equal_range(&generic)}; 2704 for (auto it{range.first}; it != range.second; ++it) { 2705 auto *name{it->second.first}; 2706 auto kind{it->second.second}; 2707 const auto *symbol{FindSymbol(*name)}; 2708 if (!symbol) { 2709 Say(*name, "Procedure '%s' not found"_err_en_US); 2710 continue; 2711 } 2712 if (symbol == &generic) { 2713 if (auto *specific{generic.get<GenericDetails>().specific()}) { 2714 symbol = specific; 2715 } 2716 } 2717 const Symbol &ultimate{symbol->GetUltimate()}; 2718 if (!ultimate.has<SubprogramDetails>() && 2719 !ultimate.has<SubprogramNameDetails>()) { 2720 Say(*name, "'%s' is not a subprogram"_err_en_US); 2721 continue; 2722 } 2723 if (kind == ProcedureKind::ModuleProcedure) { 2724 if (const auto *nd{ultimate.detailsIf<SubprogramNameDetails>()}) { 2725 if (nd->kind() != SubprogramKind::Module) { 2726 Say(*name, "'%s' is not a module procedure"_err_en_US); 2727 } 2728 } else { 2729 // USE-associated procedure 2730 const auto *sd{ultimate.detailsIf<SubprogramDetails>()}; 2731 CHECK(sd); 2732 if (ultimate.owner().kind() != Scope::Kind::Module || 2733 sd->isInterface()) { 2734 Say(*name, "'%s' is not a module procedure"_err_en_US); 2735 } 2736 } 2737 } 2738 if (!symbolsSeen.insert(ultimate).second) { 2739 if (symbol == &ultimate) { 2740 Say(name->source, 2741 "Procedure '%s' is already specified in generic '%s'"_err_en_US, 2742 name->source, MakeOpName(generic.name())); 2743 } else { 2744 Say(name->source, 2745 "Procedure '%s' from module '%s' is already specified in generic '%s'"_err_en_US, 2746 ultimate.name(), ultimate.owner().GetName().value(), 2747 MakeOpName(generic.name())); 2748 } 2749 continue; 2750 } 2751 details.AddSpecificProc(*symbol, name->source); 2752 } 2753 specificProcs_.erase(range.first, range.second); 2754 } 2755 2756 // Check that the specific procedures are all functions or all subroutines. 2757 // If there is a derived type with the same name they must be functions. 2758 // Set the corresponding flag on generic. 2759 void InterfaceVisitor::CheckGenericProcedures(Symbol &generic) { 2760 ResolveSpecificsInGeneric(generic); 2761 auto &details{generic.get<GenericDetails>()}; 2762 if (auto *proc{details.CheckSpecific()}) { 2763 auto msg{ 2764 "'%s' may not be the name of both a generic interface and a" 2765 " procedure unless it is a specific procedure of the generic"_err_en_US}; 2766 if (proc->name().begin() > generic.name().begin()) { 2767 Say(proc->name(), std::move(msg)); 2768 } else { 2769 Say(generic.name(), std::move(msg)); 2770 } 2771 } 2772 auto &specifics{details.specificProcs()}; 2773 if (specifics.empty()) { 2774 if (details.derivedType()) { 2775 generic.set(Symbol::Flag::Function); 2776 } 2777 return; 2778 } 2779 const Symbol &firstSpecific{specifics.front()}; 2780 bool isFunction{firstSpecific.test(Symbol::Flag::Function)}; 2781 for (const Symbol &specific : specifics) { 2782 if (isFunction != specific.test(Symbol::Flag::Function)) { // C1514 2783 auto &msg{Say(generic.name(), 2784 "Generic interface '%s' has both a function and a subroutine"_err_en_US)}; 2785 if (isFunction) { 2786 msg.Attach(firstSpecific.name(), "Function declaration"_en_US); 2787 msg.Attach(specific.name(), "Subroutine declaration"_en_US); 2788 } else { 2789 msg.Attach(firstSpecific.name(), "Subroutine declaration"_en_US); 2790 msg.Attach(specific.name(), "Function declaration"_en_US); 2791 } 2792 } 2793 } 2794 if (!isFunction && details.derivedType()) { 2795 SayDerivedType(generic.name(), 2796 "Generic interface '%s' may only contain functions due to derived type" 2797 " with same name"_err_en_US, 2798 *details.derivedType()->scope()); 2799 } 2800 generic.set(isFunction ? Symbol::Flag::Function : Symbol::Flag::Subroutine); 2801 } 2802 2803 // SubprogramVisitor implementation 2804 2805 // Return false if it is actually an assignment statement. 2806 bool SubprogramVisitor::HandleStmtFunction(const parser::StmtFunctionStmt &x) { 2807 const auto &name{std::get<parser::Name>(x.t)}; 2808 const DeclTypeSpec *resultType{nullptr}; 2809 // Look up name: provides return type or tells us if it's an array 2810 if (auto *symbol{FindSymbol(name)}) { 2811 auto *details{symbol->detailsIf<EntityDetails>()}; 2812 if (!details) { 2813 badStmtFuncFound_ = true; 2814 return false; 2815 } 2816 // TODO: check that attrs are compatible with stmt func 2817 resultType = details->type(); 2818 symbol->details() = UnknownDetails{}; // will be replaced below 2819 } 2820 if (badStmtFuncFound_) { 2821 Say(name, "'%s' has not been declared as an array"_err_en_US); 2822 return true; 2823 } 2824 auto &symbol{PushSubprogramScope(name, Symbol::Flag::Function)}; 2825 symbol.set(Symbol::Flag::StmtFunction); 2826 EraseSymbol(symbol); // removes symbol added by PushSubprogramScope 2827 auto &details{symbol.get<SubprogramDetails>()}; 2828 for (const auto &dummyName : std::get<std::list<parser::Name>>(x.t)) { 2829 ObjectEntityDetails dummyDetails{true}; 2830 if (auto *dummySymbol{FindInScope(currScope().parent(), dummyName)}) { 2831 if (auto *d{dummySymbol->detailsIf<EntityDetails>()}) { 2832 if (d->type()) { 2833 dummyDetails.set_type(*d->type()); 2834 } 2835 } 2836 } 2837 Symbol &dummy{MakeSymbol(dummyName, std::move(dummyDetails))}; 2838 ApplyImplicitRules(dummy); 2839 details.add_dummyArg(dummy); 2840 } 2841 ObjectEntityDetails resultDetails; 2842 if (resultType) { 2843 resultDetails.set_type(*resultType); 2844 } 2845 resultDetails.set_funcResult(true); 2846 Symbol &result{MakeSymbol(name, std::move(resultDetails))}; 2847 ApplyImplicitRules(result); 2848 details.set_result(result); 2849 const auto &parsedExpr{std::get<parser::Scalar<parser::Expr>>(x.t)}; 2850 Walk(parsedExpr); 2851 // The analysis of the expression that constitutes the body of the 2852 // statement function is deferred to FinishSpecificationPart() so that 2853 // all declarations and implicit typing are complete. 2854 PopScope(); 2855 return true; 2856 } 2857 2858 bool SubprogramVisitor::Pre(const parser::Suffix &suffix) { 2859 if (suffix.resultName) { 2860 funcInfo_.resultName = &suffix.resultName.value(); 2861 } 2862 return true; 2863 } 2864 2865 bool SubprogramVisitor::Pre(const parser::PrefixSpec &x) { 2866 // Save this to process after UseStmt and ImplicitPart 2867 if (const auto *parsedType{std::get_if<parser::DeclarationTypeSpec>(&x.u)}) { 2868 if (funcInfo_.parsedType) { // C1543 2869 Say(currStmtSource().value(), 2870 "FUNCTION prefix cannot specify the type more than once"_err_en_US); 2871 return false; 2872 } else { 2873 funcInfo_.parsedType = parsedType; 2874 funcInfo_.source = currStmtSource(); 2875 return false; 2876 } 2877 } else { 2878 return true; 2879 } 2880 } 2881 2882 void SubprogramVisitor::Post(const parser::ImplicitPart &) { 2883 // If the function has a type in the prefix, process it now 2884 if (funcInfo_.parsedType) { 2885 messageHandler().set_currStmtSource(funcInfo_.source); 2886 if (const auto *type{ProcessTypeSpec(*funcInfo_.parsedType, true)}) { 2887 if (!context().HasError(funcInfo_.resultSymbol)) { 2888 funcInfo_.resultSymbol->SetType(*type); 2889 } 2890 } 2891 } 2892 funcInfo_ = {}; 2893 } 2894 2895 bool SubprogramVisitor::Pre(const parser::InterfaceBody::Subroutine &x) { 2896 const auto &name{std::get<parser::Name>( 2897 std::get<parser::Statement<parser::SubroutineStmt>>(x.t).statement.t)}; 2898 return BeginSubprogram(name, Symbol::Flag::Subroutine); 2899 } 2900 void SubprogramVisitor::Post(const parser::InterfaceBody::Subroutine &) { 2901 EndSubprogram(); 2902 } 2903 bool SubprogramVisitor::Pre(const parser::InterfaceBody::Function &x) { 2904 const auto &name{std::get<parser::Name>( 2905 std::get<parser::Statement<parser::FunctionStmt>>(x.t).statement.t)}; 2906 return BeginSubprogram(name, Symbol::Flag::Function); 2907 } 2908 void SubprogramVisitor::Post(const parser::InterfaceBody::Function &) { 2909 EndSubprogram(); 2910 } 2911 2912 bool SubprogramVisitor::Pre(const parser::SubroutineStmt &) { 2913 return BeginAttrs(); 2914 } 2915 bool SubprogramVisitor::Pre(const parser::FunctionStmt &) { 2916 return BeginAttrs(); 2917 } 2918 bool SubprogramVisitor::Pre(const parser::EntryStmt &) { return BeginAttrs(); } 2919 2920 void SubprogramVisitor::Post(const parser::SubroutineStmt &stmt) { 2921 const auto &name{std::get<parser::Name>(stmt.t)}; 2922 auto &details{PostSubprogramStmt(name)}; 2923 for (const auto &dummyArg : std::get<std::list<parser::DummyArg>>(stmt.t)) { 2924 if (const auto *dummyName{std::get_if<parser::Name>(&dummyArg.u)}) { 2925 Symbol &dummy{MakeSymbol(*dummyName, EntityDetails(true))}; 2926 details.add_dummyArg(dummy); 2927 } else { 2928 details.add_alternateReturn(); 2929 } 2930 } 2931 } 2932 2933 void SubprogramVisitor::Post(const parser::FunctionStmt &stmt) { 2934 const auto &name{std::get<parser::Name>(stmt.t)}; 2935 auto &details{PostSubprogramStmt(name)}; 2936 for (const auto &dummyName : std::get<std::list<parser::Name>>(stmt.t)) { 2937 Symbol &dummy{MakeSymbol(dummyName, EntityDetails(true))}; 2938 details.add_dummyArg(dummy); 2939 } 2940 const parser::Name *funcResultName; 2941 if (funcInfo_.resultName && funcInfo_.resultName->source != name.source) { 2942 // Note that RESULT is ignored if it has the same name as the function. 2943 funcResultName = funcInfo_.resultName; 2944 } else { 2945 EraseSymbol(name); // was added by PushSubprogramScope 2946 funcResultName = &name; 2947 } 2948 // add function result to function scope 2949 if (details.isFunction()) { 2950 CHECK(context().HasError(currScope().symbol())); 2951 } else { 2952 // add function result to function scope 2953 EntityDetails funcResultDetails; 2954 funcResultDetails.set_funcResult(true); 2955 funcInfo_.resultSymbol = 2956 &MakeSymbol(*funcResultName, std::move(funcResultDetails)); 2957 details.set_result(*funcInfo_.resultSymbol); 2958 } 2959 2960 // C1560. 2961 if (funcInfo_.resultName && funcInfo_.resultName->source == name.source) { 2962 Say(funcInfo_.resultName->source, 2963 "The function name should not appear in RESULT, references to '%s' " 2964 "inside" 2965 " the function will be considered as references to the result only"_en_US, 2966 name.source); 2967 // RESULT name was ignored above, the only side effect from doing so will be 2968 // the inability to make recursive calls. The related parser::Name is still 2969 // resolved to the created function result symbol because every parser::Name 2970 // should be resolved to avoid internal errors. 2971 Resolve(*funcInfo_.resultName, funcInfo_.resultSymbol); 2972 } 2973 name.symbol = currScope().symbol(); // must not be function result symbol 2974 // Clear the RESULT() name now in case an ENTRY statement in the implicit-part 2975 // has a RESULT() suffix. 2976 funcInfo_.resultName = nullptr; 2977 } 2978 2979 SubprogramDetails &SubprogramVisitor::PostSubprogramStmt( 2980 const parser::Name &name) { 2981 Symbol &symbol{*currScope().symbol()}; 2982 CHECK(name.source == symbol.name()); 2983 SetBindNameOn(symbol); 2984 symbol.attrs() |= EndAttrs(); 2985 if (symbol.attrs().test(Attr::MODULE)) { 2986 symbol.attrs().set(Attr::EXTERNAL, false); 2987 } 2988 return symbol.get<SubprogramDetails>(); 2989 } 2990 2991 void SubprogramVisitor::Post(const parser::EntryStmt &stmt) { 2992 auto attrs{EndAttrs()}; // needs to be called even if early return 2993 Scope &inclusiveScope{InclusiveScope()}; 2994 const Symbol *subprogram{inclusiveScope.symbol()}; 2995 if (!subprogram) { 2996 CHECK(context().AnyFatalError()); 2997 return; 2998 } 2999 const auto &name{std::get<parser::Name>(stmt.t)}; 3000 const auto *parentDetails{subprogram->detailsIf<SubprogramDetails>()}; 3001 bool inFunction{parentDetails && parentDetails->isFunction()}; 3002 const parser::Name *resultName{funcInfo_.resultName}; 3003 if (resultName) { // RESULT(result) is present 3004 funcInfo_.resultName = nullptr; 3005 if (!inFunction) { 3006 Say2(resultName->source, 3007 "RESULT(%s) may appear only in a function"_err_en_US, 3008 subprogram->name(), "Containing subprogram"_en_US); 3009 } else if (resultName->source == subprogram->name()) { // C1574 3010 Say2(resultName->source, 3011 "RESULT(%s) may not have the same name as the function"_err_en_US, 3012 subprogram->name(), "Containing function"_en_US); 3013 } else if (const Symbol * 3014 symbol{FindSymbol(inclusiveScope.parent(), *resultName)}) { // C1574 3015 if (const auto *details{symbol->detailsIf<SubprogramDetails>()}) { 3016 if (details->entryScope() == &inclusiveScope) { 3017 Say2(resultName->source, 3018 "RESULT(%s) may not have the same name as an ENTRY in the function"_err_en_US, 3019 symbol->name(), "Conflicting ENTRY"_en_US); 3020 } 3021 } 3022 } 3023 if (Symbol * symbol{FindSymbol(name)}) { // C1570 3024 // When RESULT() appears, ENTRY name can't have been already declared 3025 if (inclusiveScope.Contains(symbol->owner())) { 3026 Say2(name, 3027 "ENTRY name '%s' may not be declared when RESULT() is present"_err_en_US, 3028 *symbol, "Previous declaration of '%s'"_en_US); 3029 } 3030 } 3031 if (resultName->source == name.source) { 3032 // ignore RESULT() hereafter when it's the same name as the ENTRY 3033 resultName = nullptr; 3034 } 3035 } 3036 SubprogramDetails entryDetails; 3037 entryDetails.set_entryScope(inclusiveScope); 3038 if (inFunction) { 3039 // Create the entity to hold the function result, if necessary. 3040 Symbol *resultSymbol{nullptr}; 3041 auto &effectiveResultName{*(resultName ? resultName : &name)}; 3042 resultSymbol = FindInScope(currScope(), effectiveResultName); 3043 if (resultSymbol) { // C1574 3044 std::visit( 3045 common::visitors{[](EntityDetails &x) { x.set_funcResult(true); }, 3046 [](ObjectEntityDetails &x) { x.set_funcResult(true); }, 3047 [](ProcEntityDetails &x) { x.set_funcResult(true); }, 3048 [&](const auto &) { 3049 Say2(effectiveResultName.source, 3050 "'%s' was previously declared as an item that may not be used as a function result"_err_en_US, 3051 resultSymbol->name(), "Previous declaration of '%s'"_en_US); 3052 }}, 3053 resultSymbol->details()); 3054 } else if (inExecutionPart_) { 3055 ObjectEntityDetails entity; 3056 entity.set_funcResult(true); 3057 resultSymbol = &MakeSymbol(effectiveResultName, std::move(entity)); 3058 ApplyImplicitRules(*resultSymbol); 3059 } else { 3060 EntityDetails entity; 3061 entity.set_funcResult(true); 3062 resultSymbol = &MakeSymbol(effectiveResultName, std::move(entity)); 3063 } 3064 if (!resultName) { 3065 name.symbol = nullptr; // symbol will be used for entry point below 3066 } 3067 entryDetails.set_result(*resultSymbol); 3068 } 3069 3070 for (const auto &dummyArg : std::get<std::list<parser::DummyArg>>(stmt.t)) { 3071 if (const auto *dummyName{std::get_if<parser::Name>(&dummyArg.u)}) { 3072 Symbol *dummy{FindSymbol(*dummyName)}; 3073 if (dummy) { 3074 std::visit( 3075 common::visitors{[](EntityDetails &x) { x.set_isDummy(); }, 3076 [](ObjectEntityDetails &x) { x.set_isDummy(); }, 3077 [](ProcEntityDetails &x) { x.set_isDummy(); }, 3078 [&](const auto &) { 3079 Say2(dummyName->source, 3080 "ENTRY dummy argument '%s' is previously declared as an item that may not be used as a dummy argument"_err_en_US, 3081 dummy->name(), "Previous declaration of '%s'"_en_US); 3082 }}, 3083 dummy->details()); 3084 } else { 3085 dummy = &MakeSymbol(*dummyName, EntityDetails(true)); 3086 } 3087 entryDetails.add_dummyArg(*dummy); 3088 } else { 3089 if (inFunction) { // C1573 3090 Say(name, 3091 "ENTRY in a function may not have an alternate return dummy argument"_err_en_US); 3092 break; 3093 } 3094 entryDetails.add_alternateReturn(); 3095 } 3096 } 3097 3098 Symbol::Flag subpFlag{ 3099 inFunction ? Symbol::Flag::Function : Symbol::Flag::Subroutine}; 3100 Scope &outer{inclusiveScope.parent()}; // global or module scope 3101 if (Symbol * extant{FindSymbol(outer, name)}) { 3102 if (extant->has<ProcEntityDetails>()) { 3103 if (!extant->test(subpFlag)) { 3104 Say2(name, 3105 subpFlag == Symbol::Flag::Function 3106 ? "'%s' was previously called as a subroutine"_err_en_US 3107 : "'%s' was previously called as a function"_err_en_US, 3108 *extant, "Previous call of '%s'"_en_US); 3109 } 3110 if (extant->attrs().test(Attr::PRIVATE)) { 3111 attrs.set(Attr::PRIVATE); 3112 } 3113 outer.erase(extant->name()); 3114 } else { 3115 if (outer.IsGlobal()) { 3116 Say2(name, "'%s' is already defined as a global identifier"_err_en_US, 3117 *extant, "Previous definition of '%s'"_en_US); 3118 } else { 3119 SayAlreadyDeclared(name, *extant); 3120 } 3121 return; 3122 } 3123 } 3124 if (outer.IsModule() && !attrs.test(Attr::PRIVATE)) { 3125 attrs.set(Attr::PUBLIC); 3126 } 3127 Symbol &entrySymbol{MakeSymbol(outer, name.source, attrs)}; 3128 entrySymbol.set_details(std::move(entryDetails)); 3129 if (outer.IsGlobal()) { 3130 MakeExternal(entrySymbol); 3131 } 3132 SetBindNameOn(entrySymbol); 3133 entrySymbol.set(subpFlag); 3134 Resolve(name, entrySymbol); 3135 } 3136 3137 // A subprogram declared with MODULE PROCEDURE 3138 bool SubprogramVisitor::BeginMpSubprogram(const parser::Name &name) { 3139 auto *symbol{FindSymbol(name)}; 3140 if (symbol && symbol->has<SubprogramNameDetails>()) { 3141 symbol = FindSymbol(currScope().parent(), name); 3142 } 3143 if (!IsSeparateModuleProcedureInterface(symbol)) { 3144 Say(name, "'%s' was not declared a separate module procedure"_err_en_US); 3145 return false; 3146 } 3147 if (symbol->owner() == currScope()) { 3148 PushScope(Scope::Kind::Subprogram, symbol); 3149 } else { 3150 Symbol &newSymbol{MakeSymbol(name, SubprogramDetails{})}; 3151 PushScope(Scope::Kind::Subprogram, &newSymbol); 3152 const auto &details{symbol->get<SubprogramDetails>()}; 3153 auto &newDetails{newSymbol.get<SubprogramDetails>()}; 3154 for (const Symbol *dummyArg : details.dummyArgs()) { 3155 if (!dummyArg) { 3156 newDetails.add_alternateReturn(); 3157 } else if (Symbol * copy{currScope().CopySymbol(*dummyArg)}) { 3158 newDetails.add_dummyArg(*copy); 3159 } 3160 } 3161 if (details.isFunction()) { 3162 currScope().erase(symbol->name()); 3163 newDetails.set_result(*currScope().CopySymbol(details.result())); 3164 } 3165 } 3166 return true; 3167 } 3168 3169 // A subprogram declared with SUBROUTINE or FUNCTION 3170 bool SubprogramVisitor::BeginSubprogram( 3171 const parser::Name &name, Symbol::Flag subpFlag, bool hasModulePrefix) { 3172 if (hasModulePrefix && currScope().IsGlobal()) { // C1547 3173 Say(name, 3174 "'%s' is a MODULE procedure which must be declared within a " 3175 "MODULE or SUBMODULE"_err_en_US); 3176 return false; 3177 } 3178 3179 if (hasModulePrefix && !inInterfaceBlock() && 3180 !IsSeparateModuleProcedureInterface( 3181 FindSymbol(currScope().parent(), name))) { 3182 Say(name, "'%s' was not declared a separate module procedure"_err_en_US); 3183 return false; 3184 } 3185 PushSubprogramScope(name, subpFlag); 3186 return true; 3187 } 3188 3189 void SubprogramVisitor::EndSubprogram() { PopScope(); } 3190 3191 void SubprogramVisitor::CheckExtantProc( 3192 const parser::Name &name, Symbol::Flag subpFlag) { 3193 if (auto *prev{FindSymbol(name)}) { 3194 if (prev->attrs().test(Attr::EXTERNAL) && prev->has<ProcEntityDetails>()) { 3195 // this subprogram was previously called, now being declared 3196 if (!prev->test(subpFlag)) { 3197 Say2(name, 3198 subpFlag == Symbol::Flag::Function 3199 ? "'%s' was previously called as a subroutine"_err_en_US 3200 : "'%s' was previously called as a function"_err_en_US, 3201 *prev, "Previous call of '%s'"_en_US); 3202 } 3203 EraseSymbol(name); 3204 } else if (const auto *details{prev->detailsIf<EntityDetails>()}) { 3205 if (!details->isDummy()) { 3206 Say2(name, "Procedure '%s' was previously declared"_err_en_US, *prev, 3207 "Previous declaration of '%s'"_en_US); 3208 } 3209 } 3210 } 3211 } 3212 3213 Symbol &SubprogramVisitor::PushSubprogramScope( 3214 const parser::Name &name, Symbol::Flag subpFlag) { 3215 auto *symbol{GetSpecificFromGeneric(name)}; 3216 if (!symbol) { 3217 CheckExtantProc(name, subpFlag); 3218 symbol = &MakeSymbol(name, SubprogramDetails{}); 3219 } 3220 symbol->set(subpFlag); 3221 symbol->ReplaceName(name.source); 3222 PushScope(Scope::Kind::Subprogram, symbol); 3223 auto &details{symbol->get<SubprogramDetails>()}; 3224 if (inInterfaceBlock()) { 3225 details.set_isInterface(); 3226 if (isAbstract()) { 3227 symbol->attrs().set(Attr::ABSTRACT); 3228 } else { 3229 MakeExternal(*symbol); 3230 } 3231 if (isGeneric()) { 3232 Symbol &genericSymbol{GetGenericSymbol()}; 3233 if (genericSymbol.has<GenericDetails>()) { 3234 genericSymbol.get<GenericDetails>().AddSpecificProc( 3235 *symbol, name.source); 3236 } else { 3237 CHECK(context().HasError(genericSymbol)); 3238 } 3239 } 3240 set_inheritFromParent(false); 3241 } 3242 FindSymbol(name)->set(subpFlag); // PushScope() created symbol 3243 return *symbol; 3244 } 3245 3246 void SubprogramVisitor::PushBlockDataScope(const parser::Name &name) { 3247 if (auto *prev{FindSymbol(name)}) { 3248 if (prev->attrs().test(Attr::EXTERNAL) && prev->has<ProcEntityDetails>()) { 3249 if (prev->test(Symbol::Flag::Subroutine) || 3250 prev->test(Symbol::Flag::Function)) { 3251 Say2(name, "BLOCK DATA '%s' has been called"_err_en_US, *prev, 3252 "Previous call of '%s'"_en_US); 3253 } 3254 EraseSymbol(name); 3255 } 3256 } 3257 if (name.source.empty()) { 3258 // Don't let unnamed BLOCK DATA conflict with unnamed PROGRAM 3259 PushScope(Scope::Kind::BlockData, nullptr); 3260 } else { 3261 PushScope(Scope::Kind::BlockData, &MakeSymbol(name, SubprogramDetails{})); 3262 } 3263 } 3264 3265 // If name is a generic, return specific subprogram with the same name. 3266 Symbol *SubprogramVisitor::GetSpecificFromGeneric(const parser::Name &name) { 3267 if (auto *symbol{FindSymbol(name)}) { 3268 if (auto *details{symbol->detailsIf<GenericDetails>()}) { 3269 // found generic, want subprogram 3270 auto *specific{details->specific()}; 3271 if (!specific) { 3272 specific = 3273 &currScope().MakeSymbol(name.source, Attrs{}, SubprogramDetails{}); 3274 if (details->derivedType()) { 3275 // A specific procedure with the same name as a derived type 3276 SayAlreadyDeclared(name, *details->derivedType()); 3277 } else { 3278 details->set_specific(Resolve(name, *specific)); 3279 } 3280 } else if (isGeneric()) { 3281 SayAlreadyDeclared(name, *specific); 3282 } 3283 if (!specific->has<SubprogramDetails>()) { 3284 specific->set_details(SubprogramDetails{}); 3285 } 3286 return specific; 3287 } 3288 } 3289 return nullptr; 3290 } 3291 3292 // DeclarationVisitor implementation 3293 3294 bool DeclarationVisitor::BeginDecl() { 3295 BeginDeclTypeSpec(); 3296 BeginArraySpec(); 3297 return BeginAttrs(); 3298 } 3299 void DeclarationVisitor::EndDecl() { 3300 EndDeclTypeSpec(); 3301 EndArraySpec(); 3302 EndAttrs(); 3303 } 3304 3305 bool DeclarationVisitor::CheckUseError(const parser::Name &name) { 3306 const auto *details{name.symbol->detailsIf<UseErrorDetails>()}; 3307 if (!details) { 3308 return false; 3309 } 3310 Message &msg{Say(name, "Reference to '%s' is ambiguous"_err_en_US)}; 3311 for (const auto &[location, module] : details->occurrences()) { 3312 msg.Attach(location, "'%s' was use-associated from module '%s'"_en_US, 3313 name.source, module->GetName().value()); 3314 } 3315 return true; 3316 } 3317 3318 // Report error if accessibility of symbol doesn't match isPrivate. 3319 void DeclarationVisitor::CheckAccessibility( 3320 const SourceName &name, bool isPrivate, Symbol &symbol) { 3321 if (symbol.attrs().test(Attr::PRIVATE) != isPrivate) { 3322 Say2(name, 3323 "'%s' does not have the same accessibility as its previous declaration"_err_en_US, 3324 symbol, "Previous declaration of '%s'"_en_US); 3325 } 3326 } 3327 3328 void DeclarationVisitor::Post(const parser::TypeDeclarationStmt &) { 3329 if (!GetAttrs().HasAny({Attr::POINTER, Attr::ALLOCATABLE})) { // C702 3330 if (const auto *typeSpec{GetDeclTypeSpec()}) { 3331 if (typeSpec->category() == DeclTypeSpec::Character) { 3332 if (typeSpec->characterTypeSpec().length().isDeferred()) { 3333 Say("The type parameter LEN cannot be deferred without" 3334 " the POINTER or ALLOCATABLE attribute"_err_en_US); 3335 } 3336 } else if (const DerivedTypeSpec * derivedSpec{typeSpec->AsDerived()}) { 3337 for (const auto &pair : derivedSpec->parameters()) { 3338 if (pair.second.isDeferred()) { 3339 Say(currStmtSource().value(), 3340 "The value of type parameter '%s' cannot be deferred" 3341 " without the POINTER or ALLOCATABLE attribute"_err_en_US, 3342 pair.first); 3343 } 3344 } 3345 } 3346 } 3347 } 3348 EndDecl(); 3349 } 3350 3351 void DeclarationVisitor::Post(const parser::DimensionStmt::Declaration &x) { 3352 DeclareObjectEntity(std::get<parser::Name>(x.t)); 3353 } 3354 void DeclarationVisitor::Post(const parser::CodimensionDecl &x) { 3355 DeclareObjectEntity(std::get<parser::Name>(x.t)); 3356 } 3357 3358 bool DeclarationVisitor::Pre(const parser::Initialization &) { 3359 // Defer inspection of initializers to Initialization() so that the 3360 // symbol being initialized will be available within the initialization 3361 // expression. 3362 return false; 3363 } 3364 3365 void DeclarationVisitor::Post(const parser::EntityDecl &x) { 3366 // TODO: may be under StructureStmt 3367 const auto &name{std::get<parser::ObjectName>(x.t)}; 3368 Attrs attrs{attrs_ ? HandleSaveName(name.source, *attrs_) : Attrs{}}; 3369 Symbol &symbol{DeclareUnknownEntity(name, attrs)}; 3370 symbol.ReplaceName(name.source); 3371 if (auto &init{std::get<std::optional<parser::Initialization>>(x.t)}) { 3372 if (ConvertToObjectEntity(symbol)) { 3373 Initialization(name, *init, false); 3374 } 3375 } else if (attrs.test(Attr::PARAMETER)) { // C882, C883 3376 Say(name, "Missing initialization for parameter '%s'"_err_en_US); 3377 } 3378 } 3379 3380 void DeclarationVisitor::Post(const parser::PointerDecl &x) { 3381 const auto &name{std::get<parser::Name>(x.t)}; 3382 if (const auto &deferredShapeSpecs{ 3383 std::get<std::optional<parser::DeferredShapeSpecList>>(x.t)}) { 3384 CHECK(arraySpec().empty()); 3385 BeginArraySpec(); 3386 set_arraySpec(AnalyzeDeferredShapeSpecList(context(), *deferredShapeSpecs)); 3387 Symbol &symbol{DeclareObjectEntity(name, Attrs{Attr::POINTER})}; 3388 symbol.ReplaceName(name.source); 3389 EndArraySpec(); 3390 } else { 3391 Symbol &symbol{DeclareUnknownEntity(name, Attrs{Attr::POINTER})}; 3392 symbol.ReplaceName(name.source); 3393 } 3394 } 3395 3396 bool DeclarationVisitor::Pre(const parser::BindEntity &x) { 3397 auto kind{std::get<parser::BindEntity::Kind>(x.t)}; 3398 auto &name{std::get<parser::Name>(x.t)}; 3399 Symbol *symbol; 3400 if (kind == parser::BindEntity::Kind::Object) { 3401 symbol = &HandleAttributeStmt(Attr::BIND_C, name); 3402 } else { 3403 symbol = &MakeCommonBlockSymbol(name); 3404 symbol->attrs().set(Attr::BIND_C); 3405 } 3406 SetBindNameOn(*symbol); 3407 return false; 3408 } 3409 bool DeclarationVisitor::Pre(const parser::OldParameterStmt &x) { 3410 inOldStyleParameterStmt_ = true; 3411 Walk(x.v); 3412 inOldStyleParameterStmt_ = false; 3413 return false; 3414 } 3415 bool DeclarationVisitor::Pre(const parser::NamedConstantDef &x) { 3416 auto &name{std::get<parser::NamedConstant>(x.t).v}; 3417 auto &symbol{HandleAttributeStmt(Attr::PARAMETER, name)}; 3418 if (!ConvertToObjectEntity(symbol) || 3419 symbol.test(Symbol::Flag::CrayPointer) || 3420 symbol.test(Symbol::Flag::CrayPointee)) { 3421 SayWithDecl( 3422 name, symbol, "PARAMETER attribute not allowed on '%s'"_err_en_US); 3423 return false; 3424 } 3425 const auto &expr{std::get<parser::ConstantExpr>(x.t)}; 3426 auto &details{symbol.get<ObjectEntityDetails>()}; 3427 if (inOldStyleParameterStmt_) { 3428 // non-standard extension PARAMETER statement (no parentheses) 3429 Walk(expr); 3430 auto folded{EvaluateExpr(expr)}; 3431 if (details.type()) { 3432 SayWithDecl(name, symbol, 3433 "Alternative style PARAMETER '%s' must not already have an explicit type"_err_en_US); 3434 } else if (folded) { 3435 auto at{expr.thing.value().source}; 3436 if (evaluate::IsActuallyConstant(*folded)) { 3437 if (const auto *type{currScope().GetType(*folded)}) { 3438 if (type->IsPolymorphic()) { 3439 Say(at, "The expression must not be polymorphic"_err_en_US); 3440 } else if (auto shape{ToArraySpec( 3441 GetFoldingContext(), evaluate::GetShape(*folded))}) { 3442 // The type of the named constant is assumed from the expression. 3443 details.set_type(*type); 3444 details.set_init(std::move(*folded)); 3445 details.set_shape(std::move(*shape)); 3446 } else { 3447 Say(at, "The expression must have constant shape"_err_en_US); 3448 } 3449 } else { 3450 Say(at, "The expression must have a known type"_err_en_US); 3451 } 3452 } else { 3453 Say(at, "The expression must be a constant of known type"_err_en_US); 3454 } 3455 } 3456 } else { 3457 // standard-conforming PARAMETER statement (with parentheses) 3458 ApplyImplicitRules(symbol); 3459 Walk(expr); 3460 if (auto converted{EvaluateNonPointerInitializer( 3461 symbol, expr, expr.thing.value().source)}) { 3462 details.set_init(std::move(*converted)); 3463 } 3464 } 3465 return false; 3466 } 3467 bool DeclarationVisitor::Pre(const parser::NamedConstant &x) { 3468 const parser::Name &name{x.v}; 3469 if (!FindSymbol(name)) { 3470 Say(name, "Named constant '%s' not found"_err_en_US); 3471 } else { 3472 CheckUseError(name); 3473 } 3474 return false; 3475 } 3476 3477 bool DeclarationVisitor::Pre(const parser::Enumerator &enumerator) { 3478 const parser::Name &name{std::get<parser::NamedConstant>(enumerator.t).v}; 3479 Symbol *symbol{FindSymbol(name)}; 3480 if (symbol && !symbol->has<UnknownDetails>()) { 3481 // Contrary to named constants appearing in a PARAMETER statement, 3482 // enumerator names should not have their type, dimension or any other 3483 // attributes defined before they are declared in the enumerator statement, 3484 // with the exception of accessibility. 3485 // This is not explicitly forbidden by the standard, but they are scalars 3486 // which type is left for the compiler to chose, so do not let users try to 3487 // tamper with that. 3488 SayAlreadyDeclared(name, *symbol); 3489 symbol = nullptr; 3490 } else { 3491 // Enumerators are treated as PARAMETER (section 7.6 paragraph (4)) 3492 symbol = &MakeSymbol(name, Attrs{Attr::PARAMETER}, ObjectEntityDetails{}); 3493 symbol->SetType(context().MakeNumericType( 3494 TypeCategory::Integer, evaluate::CInteger::kind)); 3495 } 3496 3497 if (auto &init{std::get<std::optional<parser::ScalarIntConstantExpr>>( 3498 enumerator.t)}) { 3499 Walk(*init); // Resolve names in expression before evaluation. 3500 if (auto value{EvaluateInt64(context(), *init)}) { 3501 // Cast all init expressions to C_INT so that they can then be 3502 // safely incremented (see 7.6 Note 2). 3503 enumerationState_.value = static_cast<int>(*value); 3504 } else { 3505 Say(name, 3506 "Enumerator value could not be computed " 3507 "from the given expression"_err_en_US); 3508 // Prevent resolution of next enumerators value 3509 enumerationState_.value = std::nullopt; 3510 } 3511 } 3512 3513 if (symbol) { 3514 if (enumerationState_.value) { 3515 symbol->get<ObjectEntityDetails>().set_init(SomeExpr{ 3516 evaluate::Expr<evaluate::CInteger>{*enumerationState_.value}}); 3517 } else { 3518 context().SetError(*symbol); 3519 } 3520 } 3521 3522 if (enumerationState_.value) { 3523 (*enumerationState_.value)++; 3524 } 3525 return false; 3526 } 3527 3528 void DeclarationVisitor::Post(const parser::EnumDef &) { 3529 enumerationState_ = EnumeratorState{}; 3530 } 3531 3532 bool DeclarationVisitor::Pre(const parser::AccessSpec &x) { 3533 Attr attr{AccessSpecToAttr(x)}; 3534 if (!NonDerivedTypeScope().IsModule()) { // C817 3535 Say(currStmtSource().value(), 3536 "%s attribute may only appear in the specification part of a module"_err_en_US, 3537 EnumToString(attr)); 3538 } 3539 CheckAndSet(attr); 3540 return false; 3541 } 3542 3543 bool DeclarationVisitor::Pre(const parser::AsynchronousStmt &x) { 3544 return HandleAttributeStmt(Attr::ASYNCHRONOUS, x.v); 3545 } 3546 bool DeclarationVisitor::Pre(const parser::ContiguousStmt &x) { 3547 return HandleAttributeStmt(Attr::CONTIGUOUS, x.v); 3548 } 3549 bool DeclarationVisitor::Pre(const parser::ExternalStmt &x) { 3550 HandleAttributeStmt(Attr::EXTERNAL, x.v); 3551 for (const auto &name : x.v) { 3552 auto *symbol{FindSymbol(name)}; 3553 if (!ConvertToProcEntity(*symbol)) { 3554 SayWithDecl( 3555 name, *symbol, "EXTERNAL attribute not allowed on '%s'"_err_en_US); 3556 } else if (symbol->attrs().test(Attr::INTRINSIC)) { // C840 3557 Say(symbol->name(), 3558 "Symbol '%s' cannot have both INTRINSIC and EXTERNAL attributes"_err_en_US, 3559 symbol->name()); 3560 } 3561 } 3562 return false; 3563 } 3564 bool DeclarationVisitor::Pre(const parser::IntentStmt &x) { 3565 auto &intentSpec{std::get<parser::IntentSpec>(x.t)}; 3566 auto &names{std::get<std::list<parser::Name>>(x.t)}; 3567 return CheckNotInBlock("INTENT") && // C1107 3568 HandleAttributeStmt(IntentSpecToAttr(intentSpec), names); 3569 } 3570 bool DeclarationVisitor::Pre(const parser::IntrinsicStmt &x) { 3571 HandleAttributeStmt(Attr::INTRINSIC, x.v); 3572 for (const auto &name : x.v) { 3573 auto &symbol{DEREF(FindSymbol(name))}; 3574 if (!ConvertToProcEntity(symbol)) { 3575 SayWithDecl( 3576 name, symbol, "INTRINSIC attribute not allowed on '%s'"_err_en_US); 3577 } else if (symbol.attrs().test(Attr::EXTERNAL)) { // C840 3578 Say(symbol.name(), 3579 "Symbol '%s' cannot have both EXTERNAL and INTRINSIC attributes"_err_en_US, 3580 symbol.name()); 3581 } else if (symbol.GetType()) { 3582 // These warnings are worded so that they should make sense in either 3583 // order. 3584 Say(symbol.name(), 3585 "Explicit type declaration ignored for intrinsic function '%s'"_en_US, 3586 symbol.name()) 3587 .Attach(name.source, 3588 "INTRINSIC statement for explicitly-typed '%s'"_en_US, 3589 name.source); 3590 } 3591 } 3592 return false; 3593 } 3594 bool DeclarationVisitor::Pre(const parser::OptionalStmt &x) { 3595 return CheckNotInBlock("OPTIONAL") && // C1107 3596 HandleAttributeStmt(Attr::OPTIONAL, x.v); 3597 } 3598 bool DeclarationVisitor::Pre(const parser::ProtectedStmt &x) { 3599 return HandleAttributeStmt(Attr::PROTECTED, x.v); 3600 } 3601 bool DeclarationVisitor::Pre(const parser::ValueStmt &x) { 3602 return CheckNotInBlock("VALUE") && // C1107 3603 HandleAttributeStmt(Attr::VALUE, x.v); 3604 } 3605 bool DeclarationVisitor::Pre(const parser::VolatileStmt &x) { 3606 return HandleAttributeStmt(Attr::VOLATILE, x.v); 3607 } 3608 // Handle a statement that sets an attribute on a list of names. 3609 bool DeclarationVisitor::HandleAttributeStmt( 3610 Attr attr, const std::list<parser::Name> &names) { 3611 for (const auto &name : names) { 3612 HandleAttributeStmt(attr, name); 3613 } 3614 return false; 3615 } 3616 Symbol &DeclarationVisitor::HandleAttributeStmt( 3617 Attr attr, const parser::Name &name) { 3618 if (attr == Attr::INTRINSIC && !IsIntrinsic(name.source, std::nullopt)) { 3619 Say(name.source, "'%s' is not a known intrinsic procedure"_err_en_US); 3620 } 3621 auto *symbol{FindInScope(name)}; 3622 if (attr == Attr::ASYNCHRONOUS || attr == Attr::VOLATILE) { 3623 // these can be set on a symbol that is host-assoc or use-assoc 3624 if (!symbol && 3625 (currScope().kind() == Scope::Kind::Subprogram || 3626 currScope().kind() == Scope::Kind::Block)) { 3627 if (auto *hostSymbol{FindSymbol(name)}) { 3628 symbol = &MakeHostAssocSymbol(name, *hostSymbol); 3629 } 3630 } 3631 } else if (symbol && symbol->has<UseDetails>()) { 3632 Say(currStmtSource().value(), 3633 "Cannot change %s attribute on use-associated '%s'"_err_en_US, 3634 EnumToString(attr), name.source); 3635 return *symbol; 3636 } 3637 if (!symbol) { 3638 symbol = &MakeSymbol(name, EntityDetails{}); 3639 } 3640 symbol->attrs().set(attr); 3641 symbol->attrs() = HandleSaveName(name.source, symbol->attrs()); 3642 return *symbol; 3643 } 3644 // C1107 3645 bool DeclarationVisitor::CheckNotInBlock(const char *stmt) { 3646 if (currScope().kind() == Scope::Kind::Block) { 3647 Say(MessageFormattedText{ 3648 "%s statement is not allowed in a BLOCK construct"_err_en_US, stmt}); 3649 return false; 3650 } else { 3651 return true; 3652 } 3653 } 3654 3655 void DeclarationVisitor::Post(const parser::ObjectDecl &x) { 3656 CHECK(objectDeclAttr_); 3657 const auto &name{std::get<parser::ObjectName>(x.t)}; 3658 DeclareObjectEntity(name, Attrs{*objectDeclAttr_}); 3659 } 3660 3661 // Declare an entity not yet known to be an object or proc. 3662 Symbol &DeclarationVisitor::DeclareUnknownEntity( 3663 const parser::Name &name, Attrs attrs) { 3664 if (!arraySpec().empty() || !coarraySpec().empty()) { 3665 return DeclareObjectEntity(name, attrs); 3666 } else { 3667 Symbol &symbol{DeclareEntity<EntityDetails>(name, attrs)}; 3668 if (auto *type{GetDeclTypeSpec()}) { 3669 SetType(name, *type); 3670 } 3671 charInfo_.length.reset(); 3672 SetBindNameOn(symbol); 3673 if (symbol.attrs().test(Attr::EXTERNAL)) { 3674 ConvertToProcEntity(symbol); 3675 } 3676 return symbol; 3677 } 3678 } 3679 3680 bool DeclarationVisitor::HasCycle( 3681 const Symbol &procSymbol, const ProcInterface &interface) { 3682 OrderedSymbolSet procsInCycle; 3683 procsInCycle.insert(procSymbol); 3684 const ProcInterface *thisInterface{&interface}; 3685 bool haveInterface{true}; 3686 while (haveInterface) { 3687 haveInterface = false; 3688 if (const Symbol * interfaceSymbol{thisInterface->symbol()}) { 3689 if (procsInCycle.count(*interfaceSymbol) > 0) { 3690 for (const auto &procInCycle : procsInCycle) { 3691 Say(procInCycle->name(), 3692 "The interface for procedure '%s' is recursively " 3693 "defined"_err_en_US, 3694 procInCycle->name()); 3695 context().SetError(*procInCycle); 3696 } 3697 return true; 3698 } else if (const auto *procDetails{ 3699 interfaceSymbol->detailsIf<ProcEntityDetails>()}) { 3700 haveInterface = true; 3701 thisInterface = &procDetails->interface(); 3702 procsInCycle.insert(*interfaceSymbol); 3703 } 3704 } 3705 } 3706 return false; 3707 } 3708 3709 Symbol &DeclarationVisitor::DeclareProcEntity( 3710 const parser::Name &name, Attrs attrs, const ProcInterface &interface) { 3711 Symbol &symbol{DeclareEntity<ProcEntityDetails>(name, attrs)}; 3712 if (auto *details{symbol.detailsIf<ProcEntityDetails>()}) { 3713 if (details->IsInterfaceSet()) { 3714 SayWithDecl(name, symbol, 3715 "The interface for procedure '%s' has already been " 3716 "declared"_err_en_US); 3717 context().SetError(symbol); 3718 } else if (HasCycle(symbol, interface)) { 3719 return symbol; 3720 } else if (interface.type()) { 3721 symbol.set(Symbol::Flag::Function); 3722 } else if (interface.symbol()) { 3723 if (interface.symbol()->test(Symbol::Flag::Function)) { 3724 symbol.set(Symbol::Flag::Function); 3725 } else if (interface.symbol()->test(Symbol::Flag::Subroutine)) { 3726 symbol.set(Symbol::Flag::Subroutine); 3727 } 3728 } 3729 details->set_interface(interface); 3730 SetBindNameOn(symbol); 3731 SetPassNameOn(symbol); 3732 } 3733 return symbol; 3734 } 3735 3736 Symbol &DeclarationVisitor::DeclareObjectEntity( 3737 const parser::Name &name, Attrs attrs) { 3738 Symbol &symbol{DeclareEntity<ObjectEntityDetails>(name, attrs)}; 3739 if (auto *details{symbol.detailsIf<ObjectEntityDetails>()}) { 3740 if (auto *type{GetDeclTypeSpec()}) { 3741 SetType(name, *type); 3742 } 3743 if (!arraySpec().empty()) { 3744 if (details->IsArray()) { 3745 if (!context().HasError(symbol)) { 3746 Say(name, 3747 "The dimensions of '%s' have already been declared"_err_en_US); 3748 context().SetError(symbol); 3749 } 3750 } else { 3751 details->set_shape(arraySpec()); 3752 } 3753 } 3754 if (!coarraySpec().empty()) { 3755 if (details->IsCoarray()) { 3756 if (!context().HasError(symbol)) { 3757 Say(name, 3758 "The codimensions of '%s' have already been declared"_err_en_US); 3759 context().SetError(symbol); 3760 } 3761 } else { 3762 details->set_coshape(coarraySpec()); 3763 } 3764 } 3765 SetBindNameOn(symbol); 3766 } 3767 ClearArraySpec(); 3768 ClearCoarraySpec(); 3769 charInfo_.length.reset(); 3770 return symbol; 3771 } 3772 3773 void DeclarationVisitor::Post(const parser::IntegerTypeSpec &x) { 3774 SetDeclTypeSpec(MakeNumericType(TypeCategory::Integer, x.v)); 3775 } 3776 void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::Real &x) { 3777 SetDeclTypeSpec(MakeNumericType(TypeCategory::Real, x.kind)); 3778 } 3779 void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::Complex &x) { 3780 SetDeclTypeSpec(MakeNumericType(TypeCategory::Complex, x.kind)); 3781 } 3782 void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::Logical &x) { 3783 SetDeclTypeSpec(MakeLogicalType(x.kind)); 3784 } 3785 void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::Character &) { 3786 if (!charInfo_.length) { 3787 charInfo_.length = ParamValue{1, common::TypeParamAttr::Len}; 3788 } 3789 if (!charInfo_.kind) { 3790 charInfo_.kind = 3791 KindExpr{context().GetDefaultKind(TypeCategory::Character)}; 3792 } 3793 SetDeclTypeSpec(currScope().MakeCharacterType( 3794 std::move(*charInfo_.length), std::move(*charInfo_.kind))); 3795 charInfo_ = {}; 3796 } 3797 void DeclarationVisitor::Post(const parser::CharSelector::LengthAndKind &x) { 3798 charInfo_.kind = EvaluateSubscriptIntExpr(x.kind); 3799 std::optional<std::int64_t> intKind{ToInt64(charInfo_.kind)}; 3800 if (intKind && 3801 !evaluate::IsValidKindOfIntrinsicType( 3802 TypeCategory::Character, *intKind)) { // C715, C719 3803 Say(currStmtSource().value(), 3804 "KIND value (%jd) not valid for CHARACTER"_err_en_US, *intKind); 3805 charInfo_.kind = std::nullopt; // prevent further errors 3806 } 3807 if (x.length) { 3808 charInfo_.length = GetParamValue(*x.length, common::TypeParamAttr::Len); 3809 } 3810 } 3811 void DeclarationVisitor::Post(const parser::CharLength &x) { 3812 if (const auto *length{std::get_if<std::uint64_t>(&x.u)}) { 3813 charInfo_.length = ParamValue{ 3814 static_cast<ConstantSubscript>(*length), common::TypeParamAttr::Len}; 3815 } else { 3816 charInfo_.length = GetParamValue( 3817 std::get<parser::TypeParamValue>(x.u), common::TypeParamAttr::Len); 3818 } 3819 } 3820 void DeclarationVisitor::Post(const parser::LengthSelector &x) { 3821 if (const auto *param{std::get_if<parser::TypeParamValue>(&x.u)}) { 3822 charInfo_.length = GetParamValue(*param, common::TypeParamAttr::Len); 3823 } 3824 } 3825 3826 bool DeclarationVisitor::Pre(const parser::KindParam &x) { 3827 if (const auto *kind{std::get_if< 3828 parser::Scalar<parser::Integer<parser::Constant<parser::Name>>>>( 3829 &x.u)}) { 3830 const parser::Name &name{kind->thing.thing.thing}; 3831 if (!FindSymbol(name)) { 3832 Say(name, "Parameter '%s' not found"_err_en_US); 3833 } 3834 } 3835 return false; 3836 } 3837 3838 bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Type &) { 3839 CHECK(GetDeclTypeSpecCategory() == DeclTypeSpec::Category::TypeDerived); 3840 return true; 3841 } 3842 3843 void DeclarationVisitor::Post(const parser::DeclarationTypeSpec::Type &type) { 3844 const parser::Name &derivedName{std::get<parser::Name>(type.derived.t)}; 3845 if (const Symbol * derivedSymbol{derivedName.symbol}) { 3846 CheckForAbstractType(*derivedSymbol); // C706 3847 } 3848 } 3849 3850 bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Class &) { 3851 SetDeclTypeSpecCategory(DeclTypeSpec::Category::ClassDerived); 3852 return true; 3853 } 3854 3855 void DeclarationVisitor::Post( 3856 const parser::DeclarationTypeSpec::Class &parsedClass) { 3857 const auto &typeName{std::get<parser::Name>(parsedClass.derived.t)}; 3858 if (auto spec{ResolveDerivedType(typeName)}; 3859 spec && !IsExtensibleType(&*spec)) { // C705 3860 SayWithDecl(typeName, *typeName.symbol, 3861 "Non-extensible derived type '%s' may not be used with CLASS" 3862 " keyword"_err_en_US); 3863 } 3864 } 3865 3866 bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Record &) { 3867 // TODO 3868 return true; 3869 } 3870 3871 void DeclarationVisitor::Post(const parser::DerivedTypeSpec &x) { 3872 const auto &typeName{std::get<parser::Name>(x.t)}; 3873 auto spec{ResolveDerivedType(typeName)}; 3874 if (!spec) { 3875 return; 3876 } 3877 bool seenAnyName{false}; 3878 for (const auto &typeParamSpec : 3879 std::get<std::list<parser::TypeParamSpec>>(x.t)) { 3880 const auto &optKeyword{ 3881 std::get<std::optional<parser::Keyword>>(typeParamSpec.t)}; 3882 std::optional<SourceName> name; 3883 if (optKeyword) { 3884 seenAnyName = true; 3885 name = optKeyword->v.source; 3886 } else if (seenAnyName) { 3887 Say(typeName.source, "Type parameter value must have a name"_err_en_US); 3888 continue; 3889 } 3890 const auto &value{std::get<parser::TypeParamValue>(typeParamSpec.t)}; 3891 // The expressions in a derived type specifier whose values define 3892 // non-defaulted type parameters are evaluated (folded) in the enclosing 3893 // scope. The KIND/LEN distinction is resolved later in 3894 // DerivedTypeSpec::CookParameters(). 3895 ParamValue param{GetParamValue(value, common::TypeParamAttr::Kind)}; 3896 if (!param.isExplicit() || param.GetExplicit()) { 3897 spec->AddRawParamValue(optKeyword, std::move(param)); 3898 } 3899 } 3900 3901 // The DerivedTypeSpec *spec is used initially as a search key. 3902 // If it turns out to have the same name and actual parameter 3903 // value expressions as another DerivedTypeSpec in the current 3904 // scope does, then we'll use that extant spec; otherwise, when this 3905 // spec is distinct from all derived types previously instantiated 3906 // in the current scope, this spec will be moved into that collection. 3907 const auto &dtDetails{spec->typeSymbol().get<DerivedTypeDetails>()}; 3908 auto category{GetDeclTypeSpecCategory()}; 3909 if (dtDetails.isForwardReferenced()) { 3910 DeclTypeSpec &type{currScope().MakeDerivedType(category, std::move(*spec))}; 3911 SetDeclTypeSpec(type); 3912 return; 3913 } 3914 // Normalize parameters to produce a better search key. 3915 spec->CookParameters(GetFoldingContext()); 3916 if (!spec->MightBeParameterized()) { 3917 spec->EvaluateParameters(context()); 3918 } 3919 if (const DeclTypeSpec * 3920 extant{currScope().FindInstantiatedDerivedType(*spec, category)}) { 3921 // This derived type and parameter expressions (if any) are already present 3922 // in this scope. 3923 SetDeclTypeSpec(*extant); 3924 } else { 3925 DeclTypeSpec &type{currScope().MakeDerivedType(category, std::move(*spec))}; 3926 DerivedTypeSpec &derived{type.derivedTypeSpec()}; 3927 if (derived.MightBeParameterized() && 3928 currScope().IsParameterizedDerivedType()) { 3929 // Defer instantiation; use the derived type's definition's scope. 3930 derived.set_scope(DEREF(spec->typeSymbol().scope())); 3931 } else { 3932 auto restorer{ 3933 GetFoldingContext().messages().SetLocation(currStmtSource().value())}; 3934 derived.Instantiate(currScope(), context()); 3935 } 3936 SetDeclTypeSpec(type); 3937 } 3938 // Capture the DerivedTypeSpec in the parse tree for use in building 3939 // structure constructor expressions. 3940 x.derivedTypeSpec = &GetDeclTypeSpec()->derivedTypeSpec(); 3941 } 3942 3943 // The descendents of DerivedTypeDef in the parse tree are visited directly 3944 // in this Pre() routine so that recursive use of the derived type can be 3945 // supported in the components. 3946 bool DeclarationVisitor::Pre(const parser::DerivedTypeDef &x) { 3947 auto &stmt{std::get<parser::Statement<parser::DerivedTypeStmt>>(x.t)}; 3948 Walk(stmt); 3949 Walk(std::get<std::list<parser::Statement<parser::TypeParamDefStmt>>>(x.t)); 3950 auto &scope{currScope()}; 3951 CHECK(scope.symbol()); 3952 CHECK(scope.symbol()->scope() == &scope); 3953 auto &details{scope.symbol()->get<DerivedTypeDetails>()}; 3954 std::set<SourceName> paramNames; 3955 for (auto ¶mName : std::get<std::list<parser::Name>>(stmt.statement.t)) { 3956 details.add_paramName(paramName.source); 3957 auto *symbol{FindInScope(scope, paramName)}; 3958 if (!symbol) { 3959 Say(paramName, 3960 "No definition found for type parameter '%s'"_err_en_US); // C742 3961 // No symbol for a type param. Create one and mark it as containing an 3962 // error to improve subsequent semantic processing 3963 BeginAttrs(); 3964 Symbol *typeParam{MakeTypeSymbol( 3965 paramName, TypeParamDetails{common::TypeParamAttr::Len})}; 3966 context().SetError(*typeParam); 3967 EndAttrs(); 3968 } else if (!symbol->has<TypeParamDetails>()) { 3969 Say2(paramName, "'%s' is not defined as a type parameter"_err_en_US, 3970 *symbol, "Definition of '%s'"_en_US); // C741 3971 } 3972 if (!paramNames.insert(paramName.source).second) { 3973 Say(paramName, 3974 "Duplicate type parameter name: '%s'"_err_en_US); // C731 3975 } 3976 } 3977 for (const auto &[name, symbol] : currScope()) { 3978 if (symbol->has<TypeParamDetails>() && !paramNames.count(name)) { 3979 SayDerivedType(name, 3980 "'%s' is not a type parameter of this derived type"_err_en_US, 3981 currScope()); // C741 3982 } 3983 } 3984 Walk(std::get<std::list<parser::Statement<parser::PrivateOrSequence>>>(x.t)); 3985 const auto &componentDefs{ 3986 std::get<std::list<parser::Statement<parser::ComponentDefStmt>>>(x.t)}; 3987 Walk(componentDefs); 3988 if (derivedTypeInfo_.sequence) { 3989 details.set_sequence(true); 3990 if (componentDefs.empty()) { // C740 3991 Say(stmt.source, 3992 "A sequence type must have at least one component"_err_en_US); 3993 } 3994 if (!details.paramNames().empty()) { // C740 3995 Say(stmt.source, 3996 "A sequence type may not have type parameters"_err_en_US); 3997 } 3998 if (derivedTypeInfo_.extends) { // C735 3999 Say(stmt.source, 4000 "A sequence type may not have the EXTENDS attribute"_err_en_US); 4001 } else { 4002 for (const auto &componentName : details.componentNames()) { 4003 const Symbol *componentSymbol{scope.FindComponent(componentName)}; 4004 if (componentSymbol && componentSymbol->has<ObjectEntityDetails>()) { 4005 const auto &componentDetails{ 4006 componentSymbol->get<ObjectEntityDetails>()}; 4007 const DeclTypeSpec *componentType{componentDetails.type()}; 4008 if (componentType && // C740 4009 !componentType->AsIntrinsic() && 4010 !componentType->IsSequenceType()) { 4011 Say(componentSymbol->name(), 4012 "A sequence type data component must either be of an" 4013 " intrinsic type or a derived sequence type"_err_en_US); 4014 } 4015 } 4016 } 4017 } 4018 } 4019 Walk(std::get<std::optional<parser::TypeBoundProcedurePart>>(x.t)); 4020 Walk(std::get<parser::Statement<parser::EndTypeStmt>>(x.t)); 4021 derivedTypeInfo_ = {}; 4022 PopScope(); 4023 return false; 4024 } 4025 bool DeclarationVisitor::Pre(const parser::DerivedTypeStmt &) { 4026 return BeginAttrs(); 4027 } 4028 void DeclarationVisitor::Post(const parser::DerivedTypeStmt &x) { 4029 auto &name{std::get<parser::Name>(x.t)}; 4030 // Resolve the EXTENDS() clause before creating the derived 4031 // type's symbol to foil attempts to recursively extend a type. 4032 auto *extendsName{derivedTypeInfo_.extends}; 4033 std::optional<DerivedTypeSpec> extendsType{ 4034 ResolveExtendsType(name, extendsName)}; 4035 auto &symbol{MakeSymbol(name, GetAttrs(), DerivedTypeDetails{})}; 4036 symbol.ReplaceName(name.source); 4037 derivedTypeInfo_.type = &symbol; 4038 PushScope(Scope::Kind::DerivedType, &symbol); 4039 if (extendsType) { 4040 // Declare the "parent component"; private if the type is. 4041 // Any symbol stored in the EXTENDS() clause is temporarily 4042 // hidden so that a new symbol can be created for the parent 4043 // component without producing spurious errors about already 4044 // existing. 4045 const Symbol &extendsSymbol{extendsType->typeSymbol()}; 4046 auto restorer{common::ScopedSet(extendsName->symbol, nullptr)}; 4047 if (OkToAddComponent(*extendsName, &extendsSymbol)) { 4048 auto &comp{DeclareEntity<ObjectEntityDetails>(*extendsName, Attrs{})}; 4049 comp.attrs().set( 4050 Attr::PRIVATE, extendsSymbol.attrs().test(Attr::PRIVATE)); 4051 comp.set(Symbol::Flag::ParentComp); 4052 DeclTypeSpec &type{currScope().MakeDerivedType( 4053 DeclTypeSpec::TypeDerived, std::move(*extendsType))}; 4054 type.derivedTypeSpec().set_scope(*extendsSymbol.scope()); 4055 comp.SetType(type); 4056 DerivedTypeDetails &details{symbol.get<DerivedTypeDetails>()}; 4057 details.add_component(comp); 4058 } 4059 } 4060 EndAttrs(); 4061 } 4062 4063 void DeclarationVisitor::Post(const parser::TypeParamDefStmt &x) { 4064 auto *type{GetDeclTypeSpec()}; 4065 auto attr{std::get<common::TypeParamAttr>(x.t)}; 4066 for (auto &decl : std::get<std::list<parser::TypeParamDecl>>(x.t)) { 4067 auto &name{std::get<parser::Name>(decl.t)}; 4068 if (Symbol * symbol{MakeTypeSymbol(name, TypeParamDetails{attr})}) { 4069 SetType(name, *type); 4070 if (auto &init{ 4071 std::get<std::optional<parser::ScalarIntConstantExpr>>(decl.t)}) { 4072 if (auto maybeExpr{EvaluateNonPointerInitializer( 4073 *symbol, *init, init->thing.thing.thing.value().source)}) { 4074 if (auto *intExpr{std::get_if<SomeIntExpr>(&maybeExpr->u)}) { 4075 symbol->get<TypeParamDetails>().set_init(std::move(*intExpr)); 4076 } 4077 } 4078 } 4079 } 4080 } 4081 EndDecl(); 4082 } 4083 bool DeclarationVisitor::Pre(const parser::TypeAttrSpec::Extends &x) { 4084 if (derivedTypeInfo_.extends) { 4085 Say(currStmtSource().value(), 4086 "Attribute 'EXTENDS' cannot be used more than once"_err_en_US); 4087 } else { 4088 derivedTypeInfo_.extends = &x.v; 4089 } 4090 return false; 4091 } 4092 4093 bool DeclarationVisitor::Pre(const parser::PrivateStmt &) { 4094 if (!currScope().parent().IsModule()) { 4095 Say("PRIVATE is only allowed in a derived type that is" 4096 " in a module"_err_en_US); // C766 4097 } else if (derivedTypeInfo_.sawContains) { 4098 derivedTypeInfo_.privateBindings = true; 4099 } else if (!derivedTypeInfo_.privateComps) { 4100 derivedTypeInfo_.privateComps = true; 4101 } else { 4102 Say("PRIVATE may not appear more than once in" 4103 " derived type components"_en_US); // C738 4104 } 4105 return false; 4106 } 4107 bool DeclarationVisitor::Pre(const parser::SequenceStmt &) { 4108 if (derivedTypeInfo_.sequence) { 4109 Say("SEQUENCE may not appear more than once in" 4110 " derived type components"_en_US); // C738 4111 } 4112 derivedTypeInfo_.sequence = true; 4113 return false; 4114 } 4115 void DeclarationVisitor::Post(const parser::ComponentDecl &x) { 4116 const auto &name{std::get<parser::Name>(x.t)}; 4117 auto attrs{GetAttrs()}; 4118 if (derivedTypeInfo_.privateComps && 4119 !attrs.HasAny({Attr::PUBLIC, Attr::PRIVATE})) { 4120 attrs.set(Attr::PRIVATE); 4121 } 4122 if (const auto *declType{GetDeclTypeSpec()}) { 4123 if (const auto *derived{declType->AsDerived()}) { 4124 if (!attrs.HasAny({Attr::POINTER, Attr::ALLOCATABLE})) { 4125 if (derivedTypeInfo_.type == &derived->typeSymbol()) { // C744 4126 Say("Recursive use of the derived type requires " 4127 "POINTER or ALLOCATABLE"_err_en_US); 4128 } 4129 } 4130 if (!coarraySpec().empty()) { // C747 4131 if (IsTeamType(derived)) { 4132 Say("A coarray component may not be of type TEAM_TYPE from " 4133 "ISO_FORTRAN_ENV"_err_en_US); 4134 } else { 4135 if (IsIsoCType(derived)) { 4136 Say("A coarray component may not be of type C_PTR or C_FUNPTR from " 4137 "ISO_C_BINDING"_err_en_US); 4138 } 4139 } 4140 } 4141 if (auto it{FindCoarrayUltimateComponent(*derived)}) { // C748 4142 std::string ultimateName{it.BuildResultDesignatorName()}; 4143 // Strip off the leading "%" 4144 if (ultimateName.length() > 1) { 4145 ultimateName.erase(0, 1); 4146 if (attrs.HasAny({Attr::POINTER, Attr::ALLOCATABLE})) { 4147 evaluate::AttachDeclaration( 4148 Say(name.source, 4149 "A component with a POINTER or ALLOCATABLE attribute may " 4150 "not " 4151 "be of a type with a coarray ultimate component (named " 4152 "'%s')"_err_en_US, 4153 ultimateName), 4154 derived->typeSymbol()); 4155 } 4156 if (!arraySpec().empty() || !coarraySpec().empty()) { 4157 evaluate::AttachDeclaration( 4158 Say(name.source, 4159 "An array or coarray component may not be of a type with a " 4160 "coarray ultimate component (named '%s')"_err_en_US, 4161 ultimateName), 4162 derived->typeSymbol()); 4163 } 4164 } 4165 } 4166 } 4167 } 4168 if (OkToAddComponent(name)) { 4169 auto &symbol{DeclareObjectEntity(name, attrs)}; 4170 if (symbol.has<ObjectEntityDetails>()) { 4171 if (auto &init{std::get<std::optional<parser::Initialization>>(x.t)}) { 4172 Initialization(name, *init, true); 4173 } 4174 } 4175 currScope().symbol()->get<DerivedTypeDetails>().add_component(symbol); 4176 } 4177 ClearArraySpec(); 4178 ClearCoarraySpec(); 4179 } 4180 bool DeclarationVisitor::Pre(const parser::ProcedureDeclarationStmt &) { 4181 CHECK(!interfaceName_); 4182 return BeginDecl(); 4183 } 4184 void DeclarationVisitor::Post(const parser::ProcedureDeclarationStmt &) { 4185 interfaceName_ = nullptr; 4186 EndDecl(); 4187 } 4188 bool DeclarationVisitor::Pre(const parser::DataComponentDefStmt &x) { 4189 // Overrides parse tree traversal so as to handle attributes first, 4190 // so POINTER & ALLOCATABLE enable forward references to derived types. 4191 Walk(std::get<std::list<parser::ComponentAttrSpec>>(x.t)); 4192 set_allowForwardReferenceToDerivedType( 4193 GetAttrs().HasAny({Attr::POINTER, Attr::ALLOCATABLE})); 4194 Walk(std::get<parser::DeclarationTypeSpec>(x.t)); 4195 set_allowForwardReferenceToDerivedType(false); 4196 Walk(std::get<std::list<parser::ComponentDecl>>(x.t)); 4197 return false; 4198 } 4199 bool DeclarationVisitor::Pre(const parser::ProcComponentDefStmt &) { 4200 CHECK(!interfaceName_); 4201 return true; 4202 } 4203 void DeclarationVisitor::Post(const parser::ProcComponentDefStmt &) { 4204 interfaceName_ = nullptr; 4205 } 4206 bool DeclarationVisitor::Pre(const parser::ProcPointerInit &x) { 4207 if (auto *name{std::get_if<parser::Name>(&x.u)}) { 4208 return !NameIsKnownOrIntrinsic(*name); 4209 } 4210 return true; 4211 } 4212 void DeclarationVisitor::Post(const parser::ProcInterface &x) { 4213 if (auto *name{std::get_if<parser::Name>(&x.u)}) { 4214 interfaceName_ = name; 4215 NoteInterfaceName(*name); 4216 } 4217 } 4218 4219 void DeclarationVisitor::Post(const parser::ProcDecl &x) { 4220 const auto &name{std::get<parser::Name>(x.t)}; 4221 ProcInterface interface; 4222 if (interfaceName_) { 4223 interface.set_symbol(*interfaceName_->symbol); 4224 } else if (auto *type{GetDeclTypeSpec()}) { 4225 interface.set_type(*type); 4226 } 4227 auto attrs{HandleSaveName(name.source, GetAttrs())}; 4228 DerivedTypeDetails *dtDetails{nullptr}; 4229 if (Symbol * symbol{currScope().symbol()}) { 4230 dtDetails = symbol->detailsIf<DerivedTypeDetails>(); 4231 } 4232 if (!dtDetails) { 4233 attrs.set(Attr::EXTERNAL); 4234 } 4235 Symbol &symbol{DeclareProcEntity(name, attrs, interface)}; 4236 symbol.ReplaceName(name.source); 4237 if (dtDetails) { 4238 dtDetails->add_component(symbol); 4239 } 4240 } 4241 4242 bool DeclarationVisitor::Pre(const parser::TypeBoundProcedurePart &) { 4243 derivedTypeInfo_.sawContains = true; 4244 return true; 4245 } 4246 4247 // Resolve binding names from type-bound generics, saved in genericBindings_. 4248 void DeclarationVisitor::Post(const parser::TypeBoundProcedurePart &) { 4249 // track specifics seen for the current generic to detect duplicates: 4250 const Symbol *currGeneric{nullptr}; 4251 std::set<SourceName> specifics; 4252 for (const auto &[generic, bindingName] : genericBindings_) { 4253 if (generic != currGeneric) { 4254 currGeneric = generic; 4255 specifics.clear(); 4256 } 4257 auto [it, inserted]{specifics.insert(bindingName->source)}; 4258 if (!inserted) { 4259 Say(*bindingName, // C773 4260 "Binding name '%s' was already specified for generic '%s'"_err_en_US, 4261 bindingName->source, generic->name()) 4262 .Attach(*it, "Previous specification of '%s'"_en_US, *it); 4263 continue; 4264 } 4265 auto *symbol{FindInTypeOrParents(*bindingName)}; 4266 if (!symbol) { 4267 Say(*bindingName, // C772 4268 "Binding name '%s' not found in this derived type"_err_en_US); 4269 } else if (!symbol->has<ProcBindingDetails>()) { 4270 SayWithDecl(*bindingName, *symbol, // C772 4271 "'%s' is not the name of a specific binding of this type"_err_en_US); 4272 } else { 4273 generic->get<GenericDetails>().AddSpecificProc( 4274 *symbol, bindingName->source); 4275 } 4276 } 4277 genericBindings_.clear(); 4278 } 4279 4280 void DeclarationVisitor::Post(const parser::ContainsStmt &) { 4281 if (derivedTypeInfo_.sequence) { 4282 Say("A sequence type may not have a CONTAINS statement"_err_en_US); // C740 4283 } 4284 } 4285 4286 void DeclarationVisitor::Post( 4287 const parser::TypeBoundProcedureStmt::WithoutInterface &x) { 4288 if (GetAttrs().test(Attr::DEFERRED)) { // C783 4289 Say("DEFERRED is only allowed when an interface-name is provided"_err_en_US); 4290 } 4291 for (auto &declaration : x.declarations) { 4292 auto &bindingName{std::get<parser::Name>(declaration.t)}; 4293 auto &optName{std::get<std::optional<parser::Name>>(declaration.t)}; 4294 const parser::Name &procedureName{optName ? *optName : bindingName}; 4295 Symbol *procedure{FindSymbol(procedureName)}; 4296 if (!procedure) { 4297 procedure = NoteInterfaceName(procedureName); 4298 } 4299 if (auto *s{MakeTypeSymbol(bindingName, ProcBindingDetails{*procedure})}) { 4300 SetPassNameOn(*s); 4301 if (GetAttrs().test(Attr::DEFERRED)) { 4302 context().SetError(*s); 4303 } 4304 } 4305 } 4306 } 4307 4308 void DeclarationVisitor::CheckBindings( 4309 const parser::TypeBoundProcedureStmt::WithoutInterface &tbps) { 4310 CHECK(currScope().IsDerivedType()); 4311 for (auto &declaration : tbps.declarations) { 4312 auto &bindingName{std::get<parser::Name>(declaration.t)}; 4313 if (Symbol * binding{FindInScope(bindingName)}) { 4314 if (auto *details{binding->detailsIf<ProcBindingDetails>()}) { 4315 const Symbol *procedure{FindSubprogram(details->symbol())}; 4316 if (!CanBeTypeBoundProc(procedure)) { 4317 if (details->symbol().name() != binding->name()) { 4318 Say(binding->name(), 4319 "The binding of '%s' ('%s') must be either an accessible " 4320 "module procedure or an external procedure with " 4321 "an explicit interface"_err_en_US, 4322 binding->name(), details->symbol().name()); 4323 } else { 4324 Say(binding->name(), 4325 "'%s' must be either an accessible module procedure " 4326 "or an external procedure with an explicit interface"_err_en_US, 4327 binding->name()); 4328 } 4329 context().SetError(*binding); 4330 } 4331 } 4332 } 4333 } 4334 } 4335 4336 void DeclarationVisitor::Post( 4337 const parser::TypeBoundProcedureStmt::WithInterface &x) { 4338 if (!GetAttrs().test(Attr::DEFERRED)) { // C783 4339 Say("DEFERRED is required when an interface-name is provided"_err_en_US); 4340 } 4341 if (Symbol * interface{NoteInterfaceName(x.interfaceName)}) { 4342 for (auto &bindingName : x.bindingNames) { 4343 if (auto *s{ 4344 MakeTypeSymbol(bindingName, ProcBindingDetails{*interface})}) { 4345 SetPassNameOn(*s); 4346 if (!GetAttrs().test(Attr::DEFERRED)) { 4347 context().SetError(*s); 4348 } 4349 } 4350 } 4351 } 4352 } 4353 4354 void DeclarationVisitor::Post(const parser::FinalProcedureStmt &x) { 4355 if (currScope().IsDerivedType() && currScope().symbol()) { 4356 if (auto *details{currScope().symbol()->detailsIf<DerivedTypeDetails>()}) { 4357 for (const auto &subrName : x.v) { 4358 if (const auto *name{ResolveName(subrName)}) { 4359 auto pair{ 4360 details->finals().emplace(name->source, DEREF(name->symbol))}; 4361 if (!pair.second) { // C787 4362 Say(name->source, 4363 "FINAL subroutine '%s' already appeared in this derived type"_err_en_US, 4364 name->source) 4365 .Attach(pair.first->first, 4366 "earlier appearance of this FINAL subroutine"_en_US); 4367 } 4368 } 4369 } 4370 } 4371 } 4372 } 4373 4374 bool DeclarationVisitor::Pre(const parser::TypeBoundGenericStmt &x) { 4375 const auto &accessSpec{std::get<std::optional<parser::AccessSpec>>(x.t)}; 4376 const auto &genericSpec{std::get<Indirection<parser::GenericSpec>>(x.t)}; 4377 const auto &bindingNames{std::get<std::list<parser::Name>>(x.t)}; 4378 auto info{GenericSpecInfo{genericSpec.value()}}; 4379 SourceName symbolName{info.symbolName()}; 4380 bool isPrivate{accessSpec ? accessSpec->v == parser::AccessSpec::Kind::Private 4381 : derivedTypeInfo_.privateBindings}; 4382 auto *genericSymbol{FindInScope(symbolName)}; 4383 if (genericSymbol) { 4384 if (!genericSymbol->has<GenericDetails>()) { 4385 genericSymbol = nullptr; // MakeTypeSymbol will report the error below 4386 } 4387 } else { 4388 // look in parent types: 4389 Symbol *inheritedSymbol{nullptr}; 4390 for (const auto &name : GetAllNames(context(), symbolName)) { 4391 inheritedSymbol = currScope().FindComponent(SourceName{name}); 4392 if (inheritedSymbol) { 4393 break; 4394 } 4395 } 4396 if (inheritedSymbol && inheritedSymbol->has<GenericDetails>()) { 4397 CheckAccessibility(symbolName, isPrivate, *inheritedSymbol); // C771 4398 } 4399 } 4400 if (genericSymbol) { 4401 CheckAccessibility(symbolName, isPrivate, *genericSymbol); // C771 4402 } else { 4403 genericSymbol = MakeTypeSymbol(symbolName, GenericDetails{}); 4404 if (!genericSymbol) { 4405 return false; 4406 } 4407 if (isPrivate) { 4408 genericSymbol->attrs().set(Attr::PRIVATE); 4409 } 4410 } 4411 for (const parser::Name &bindingName : bindingNames) { 4412 genericBindings_.emplace(genericSymbol, &bindingName); 4413 } 4414 info.Resolve(genericSymbol); 4415 return false; 4416 } 4417 4418 bool DeclarationVisitor::Pre(const parser::AllocateStmt &) { 4419 BeginDeclTypeSpec(); 4420 return true; 4421 } 4422 void DeclarationVisitor::Post(const parser::AllocateStmt &) { 4423 EndDeclTypeSpec(); 4424 } 4425 4426 bool DeclarationVisitor::Pre(const parser::StructureConstructor &x) { 4427 auto &parsedType{std::get<parser::DerivedTypeSpec>(x.t)}; 4428 const DeclTypeSpec *type{ProcessTypeSpec(parsedType)}; 4429 if (!type) { 4430 return false; 4431 } 4432 const DerivedTypeSpec *spec{type->AsDerived()}; 4433 const Scope *typeScope{spec ? spec->scope() : nullptr}; 4434 if (!typeScope) { 4435 return false; 4436 } 4437 4438 // N.B C7102 is implicitly enforced by having inaccessible types not 4439 // being found in resolution. 4440 // More constraints are enforced in expression.cpp so that they 4441 // can apply to structure constructors that have been converted 4442 // from misparsed function references. 4443 for (const auto &component : 4444 std::get<std::list<parser::ComponentSpec>>(x.t)) { 4445 // Visit the component spec expression, but not the keyword, since 4446 // we need to resolve its symbol in the scope of the derived type. 4447 Walk(std::get<parser::ComponentDataSource>(component.t)); 4448 if (const auto &kw{std::get<std::optional<parser::Keyword>>(component.t)}) { 4449 FindInTypeOrParents(*typeScope, kw->v); 4450 } 4451 } 4452 return false; 4453 } 4454 4455 bool DeclarationVisitor::Pre(const parser::BasedPointerStmt &x) { 4456 for (const parser::BasedPointer &bp : x.v) { 4457 const parser::ObjectName &pointerName{std::get<0>(bp.t)}; 4458 const parser::ObjectName &pointeeName{std::get<1>(bp.t)}; 4459 auto *pointer{FindSymbol(pointerName)}; 4460 if (!pointer) { 4461 pointer = &MakeSymbol(pointerName, ObjectEntityDetails{}); 4462 } else if (!ConvertToObjectEntity(*pointer) || IsNamedConstant(*pointer)) { 4463 SayWithDecl(pointerName, *pointer, "'%s' is not a variable"_err_en_US); 4464 } else if (pointer->Rank() > 0) { 4465 SayWithDecl(pointerName, *pointer, 4466 "Cray pointer '%s' must be a scalar"_err_en_US); 4467 } else if (pointer->test(Symbol::Flag::CrayPointee)) { 4468 Say(pointerName, 4469 "'%s' cannot be a Cray pointer as it is already a Cray pointee"_err_en_US); 4470 } 4471 pointer->set(Symbol::Flag::CrayPointer); 4472 const DeclTypeSpec &pointerType{MakeNumericType(TypeCategory::Integer, 4473 context().defaultKinds().subscriptIntegerKind())}; 4474 const auto *type{pointer->GetType()}; 4475 if (!type) { 4476 pointer->SetType(pointerType); 4477 } else if (*type != pointerType) { 4478 Say(pointerName.source, "Cray pointer '%s' must have type %s"_err_en_US, 4479 pointerName.source, pointerType.AsFortran()); 4480 } 4481 if (ResolveName(pointeeName)) { 4482 Symbol &pointee{*pointeeName.symbol}; 4483 if (pointee.has<UseDetails>()) { 4484 Say(pointeeName, 4485 "'%s' cannot be a Cray pointee as it is use-associated"_err_en_US); 4486 continue; 4487 } else if (!ConvertToObjectEntity(pointee) || IsNamedConstant(pointee)) { 4488 Say(pointeeName, "'%s' is not a variable"_err_en_US); 4489 continue; 4490 } else if (pointee.test(Symbol::Flag::CrayPointer)) { 4491 Say(pointeeName, 4492 "'%s' cannot be a Cray pointee as it is already a Cray pointer"_err_en_US); 4493 } else if (pointee.test(Symbol::Flag::CrayPointee)) { 4494 Say(pointeeName, 4495 "'%s' was already declared as a Cray pointee"_err_en_US); 4496 } else { 4497 pointee.set(Symbol::Flag::CrayPointee); 4498 } 4499 if (const auto *pointeeType{pointee.GetType()}) { 4500 if (const auto *derived{pointeeType->AsDerived()}) { 4501 if (!derived->typeSymbol().get<DerivedTypeDetails>().sequence()) { 4502 Say(pointeeName, 4503 "Type of Cray pointee '%s' is a non-sequence derived type"_err_en_US); 4504 } 4505 } 4506 } 4507 // process the pointee array-spec, if present 4508 BeginArraySpec(); 4509 Walk(std::get<std::optional<parser::ArraySpec>>(bp.t)); 4510 const auto &spec{arraySpec()}; 4511 if (!spec.empty()) { 4512 auto &details{pointee.get<ObjectEntityDetails>()}; 4513 if (details.shape().empty()) { 4514 details.set_shape(spec); 4515 } else { 4516 SayWithDecl(pointeeName, pointee, 4517 "Array spec was already declared for '%s'"_err_en_US); 4518 } 4519 } 4520 ClearArraySpec(); 4521 currScope().add_crayPointer(pointeeName.source, *pointer); 4522 } 4523 } 4524 return false; 4525 } 4526 4527 bool DeclarationVisitor::Pre(const parser::NamelistStmt::Group &x) { 4528 if (!CheckNotInBlock("NAMELIST")) { // C1107 4529 return false; 4530 } 4531 4532 NamelistDetails details; 4533 for (const auto &name : std::get<std::list<parser::Name>>(x.t)) { 4534 auto *symbol{FindSymbol(name)}; 4535 if (!symbol) { 4536 symbol = &MakeSymbol(name, ObjectEntityDetails{}); 4537 ApplyImplicitRules(*symbol); 4538 } else if (!ConvertToObjectEntity(*symbol)) { 4539 SayWithDecl(name, *symbol, "'%s' is not a variable"_err_en_US); 4540 } 4541 symbol->GetUltimate().set(Symbol::Flag::InNamelist); 4542 details.add_object(*symbol); 4543 } 4544 4545 const auto &groupName{std::get<parser::Name>(x.t)}; 4546 auto *groupSymbol{FindInScope(groupName)}; 4547 if (!groupSymbol || !groupSymbol->has<NamelistDetails>()) { 4548 groupSymbol = &MakeSymbol(groupName, std::move(details)); 4549 groupSymbol->ReplaceName(groupName.source); 4550 } 4551 groupSymbol->get<NamelistDetails>().add_objects(details.objects()); 4552 return false; 4553 } 4554 4555 bool DeclarationVisitor::Pre(const parser::IoControlSpec &x) { 4556 if (const auto *name{std::get_if<parser::Name>(&x.u)}) { 4557 auto *symbol{FindSymbol(*name)}; 4558 if (!symbol) { 4559 Say(*name, "Namelist group '%s' not found"_err_en_US); 4560 } else if (!symbol->GetUltimate().has<NamelistDetails>()) { 4561 SayWithDecl( 4562 *name, *symbol, "'%s' is not the name of a namelist group"_err_en_US); 4563 } 4564 } 4565 return true; 4566 } 4567 4568 bool DeclarationVisitor::Pre(const parser::CommonStmt::Block &x) { 4569 CheckNotInBlock("COMMON"); // C1107 4570 return true; 4571 } 4572 4573 bool DeclarationVisitor::Pre(const parser::CommonBlockObject &) { 4574 BeginArraySpec(); 4575 return true; 4576 } 4577 4578 void DeclarationVisitor::Post(const parser::CommonBlockObject &x) { 4579 const auto &name{std::get<parser::Name>(x.t)}; 4580 DeclareObjectEntity(name); 4581 auto pair{specPartState_.commonBlockObjects.insert(name.source)}; 4582 if (!pair.second) { 4583 const SourceName &prev{*pair.first}; 4584 Say2(name.source, "'%s' is already in a COMMON block"_err_en_US, prev, 4585 "Previous occurrence of '%s' in a COMMON block"_en_US); 4586 } 4587 } 4588 4589 bool DeclarationVisitor::Pre(const parser::EquivalenceStmt &x) { 4590 // save equivalence sets to be processed after specification part 4591 if (CheckNotInBlock("EQUIVALENCE")) { // C1107 4592 for (const std::list<parser::EquivalenceObject> &set : x.v) { 4593 specPartState_.equivalenceSets.push_back(&set); 4594 } 4595 } 4596 return false; // don't implicitly declare names yet 4597 } 4598 4599 void DeclarationVisitor::CheckEquivalenceSets() { 4600 EquivalenceSets equivSets{context()}; 4601 inEquivalenceStmt_ = true; 4602 for (const auto *set : specPartState_.equivalenceSets) { 4603 const auto &source{set->front().v.value().source}; 4604 if (set->size() <= 1) { // R871 4605 Say(source, "Equivalence set must have more than one object"_err_en_US); 4606 } 4607 for (const parser::EquivalenceObject &object : *set) { 4608 const auto &designator{object.v.value()}; 4609 // The designator was not resolved when it was encountered so do it now. 4610 // AnalyzeExpr causes array sections to be changed to substrings as needed 4611 Walk(designator); 4612 if (AnalyzeExpr(context(), designator)) { 4613 equivSets.AddToSet(designator); 4614 } 4615 } 4616 equivSets.FinishSet(source); 4617 } 4618 inEquivalenceStmt_ = false; 4619 for (auto &set : equivSets.sets()) { 4620 if (!set.empty()) { 4621 currScope().add_equivalenceSet(std::move(set)); 4622 } 4623 } 4624 specPartState_.equivalenceSets.clear(); 4625 } 4626 4627 bool DeclarationVisitor::Pre(const parser::SaveStmt &x) { 4628 if (x.v.empty()) { 4629 specPartState_.saveInfo.saveAll = currStmtSource(); 4630 currScope().set_hasSAVE(); 4631 } else { 4632 for (const parser::SavedEntity &y : x.v) { 4633 auto kind{std::get<parser::SavedEntity::Kind>(y.t)}; 4634 const auto &name{std::get<parser::Name>(y.t)}; 4635 if (kind == parser::SavedEntity::Kind::Common) { 4636 MakeCommonBlockSymbol(name); 4637 AddSaveName(specPartState_.saveInfo.commons, name.source); 4638 } else { 4639 HandleAttributeStmt(Attr::SAVE, name); 4640 } 4641 } 4642 } 4643 return false; 4644 } 4645 4646 void DeclarationVisitor::CheckSaveStmts() { 4647 for (const SourceName &name : specPartState_.saveInfo.entities) { 4648 auto *symbol{FindInScope(name)}; 4649 if (!symbol) { 4650 // error was reported 4651 } else if (specPartState_.saveInfo.saveAll) { 4652 // C889 - note that pgi, ifort, xlf do not enforce this constraint 4653 Say2(name, 4654 "Explicit SAVE of '%s' is redundant due to global SAVE statement"_err_en_US, 4655 *specPartState_.saveInfo.saveAll, "Global SAVE statement"_en_US); 4656 } else if (auto msg{CheckSaveAttr(*symbol)}) { 4657 Say(name, std::move(*msg)); 4658 context().SetError(*symbol); 4659 } else { 4660 SetSaveAttr(*symbol); 4661 } 4662 } 4663 for (const SourceName &name : specPartState_.saveInfo.commons) { 4664 if (auto *symbol{currScope().FindCommonBlock(name)}) { 4665 auto &objects{symbol->get<CommonBlockDetails>().objects()}; 4666 if (objects.empty()) { 4667 if (currScope().kind() != Scope::Kind::Block) { 4668 Say(name, 4669 "'%s' appears as a COMMON block in a SAVE statement but not in" 4670 " a COMMON statement"_err_en_US); 4671 } else { // C1108 4672 Say(name, 4673 "SAVE statement in BLOCK construct may not contain a" 4674 " common block name '%s'"_err_en_US); 4675 } 4676 } else { 4677 for (auto &object : symbol->get<CommonBlockDetails>().objects()) { 4678 SetSaveAttr(*object); 4679 } 4680 } 4681 } 4682 } 4683 if (specPartState_.saveInfo.saveAll) { 4684 // Apply SAVE attribute to applicable symbols 4685 for (auto pair : currScope()) { 4686 auto &symbol{*pair.second}; 4687 if (!CheckSaveAttr(symbol)) { 4688 SetSaveAttr(symbol); 4689 } 4690 } 4691 } 4692 specPartState_.saveInfo = {}; 4693 } 4694 4695 // If SAVE attribute can't be set on symbol, return error message. 4696 std::optional<MessageFixedText> DeclarationVisitor::CheckSaveAttr( 4697 const Symbol &symbol) { 4698 if (IsDummy(symbol)) { 4699 return "SAVE attribute may not be applied to dummy argument '%s'"_err_en_US; 4700 } else if (symbol.IsFuncResult()) { 4701 return "SAVE attribute may not be applied to function result '%s'"_err_en_US; 4702 } else if (symbol.has<ProcEntityDetails>() && 4703 !symbol.attrs().test(Attr::POINTER)) { 4704 return "Procedure '%s' with SAVE attribute must also have POINTER attribute"_err_en_US; 4705 } else if (IsAutomatic(symbol)) { 4706 return "SAVE attribute may not be applied to automatic data object '%s'"_err_en_US; 4707 } else { 4708 return std::nullopt; 4709 } 4710 } 4711 4712 // Record SAVEd names in specPartState_.saveInfo.entities. 4713 Attrs DeclarationVisitor::HandleSaveName(const SourceName &name, Attrs attrs) { 4714 if (attrs.test(Attr::SAVE)) { 4715 AddSaveName(specPartState_.saveInfo.entities, name); 4716 } 4717 return attrs; 4718 } 4719 4720 // Record a name in a set of those to be saved. 4721 void DeclarationVisitor::AddSaveName( 4722 std::set<SourceName> &set, const SourceName &name) { 4723 auto pair{set.insert(name)}; 4724 if (!pair.second) { 4725 Say2(name, "SAVE attribute was already specified on '%s'"_err_en_US, 4726 *pair.first, "Previous specification of SAVE attribute"_en_US); 4727 } 4728 } 4729 4730 // Set the SAVE attribute on symbol unless it is implicitly saved anyway. 4731 void DeclarationVisitor::SetSaveAttr(Symbol &symbol) { 4732 if (!IsSaved(symbol)) { 4733 symbol.attrs().set(Attr::SAVE); 4734 } 4735 } 4736 4737 // Check types of common block objects, now that they are known. 4738 void DeclarationVisitor::CheckCommonBlocks() { 4739 // check for empty common blocks 4740 for (const auto &pair : currScope().commonBlocks()) { 4741 const auto &symbol{*pair.second}; 4742 if (symbol.get<CommonBlockDetails>().objects().empty() && 4743 symbol.attrs().test(Attr::BIND_C)) { 4744 Say(symbol.name(), 4745 "'%s' appears as a COMMON block in a BIND statement but not in" 4746 " a COMMON statement"_err_en_US); 4747 } 4748 } 4749 // check objects in common blocks 4750 for (const auto &name : specPartState_.commonBlockObjects) { 4751 const auto *symbol{currScope().FindSymbol(name)}; 4752 if (!symbol) { 4753 continue; 4754 } 4755 const auto &attrs{symbol->attrs()}; 4756 if (attrs.test(Attr::ALLOCATABLE)) { 4757 Say(name, 4758 "ALLOCATABLE object '%s' may not appear in a COMMON block"_err_en_US); 4759 } else if (attrs.test(Attr::BIND_C)) { 4760 Say(name, 4761 "Variable '%s' with BIND attribute may not appear in a COMMON block"_err_en_US); 4762 } else if (IsDummy(*symbol)) { 4763 Say(name, 4764 "Dummy argument '%s' may not appear in a COMMON block"_err_en_US); 4765 } else if (symbol->IsFuncResult()) { 4766 Say(name, 4767 "Function result '%s' may not appear in a COMMON block"_err_en_US); 4768 } else if (const DeclTypeSpec * type{symbol->GetType()}) { 4769 if (type->category() == DeclTypeSpec::ClassStar) { 4770 Say(name, 4771 "Unlimited polymorphic pointer '%s' may not appear in a COMMON block"_err_en_US); 4772 } else if (const auto *derived{type->AsDerived()}) { 4773 auto &typeSymbol{derived->typeSymbol()}; 4774 if (!typeSymbol.attrs().test(Attr::BIND_C) && 4775 !typeSymbol.get<DerivedTypeDetails>().sequence()) { 4776 Say(name, 4777 "Derived type '%s' in COMMON block must have the BIND or" 4778 " SEQUENCE attribute"_err_en_US); 4779 } 4780 CheckCommonBlockDerivedType(name, typeSymbol); 4781 } 4782 } 4783 } 4784 specPartState_.commonBlockObjects = {}; 4785 } 4786 4787 Symbol &DeclarationVisitor::MakeCommonBlockSymbol(const parser::Name &name) { 4788 return Resolve(name, currScope().MakeCommonBlock(name.source)); 4789 } 4790 Symbol &DeclarationVisitor::MakeCommonBlockSymbol( 4791 const std::optional<parser::Name> &name) { 4792 if (name) { 4793 return MakeCommonBlockSymbol(*name); 4794 } else { 4795 return MakeCommonBlockSymbol(parser::Name{}); 4796 } 4797 } 4798 4799 bool DeclarationVisitor::NameIsKnownOrIntrinsic(const parser::Name &name) { 4800 return FindSymbol(name) || HandleUnrestrictedSpecificIntrinsicFunction(name); 4801 } 4802 4803 // Check if this derived type can be in a COMMON block. 4804 void DeclarationVisitor::CheckCommonBlockDerivedType( 4805 const SourceName &name, const Symbol &typeSymbol) { 4806 if (const auto *scope{typeSymbol.scope()}) { 4807 for (const auto &pair : *scope) { 4808 const Symbol &component{*pair.second}; 4809 if (component.attrs().test(Attr::ALLOCATABLE)) { 4810 Say2(name, 4811 "Derived type variable '%s' may not appear in a COMMON block" 4812 " due to ALLOCATABLE component"_err_en_US, 4813 component.name(), "Component with ALLOCATABLE attribute"_en_US); 4814 return; 4815 } 4816 if (const auto *details{component.detailsIf<ObjectEntityDetails>()}) { 4817 if (details->init()) { 4818 Say2(name, 4819 "Derived type variable '%s' may not appear in a COMMON block" 4820 " due to component with default initialization"_err_en_US, 4821 component.name(), "Component with default initialization"_en_US); 4822 return; 4823 } 4824 if (const auto *type{details->type()}) { 4825 if (const auto *derived{type->AsDerived()}) { 4826 CheckCommonBlockDerivedType(name, derived->typeSymbol()); 4827 } 4828 } 4829 } 4830 } 4831 } 4832 } 4833 4834 bool DeclarationVisitor::HandleUnrestrictedSpecificIntrinsicFunction( 4835 const parser::Name &name) { 4836 if (auto interface{context().intrinsics().IsSpecificIntrinsicFunction( 4837 name.source.ToString())}) { 4838 // Unrestricted specific intrinsic function names (e.g., "cos") 4839 // are acceptable as procedure interfaces. 4840 Symbol &symbol{ 4841 MakeSymbol(InclusiveScope(), name.source, Attrs{Attr::INTRINSIC})}; 4842 symbol.set_details(ProcEntityDetails{}); 4843 symbol.set(Symbol::Flag::Function); 4844 if (interface->IsElemental()) { 4845 symbol.attrs().set(Attr::ELEMENTAL); 4846 } 4847 if (interface->IsPure()) { 4848 symbol.attrs().set(Attr::PURE); 4849 } 4850 Resolve(name, symbol); 4851 return true; 4852 } else { 4853 return false; 4854 } 4855 } 4856 4857 // Checks for all locality-specs: LOCAL, LOCAL_INIT, and SHARED 4858 bool DeclarationVisitor::PassesSharedLocalityChecks( 4859 const parser::Name &name, Symbol &symbol) { 4860 if (!IsVariableName(symbol)) { 4861 SayLocalMustBeVariable(name, symbol); // C1124 4862 return false; 4863 } 4864 if (symbol.owner() == currScope()) { // C1125 and C1126 4865 SayAlreadyDeclared(name, symbol); 4866 return false; 4867 } 4868 return true; 4869 } 4870 4871 // Checks for locality-specs LOCAL and LOCAL_INIT 4872 bool DeclarationVisitor::PassesLocalityChecks( 4873 const parser::Name &name, Symbol &symbol) { 4874 if (IsAllocatable(symbol)) { // C1128 4875 SayWithDecl(name, symbol, 4876 "ALLOCATABLE variable '%s' not allowed in a locality-spec"_err_en_US); 4877 return false; 4878 } 4879 if (IsOptional(symbol)) { // C1128 4880 SayWithDecl(name, symbol, 4881 "OPTIONAL argument '%s' not allowed in a locality-spec"_err_en_US); 4882 return false; 4883 } 4884 if (IsIntentIn(symbol)) { // C1128 4885 SayWithDecl(name, symbol, 4886 "INTENT IN argument '%s' not allowed in a locality-spec"_err_en_US); 4887 return false; 4888 } 4889 if (IsFinalizable(symbol)) { // C1128 4890 SayWithDecl(name, symbol, 4891 "Finalizable variable '%s' not allowed in a locality-spec"_err_en_US); 4892 return false; 4893 } 4894 if (IsCoarray(symbol)) { // C1128 4895 SayWithDecl( 4896 name, symbol, "Coarray '%s' not allowed in a locality-spec"_err_en_US); 4897 return false; 4898 } 4899 if (const DeclTypeSpec * type{symbol.GetType()}) { 4900 if (type->IsPolymorphic() && IsDummy(symbol) && 4901 !IsPointer(symbol)) { // C1128 4902 SayWithDecl(name, symbol, 4903 "Nonpointer polymorphic argument '%s' not allowed in a " 4904 "locality-spec"_err_en_US); 4905 return false; 4906 } 4907 } 4908 if (IsAssumedSizeArray(symbol)) { // C1128 4909 SayWithDecl(name, symbol, 4910 "Assumed size array '%s' not allowed in a locality-spec"_err_en_US); 4911 return false; 4912 } 4913 if (std::optional<MessageFixedText> msg{ 4914 WhyNotModifiable(symbol, currScope())}) { 4915 SayWithReason(name, symbol, 4916 "'%s' may not appear in a locality-spec because it is not " 4917 "definable"_err_en_US, 4918 std::move(*msg)); 4919 return false; 4920 } 4921 return PassesSharedLocalityChecks(name, symbol); 4922 } 4923 4924 Symbol &DeclarationVisitor::FindOrDeclareEnclosingEntity( 4925 const parser::Name &name) { 4926 Symbol *prev{FindSymbol(name)}; 4927 if (!prev) { 4928 // Declare the name as an object in the enclosing scope so that 4929 // the name can't be repurposed there later as something else. 4930 prev = &MakeSymbol(InclusiveScope(), name.source, Attrs{}); 4931 ConvertToObjectEntity(*prev); 4932 ApplyImplicitRules(*prev); 4933 } 4934 return *prev; 4935 } 4936 4937 Symbol *DeclarationVisitor::DeclareLocalEntity(const parser::Name &name) { 4938 Symbol &prev{FindOrDeclareEnclosingEntity(name)}; 4939 if (!PassesLocalityChecks(name, prev)) { 4940 return nullptr; 4941 } 4942 return &MakeHostAssocSymbol(name, prev); 4943 } 4944 4945 Symbol *DeclarationVisitor::DeclareStatementEntity(const parser::Name &name, 4946 const std::optional<parser::IntegerTypeSpec> &type) { 4947 const DeclTypeSpec *declTypeSpec{nullptr}; 4948 if (auto *prev{FindSymbol(name)}) { 4949 if (prev->owner() == currScope()) { 4950 SayAlreadyDeclared(name, *prev); 4951 return nullptr; 4952 } 4953 name.symbol = nullptr; 4954 declTypeSpec = prev->GetType(); 4955 } 4956 Symbol &symbol{DeclareEntity<ObjectEntityDetails>(name, {})}; 4957 if (!symbol.has<ObjectEntityDetails>()) { 4958 return nullptr; // error was reported in DeclareEntity 4959 } 4960 if (type) { 4961 declTypeSpec = ProcessTypeSpec(*type); 4962 } 4963 if (declTypeSpec) { 4964 // Subtlety: Don't let a "*length" specifier (if any is pending) affect the 4965 // declaration of this implied DO loop control variable. 4966 auto restorer{ 4967 common::ScopedSet(charInfo_.length, std::optional<ParamValue>{})}; 4968 SetType(name, *declTypeSpec); 4969 } else { 4970 ApplyImplicitRules(symbol); 4971 } 4972 return Resolve(name, &symbol); 4973 } 4974 4975 // Set the type of an entity or report an error. 4976 void DeclarationVisitor::SetType( 4977 const parser::Name &name, const DeclTypeSpec &type) { 4978 CHECK(name.symbol); 4979 auto &symbol{*name.symbol}; 4980 if (charInfo_.length) { // Declaration has "*length" (R723) 4981 auto length{std::move(*charInfo_.length)}; 4982 charInfo_.length.reset(); 4983 if (type.category() == DeclTypeSpec::Character) { 4984 auto kind{type.characterTypeSpec().kind()}; 4985 // Recurse with correct type. 4986 SetType(name, 4987 currScope().MakeCharacterType(std::move(length), std::move(kind))); 4988 return; 4989 } else { // C753 4990 Say(name, 4991 "A length specifier cannot be used to declare the non-character entity '%s'"_err_en_US); 4992 } 4993 } 4994 auto *prevType{symbol.GetType()}; 4995 if (!prevType) { 4996 symbol.SetType(type); 4997 } else if (symbol.has<UseDetails>()) { 4998 // error recovery case, redeclaration of use-associated name 4999 } else if (HadForwardRef(symbol)) { 5000 // error recovery after use of host-associated name 5001 } else if (!symbol.test(Symbol::Flag::Implicit)) { 5002 SayWithDecl( 5003 name, symbol, "The type of '%s' has already been declared"_err_en_US); 5004 context().SetError(symbol); 5005 } else if (type != *prevType) { 5006 SayWithDecl(name, symbol, 5007 "The type of '%s' has already been implicitly declared"_err_en_US); 5008 context().SetError(symbol); 5009 } else { 5010 symbol.set(Symbol::Flag::Implicit, false); 5011 } 5012 } 5013 5014 std::optional<DerivedTypeSpec> DeclarationVisitor::ResolveDerivedType( 5015 const parser::Name &name) { 5016 Symbol *symbol{FindSymbol(NonDerivedTypeScope(), name)}; 5017 if (!symbol || symbol->has<UnknownDetails>()) { 5018 if (allowForwardReferenceToDerivedType()) { 5019 if (!symbol) { 5020 symbol = &MakeSymbol(InclusiveScope(), name.source, Attrs{}); 5021 Resolve(name, *symbol); 5022 }; 5023 DerivedTypeDetails details; 5024 details.set_isForwardReferenced(); 5025 symbol->set_details(std::move(details)); 5026 } else { // C732 5027 Say(name, "Derived type '%s' not found"_err_en_US); 5028 return std::nullopt; 5029 } 5030 } 5031 if (CheckUseError(name)) { 5032 return std::nullopt; 5033 } 5034 symbol = &symbol->GetUltimate(); 5035 if (auto *details{symbol->detailsIf<GenericDetails>()}) { 5036 if (details->derivedType()) { 5037 symbol = details->derivedType(); 5038 } 5039 } 5040 if (symbol->has<DerivedTypeDetails>()) { 5041 return DerivedTypeSpec{name.source, *symbol}; 5042 } else { 5043 Say(name, "'%s' is not a derived type"_err_en_US); 5044 return std::nullopt; 5045 } 5046 } 5047 5048 std::optional<DerivedTypeSpec> DeclarationVisitor::ResolveExtendsType( 5049 const parser::Name &typeName, const parser::Name *extendsName) { 5050 if (!extendsName) { 5051 return std::nullopt; 5052 } else if (typeName.source == extendsName->source) { 5053 Say(extendsName->source, 5054 "Derived type '%s' cannot extend itself"_err_en_US); 5055 return std::nullopt; 5056 } else { 5057 return ResolveDerivedType(*extendsName); 5058 } 5059 } 5060 5061 Symbol *DeclarationVisitor::NoteInterfaceName(const parser::Name &name) { 5062 // The symbol is checked later by CheckExplicitInterface() and 5063 // CheckBindings(). It can be a forward reference. 5064 if (!NameIsKnownOrIntrinsic(name)) { 5065 Symbol &symbol{MakeSymbol(InclusiveScope(), name.source, Attrs{})}; 5066 Resolve(name, symbol); 5067 } 5068 return name.symbol; 5069 } 5070 5071 void DeclarationVisitor::CheckExplicitInterface(const parser::Name &name) { 5072 if (const Symbol * symbol{name.symbol}) { 5073 if (!context().HasError(*symbol) && !symbol->HasExplicitInterface()) { 5074 Say(name, 5075 "'%s' must be an abstract interface or a procedure with " 5076 "an explicit interface"_err_en_US, 5077 symbol->name()); 5078 } 5079 } 5080 } 5081 5082 // Create a symbol for a type parameter, component, or procedure binding in 5083 // the current derived type scope. Return false on error. 5084 Symbol *DeclarationVisitor::MakeTypeSymbol( 5085 const parser::Name &name, Details &&details) { 5086 return Resolve(name, MakeTypeSymbol(name.source, std::move(details))); 5087 } 5088 Symbol *DeclarationVisitor::MakeTypeSymbol( 5089 const SourceName &name, Details &&details) { 5090 Scope &derivedType{currScope()}; 5091 CHECK(derivedType.IsDerivedType()); 5092 if (auto *symbol{FindInScope(derivedType, name)}) { // C742 5093 Say2(name, 5094 "Type parameter, component, or procedure binding '%s'" 5095 " already defined in this type"_err_en_US, 5096 *symbol, "Previous definition of '%s'"_en_US); 5097 return nullptr; 5098 } else { 5099 auto attrs{GetAttrs()}; 5100 // Apply binding-private-stmt if present and this is a procedure binding 5101 if (derivedTypeInfo_.privateBindings && 5102 !attrs.HasAny({Attr::PUBLIC, Attr::PRIVATE}) && 5103 std::holds_alternative<ProcBindingDetails>(details)) { 5104 attrs.set(Attr::PRIVATE); 5105 } 5106 Symbol &result{MakeSymbol(name, attrs, std::move(details))}; 5107 if (result.has<TypeParamDetails>()) { 5108 derivedType.symbol()->get<DerivedTypeDetails>().add_paramDecl(result); 5109 } 5110 return &result; 5111 } 5112 } 5113 5114 // Return true if it is ok to declare this component in the current scope. 5115 // Otherwise, emit an error and return false. 5116 bool DeclarationVisitor::OkToAddComponent( 5117 const parser::Name &name, const Symbol *extends) { 5118 for (const Scope *scope{&currScope()}; scope;) { 5119 CHECK(scope->IsDerivedType()); 5120 if (auto *prev{FindInScope(*scope, name)}) { 5121 if (!context().HasError(*prev)) { 5122 auto msg{""_en_US}; 5123 if (extends) { 5124 msg = "Type cannot be extended as it has a component named" 5125 " '%s'"_err_en_US; 5126 } else if (prev->test(Symbol::Flag::ParentComp)) { 5127 msg = "'%s' is a parent type of this type and so cannot be" 5128 " a component"_err_en_US; 5129 } else if (scope != &currScope()) { 5130 msg = "Component '%s' is already declared in a parent of this" 5131 " derived type"_err_en_US; 5132 } else { 5133 msg = "Component '%s' is already declared in this" 5134 " derived type"_err_en_US; 5135 } 5136 Say2(name, std::move(msg), *prev, "Previous declaration of '%s'"_en_US); 5137 } 5138 return false; 5139 } 5140 if (scope == &currScope() && extends) { 5141 // The parent component has not yet been added to the scope. 5142 scope = extends->scope(); 5143 } else { 5144 scope = scope->GetDerivedTypeParent(); 5145 } 5146 } 5147 return true; 5148 } 5149 5150 ParamValue DeclarationVisitor::GetParamValue( 5151 const parser::TypeParamValue &x, common::TypeParamAttr attr) { 5152 return std::visit( 5153 common::visitors{ 5154 [=](const parser::ScalarIntExpr &x) { // C704 5155 return ParamValue{EvaluateIntExpr(x), attr}; 5156 }, 5157 [=](const parser::Star &) { return ParamValue::Assumed(attr); }, 5158 [=](const parser::TypeParamValue::Deferred &) { 5159 return ParamValue::Deferred(attr); 5160 }, 5161 }, 5162 x.u); 5163 } 5164 5165 // ConstructVisitor implementation 5166 5167 void ConstructVisitor::ResolveIndexName( 5168 const parser::ConcurrentControl &control) { 5169 const parser::Name &name{std::get<parser::Name>(control.t)}; 5170 auto *prev{FindSymbol(name)}; 5171 if (prev) { 5172 if (prev->owner().kind() == Scope::Kind::Forall || 5173 prev->owner() == currScope()) { 5174 SayAlreadyDeclared(name, *prev); 5175 return; 5176 } 5177 name.symbol = nullptr; 5178 } 5179 auto &symbol{DeclareObjectEntity(name)}; 5180 if (symbol.GetType()) { 5181 // type came from explicit type-spec 5182 } else if (!prev) { 5183 ApplyImplicitRules(symbol); 5184 } else { 5185 const Symbol &prevRoot{ResolveAssociations(*prev)}; 5186 // prev could be host- use- or construct-associated with another symbol 5187 if (!prevRoot.has<ObjectEntityDetails>() && 5188 !prevRoot.has<EntityDetails>()) { 5189 Say2(name, "Index name '%s' conflicts with existing identifier"_err_en_US, 5190 *prev, "Previous declaration of '%s'"_en_US); 5191 return; 5192 } else { 5193 if (const auto *type{prevRoot.GetType()}) { 5194 symbol.SetType(*type); 5195 } 5196 if (prevRoot.IsObjectArray()) { 5197 SayWithDecl(name, *prev, "Index variable '%s' is not scalar"_err_en_US); 5198 return; 5199 } 5200 } 5201 } 5202 EvaluateExpr(parser::Scalar{parser::Integer{common::Clone(name)}}); 5203 } 5204 5205 // We need to make sure that all of the index-names get declared before the 5206 // expressions in the loop control are evaluated so that references to the 5207 // index-names in the expressions are correctly detected. 5208 bool ConstructVisitor::Pre(const parser::ConcurrentHeader &header) { 5209 BeginDeclTypeSpec(); 5210 Walk(std::get<std::optional<parser::IntegerTypeSpec>>(header.t)); 5211 const auto &controls{ 5212 std::get<std::list<parser::ConcurrentControl>>(header.t)}; 5213 for (const auto &control : controls) { 5214 ResolveIndexName(control); 5215 } 5216 Walk(controls); 5217 Walk(std::get<std::optional<parser::ScalarLogicalExpr>>(header.t)); 5218 EndDeclTypeSpec(); 5219 return false; 5220 } 5221 5222 bool ConstructVisitor::Pre(const parser::LocalitySpec::Local &x) { 5223 for (auto &name : x.v) { 5224 if (auto *symbol{DeclareLocalEntity(name)}) { 5225 symbol->set(Symbol::Flag::LocalityLocal); 5226 } 5227 } 5228 return false; 5229 } 5230 5231 bool ConstructVisitor::Pre(const parser::LocalitySpec::LocalInit &x) { 5232 for (auto &name : x.v) { 5233 if (auto *symbol{DeclareLocalEntity(name)}) { 5234 symbol->set(Symbol::Flag::LocalityLocalInit); 5235 } 5236 } 5237 return false; 5238 } 5239 5240 bool ConstructVisitor::Pre(const parser::LocalitySpec::Shared &x) { 5241 for (const auto &name : x.v) { 5242 if (!FindSymbol(name)) { 5243 Say(name, "Variable '%s' with SHARED locality implicitly declared"_en_US); 5244 } 5245 Symbol &prev{FindOrDeclareEnclosingEntity(name)}; 5246 if (PassesSharedLocalityChecks(name, prev)) { 5247 MakeHostAssocSymbol(name, prev).set(Symbol::Flag::LocalityShared); 5248 } 5249 } 5250 return false; 5251 } 5252 5253 bool ConstructVisitor::Pre(const parser::AcSpec &x) { 5254 ProcessTypeSpec(x.type); 5255 PushScope(Scope::Kind::ImpliedDos, nullptr); 5256 Walk(x.values); 5257 PopScope(); 5258 return false; 5259 } 5260 5261 // Section 19.4, paragraph 5 says that each ac-do-variable has the scope of the 5262 // enclosing ac-implied-do 5263 bool ConstructVisitor::Pre(const parser::AcImpliedDo &x) { 5264 auto &values{std::get<std::list<parser::AcValue>>(x.t)}; 5265 auto &control{std::get<parser::AcImpliedDoControl>(x.t)}; 5266 auto &type{std::get<std::optional<parser::IntegerTypeSpec>>(control.t)}; 5267 auto &bounds{std::get<parser::AcImpliedDoControl::Bounds>(control.t)}; 5268 PushScope(Scope::Kind::ImpliedDos, nullptr); 5269 DeclareStatementEntity(bounds.name.thing.thing, type); 5270 Walk(bounds); 5271 Walk(values); 5272 PopScope(); 5273 return false; 5274 } 5275 5276 bool ConstructVisitor::Pre(const parser::DataImpliedDo &x) { 5277 auto &objects{std::get<std::list<parser::DataIDoObject>>(x.t)}; 5278 auto &type{std::get<std::optional<parser::IntegerTypeSpec>>(x.t)}; 5279 auto &bounds{std::get<parser::DataImpliedDo::Bounds>(x.t)}; 5280 DeclareStatementEntity(bounds.name.thing.thing, type); 5281 Walk(bounds); 5282 Walk(objects); 5283 return false; 5284 } 5285 5286 // Sets InDataStmt flag on a variable (or misidentified function) in a DATA 5287 // statement so that the predicate IsStaticallyInitialized() will be true 5288 // during semantic analysis before the symbol's initializer is constructed. 5289 bool ConstructVisitor::Pre(const parser::DataIDoObject &x) { 5290 std::visit( 5291 common::visitors{ 5292 [&](const parser::Scalar<Indirection<parser::Designator>> &y) { 5293 Walk(y.thing.value()); 5294 const parser::Name &first{parser::GetFirstName(y.thing.value())}; 5295 if (first.symbol) { 5296 first.symbol->set(Symbol::Flag::InDataStmt); 5297 } 5298 }, 5299 [&](const Indirection<parser::DataImpliedDo> &y) { Walk(y.value()); }, 5300 }, 5301 x.u); 5302 return false; 5303 } 5304 5305 bool ConstructVisitor::Pre(const parser::DataStmtObject &x) { 5306 std::visit(common::visitors{ 5307 [&](const Indirection<parser::Variable> &y) { 5308 Walk(y.value()); 5309 const parser::Name &first{parser::GetFirstName(y.value())}; 5310 if (first.symbol) { 5311 first.symbol->set(Symbol::Flag::InDataStmt); 5312 } 5313 }, 5314 [&](const parser::DataImpliedDo &y) { 5315 PushScope(Scope::Kind::ImpliedDos, nullptr); 5316 Walk(y); 5317 PopScope(); 5318 }, 5319 }, 5320 x.u); 5321 return false; 5322 } 5323 5324 bool ConstructVisitor::Pre(const parser::DataStmtValue &x) { 5325 const auto &data{std::get<parser::DataStmtConstant>(x.t)}; 5326 auto &mutableData{const_cast<parser::DataStmtConstant &>(data)}; 5327 if (auto *elem{parser::Unwrap<parser::ArrayElement>(mutableData)}) { 5328 if (const auto *name{std::get_if<parser::Name>(&elem->base.u)}) { 5329 if (const Symbol * symbol{FindSymbol(*name)}) { 5330 const Symbol &ultimate{symbol->GetUltimate()}; 5331 if (ultimate.has<DerivedTypeDetails>()) { 5332 mutableData.u = elem->ConvertToStructureConstructor( 5333 DerivedTypeSpec{name->source, ultimate}); 5334 } 5335 } 5336 } 5337 } 5338 return true; 5339 } 5340 5341 bool ConstructVisitor::Pre(const parser::DoConstruct &x) { 5342 if (x.IsDoConcurrent()) { 5343 PushScope(Scope::Kind::Block, nullptr); 5344 } 5345 return true; 5346 } 5347 void ConstructVisitor::Post(const parser::DoConstruct &x) { 5348 if (x.IsDoConcurrent()) { 5349 PopScope(); 5350 } 5351 } 5352 5353 bool ConstructVisitor::Pre(const parser::ForallConstruct &) { 5354 PushScope(Scope::Kind::Forall, nullptr); 5355 return true; 5356 } 5357 void ConstructVisitor::Post(const parser::ForallConstruct &) { PopScope(); } 5358 bool ConstructVisitor::Pre(const parser::ForallStmt &) { 5359 PushScope(Scope::Kind::Forall, nullptr); 5360 return true; 5361 } 5362 void ConstructVisitor::Post(const parser::ForallStmt &) { PopScope(); } 5363 5364 bool ConstructVisitor::Pre(const parser::BlockStmt &x) { 5365 CheckDef(x.v); 5366 PushScope(Scope::Kind::Block, nullptr); 5367 return false; 5368 } 5369 bool ConstructVisitor::Pre(const parser::EndBlockStmt &x) { 5370 PopScope(); 5371 CheckRef(x.v); 5372 return false; 5373 } 5374 5375 void ConstructVisitor::Post(const parser::Selector &x) { 5376 GetCurrentAssociation().selector = ResolveSelector(x); 5377 } 5378 5379 void ConstructVisitor::Post(const parser::AssociateStmt &x) { 5380 CheckDef(x.t); 5381 PushScope(Scope::Kind::Block, nullptr); 5382 const auto assocCount{std::get<std::list<parser::Association>>(x.t).size()}; 5383 for (auto nthLastAssoc{assocCount}; nthLastAssoc > 0; --nthLastAssoc) { 5384 SetCurrentAssociation(nthLastAssoc); 5385 if (auto *symbol{MakeAssocEntity()}) { 5386 if (ExtractCoarrayRef(GetCurrentAssociation().selector.expr)) { // C1103 5387 Say("Selector must not be a coindexed object"_err_en_US); 5388 } 5389 SetTypeFromAssociation(*symbol); 5390 SetAttrsFromAssociation(*symbol); 5391 } 5392 } 5393 PopAssociation(assocCount); 5394 } 5395 5396 void ConstructVisitor::Post(const parser::EndAssociateStmt &x) { 5397 PopScope(); 5398 CheckRef(x.v); 5399 } 5400 5401 bool ConstructVisitor::Pre(const parser::Association &x) { 5402 PushAssociation(); 5403 const auto &name{std::get<parser::Name>(x.t)}; 5404 GetCurrentAssociation().name = &name; 5405 return true; 5406 } 5407 5408 bool ConstructVisitor::Pre(const parser::ChangeTeamStmt &x) { 5409 CheckDef(x.t); 5410 PushScope(Scope::Kind::Block, nullptr); 5411 PushAssociation(); 5412 return true; 5413 } 5414 5415 void ConstructVisitor::Post(const parser::CoarrayAssociation &x) { 5416 const auto &decl{std::get<parser::CodimensionDecl>(x.t)}; 5417 const auto &name{std::get<parser::Name>(decl.t)}; 5418 if (auto *symbol{FindInScope(name)}) { 5419 const auto &selector{std::get<parser::Selector>(x.t)}; 5420 if (auto sel{ResolveSelector(selector)}) { 5421 const Symbol *whole{UnwrapWholeSymbolDataRef(sel.expr)}; 5422 if (!whole || whole->Corank() == 0) { 5423 Say(sel.source, // C1116 5424 "Selector in coarray association must name a coarray"_err_en_US); 5425 } else if (auto dynType{sel.expr->GetType()}) { 5426 if (!symbol->GetType()) { 5427 symbol->SetType(ToDeclTypeSpec(std::move(*dynType))); 5428 } 5429 } 5430 } 5431 } 5432 } 5433 5434 void ConstructVisitor::Post(const parser::EndChangeTeamStmt &x) { 5435 PopAssociation(); 5436 PopScope(); 5437 CheckRef(x.t); 5438 } 5439 5440 bool ConstructVisitor::Pre(const parser::SelectTypeConstruct &) { 5441 PushAssociation(); 5442 return true; 5443 } 5444 5445 void ConstructVisitor::Post(const parser::SelectTypeConstruct &) { 5446 PopAssociation(); 5447 } 5448 5449 void ConstructVisitor::Post(const parser::SelectTypeStmt &x) { 5450 auto &association{GetCurrentAssociation()}; 5451 if (const std::optional<parser::Name> &name{std::get<1>(x.t)}) { 5452 // This isn't a name in the current scope, it is in each TypeGuardStmt 5453 MakePlaceholder(*name, MiscDetails::Kind::SelectTypeAssociateName); 5454 association.name = &*name; 5455 auto exprType{association.selector.expr->GetType()}; 5456 if (ExtractCoarrayRef(association.selector.expr)) { // C1103 5457 Say("Selector must not be a coindexed object"_err_en_US); 5458 } 5459 if (exprType && !exprType->IsPolymorphic()) { // C1159 5460 Say(association.selector.source, 5461 "Selector '%s' in SELECT TYPE statement must be " 5462 "polymorphic"_err_en_US); 5463 } 5464 } else { 5465 if (const Symbol * 5466 whole{UnwrapWholeSymbolDataRef(association.selector.expr)}) { 5467 ConvertToObjectEntity(const_cast<Symbol &>(*whole)); 5468 if (!IsVariableName(*whole)) { 5469 Say(association.selector.source, // C901 5470 "Selector is not a variable"_err_en_US); 5471 association = {}; 5472 } 5473 if (const DeclTypeSpec * type{whole->GetType()}) { 5474 if (!type->IsPolymorphic()) { // C1159 5475 Say(association.selector.source, 5476 "Selector '%s' in SELECT TYPE statement must be " 5477 "polymorphic"_err_en_US); 5478 } 5479 } 5480 } else { 5481 Say(association.selector.source, // C1157 5482 "Selector is not a named variable: 'associate-name =>' is required"_err_en_US); 5483 association = {}; 5484 } 5485 } 5486 } 5487 5488 void ConstructVisitor::Post(const parser::SelectRankStmt &x) { 5489 auto &association{GetCurrentAssociation()}; 5490 if (const std::optional<parser::Name> &name{std::get<1>(x.t)}) { 5491 // This isn't a name in the current scope, it is in each SelectRankCaseStmt 5492 MakePlaceholder(*name, MiscDetails::Kind::SelectRankAssociateName); 5493 association.name = &*name; 5494 } 5495 } 5496 5497 bool ConstructVisitor::Pre(const parser::SelectTypeConstruct::TypeCase &) { 5498 PushScope(Scope::Kind::Block, nullptr); 5499 return true; 5500 } 5501 void ConstructVisitor::Post(const parser::SelectTypeConstruct::TypeCase &) { 5502 PopScope(); 5503 } 5504 5505 bool ConstructVisitor::Pre(const parser::SelectRankConstruct::RankCase &) { 5506 PushScope(Scope::Kind::Block, nullptr); 5507 return true; 5508 } 5509 void ConstructVisitor::Post(const parser::SelectRankConstruct::RankCase &) { 5510 PopScope(); 5511 } 5512 5513 void ConstructVisitor::Post(const parser::TypeGuardStmt::Guard &x) { 5514 if (auto *symbol{MakeAssocEntity()}) { 5515 if (std::holds_alternative<parser::Default>(x.u)) { 5516 SetTypeFromAssociation(*symbol); 5517 } else if (const auto *type{GetDeclTypeSpec()}) { 5518 symbol->SetType(*type); 5519 } 5520 SetAttrsFromAssociation(*symbol); 5521 } 5522 } 5523 5524 void ConstructVisitor::Post(const parser::SelectRankCaseStmt::Rank &x) { 5525 if (auto *symbol{MakeAssocEntity()}) { 5526 SetTypeFromAssociation(*symbol); 5527 SetAttrsFromAssociation(*symbol); 5528 if (const auto *init{std::get_if<parser::ScalarIntConstantExpr>(&x.u)}) { 5529 if (auto val{EvaluateInt64(context(), *init)}) { 5530 auto &details{symbol->get<AssocEntityDetails>()}; 5531 details.set_rank(*val); 5532 } 5533 } 5534 } 5535 } 5536 5537 bool ConstructVisitor::Pre(const parser::SelectRankConstruct &) { 5538 PushAssociation(); 5539 return true; 5540 } 5541 5542 void ConstructVisitor::Post(const parser::SelectRankConstruct &) { 5543 PopAssociation(); 5544 } 5545 5546 bool ConstructVisitor::CheckDef(const std::optional<parser::Name> &x) { 5547 if (x) { 5548 MakeSymbol(*x, MiscDetails{MiscDetails::Kind::ConstructName}); 5549 } 5550 return true; 5551 } 5552 5553 void ConstructVisitor::CheckRef(const std::optional<parser::Name> &x) { 5554 if (x) { 5555 // Just add an occurrence of this name; checking is done in ValidateLabels 5556 FindSymbol(*x); 5557 } 5558 } 5559 5560 // Make a symbol for the associating entity of the current association. 5561 Symbol *ConstructVisitor::MakeAssocEntity() { 5562 Symbol *symbol{nullptr}; 5563 auto &association{GetCurrentAssociation()}; 5564 if (association.name) { 5565 symbol = &MakeSymbol(*association.name, UnknownDetails{}); 5566 if (symbol->has<AssocEntityDetails>() && symbol->owner() == currScope()) { 5567 Say(*association.name, // C1102 5568 "The associate name '%s' is already used in this associate statement"_err_en_US); 5569 return nullptr; 5570 } 5571 } else if (const Symbol * 5572 whole{UnwrapWholeSymbolDataRef(association.selector.expr)}) { 5573 symbol = &MakeSymbol(whole->name()); 5574 } else { 5575 return nullptr; 5576 } 5577 if (auto &expr{association.selector.expr}) { 5578 symbol->set_details(AssocEntityDetails{common::Clone(*expr)}); 5579 } else { 5580 symbol->set_details(AssocEntityDetails{}); 5581 } 5582 return symbol; 5583 } 5584 5585 // Set the type of symbol based on the current association selector. 5586 void ConstructVisitor::SetTypeFromAssociation(Symbol &symbol) { 5587 auto &details{symbol.get<AssocEntityDetails>()}; 5588 const MaybeExpr *pexpr{&details.expr()}; 5589 if (!*pexpr) { 5590 pexpr = &GetCurrentAssociation().selector.expr; 5591 } 5592 if (*pexpr) { 5593 const SomeExpr &expr{**pexpr}; 5594 if (std::optional<evaluate::DynamicType> type{expr.GetType()}) { 5595 if (const auto *charExpr{ 5596 evaluate::UnwrapExpr<evaluate::Expr<evaluate::SomeCharacter>>( 5597 expr)}) { 5598 symbol.SetType(ToDeclTypeSpec(std::move(*type), 5599 FoldExpr( 5600 std::visit([](const auto &kindChar) { return kindChar.LEN(); }, 5601 charExpr->u)))); 5602 } else { 5603 symbol.SetType(ToDeclTypeSpec(std::move(*type))); 5604 } 5605 } else { 5606 // BOZ literals, procedure designators, &c. are not acceptable 5607 Say(symbol.name(), "Associate name '%s' must have a type"_err_en_US); 5608 } 5609 } 5610 } 5611 5612 // If current selector is a variable, set some of its attributes on symbol. 5613 void ConstructVisitor::SetAttrsFromAssociation(Symbol &symbol) { 5614 Attrs attrs{evaluate::GetAttrs(GetCurrentAssociation().selector.expr)}; 5615 symbol.attrs() |= attrs & 5616 Attrs{Attr::TARGET, Attr::ASYNCHRONOUS, Attr::VOLATILE, Attr::CONTIGUOUS}; 5617 if (attrs.test(Attr::POINTER)) { 5618 symbol.attrs().set(Attr::TARGET); 5619 } 5620 } 5621 5622 ConstructVisitor::Selector ConstructVisitor::ResolveSelector( 5623 const parser::Selector &x) { 5624 return std::visit(common::visitors{ 5625 [&](const parser::Expr &expr) { 5626 return Selector{expr.source, EvaluateExpr(expr)}; 5627 }, 5628 [&](const parser::Variable &var) { 5629 return Selector{var.GetSource(), EvaluateExpr(var)}; 5630 }, 5631 }, 5632 x.u); 5633 } 5634 5635 // Set the current association to the nth to the last association on the 5636 // association stack. The top of the stack is at n = 1. This allows access 5637 // to the interior of a list of associations at the top of the stack. 5638 void ConstructVisitor::SetCurrentAssociation(std::size_t n) { 5639 CHECK(n > 0 && n <= associationStack_.size()); 5640 currentAssociation_ = &associationStack_[associationStack_.size() - n]; 5641 } 5642 5643 ConstructVisitor::Association &ConstructVisitor::GetCurrentAssociation() { 5644 CHECK(currentAssociation_); 5645 return *currentAssociation_; 5646 } 5647 5648 void ConstructVisitor::PushAssociation() { 5649 associationStack_.emplace_back(Association{}); 5650 currentAssociation_ = &associationStack_.back(); 5651 } 5652 5653 void ConstructVisitor::PopAssociation(std::size_t count) { 5654 CHECK(count > 0 && count <= associationStack_.size()); 5655 associationStack_.resize(associationStack_.size() - count); 5656 currentAssociation_ = 5657 associationStack_.empty() ? nullptr : &associationStack_.back(); 5658 } 5659 5660 const DeclTypeSpec &ConstructVisitor::ToDeclTypeSpec( 5661 evaluate::DynamicType &&type) { 5662 switch (type.category()) { 5663 SWITCH_COVERS_ALL_CASES 5664 case common::TypeCategory::Integer: 5665 case common::TypeCategory::Real: 5666 case common::TypeCategory::Complex: 5667 return context().MakeNumericType(type.category(), type.kind()); 5668 case common::TypeCategory::Logical: 5669 return context().MakeLogicalType(type.kind()); 5670 case common::TypeCategory::Derived: 5671 if (type.IsAssumedType()) { 5672 return currScope().MakeTypeStarType(); 5673 } else if (type.IsUnlimitedPolymorphic()) { 5674 return currScope().MakeClassStarType(); 5675 } else { 5676 return currScope().MakeDerivedType( 5677 type.IsPolymorphic() ? DeclTypeSpec::ClassDerived 5678 : DeclTypeSpec::TypeDerived, 5679 common::Clone(type.GetDerivedTypeSpec()) 5680 5681 ); 5682 } 5683 case common::TypeCategory::Character: 5684 CRASH_NO_CASE; 5685 } 5686 } 5687 5688 const DeclTypeSpec &ConstructVisitor::ToDeclTypeSpec( 5689 evaluate::DynamicType &&type, MaybeSubscriptIntExpr &&length) { 5690 CHECK(type.category() == common::TypeCategory::Character); 5691 if (length) { 5692 return currScope().MakeCharacterType( 5693 ParamValue{SomeIntExpr{*std::move(length)}, common::TypeParamAttr::Len}, 5694 KindExpr{type.kind()}); 5695 } else { 5696 return currScope().MakeCharacterType( 5697 ParamValue::Deferred(common::TypeParamAttr::Len), 5698 KindExpr{type.kind()}); 5699 } 5700 } 5701 5702 // ResolveNamesVisitor implementation 5703 5704 bool ResolveNamesVisitor::Pre(const parser::FunctionReference &x) { 5705 HandleCall(Symbol::Flag::Function, x.v); 5706 return false; 5707 } 5708 bool ResolveNamesVisitor::Pre(const parser::CallStmt &x) { 5709 HandleCall(Symbol::Flag::Subroutine, x.v); 5710 return false; 5711 } 5712 5713 bool ResolveNamesVisitor::Pre(const parser::ImportStmt &x) { 5714 auto &scope{currScope()}; 5715 // Check C896 and C899: where IMPORT statements are allowed 5716 switch (scope.kind()) { 5717 case Scope::Kind::Module: 5718 if (scope.IsModule()) { 5719 Say("IMPORT is not allowed in a module scoping unit"_err_en_US); 5720 return false; 5721 } else if (x.kind == common::ImportKind::None) { 5722 Say("IMPORT,NONE is not allowed in a submodule scoping unit"_err_en_US); 5723 return false; 5724 } 5725 break; 5726 case Scope::Kind::MainProgram: 5727 Say("IMPORT is not allowed in a main program scoping unit"_err_en_US); 5728 return false; 5729 case Scope::Kind::Subprogram: 5730 if (scope.parent().IsGlobal()) { 5731 Say("IMPORT is not allowed in an external subprogram scoping unit"_err_en_US); 5732 return false; 5733 } 5734 break; 5735 case Scope::Kind::BlockData: // C1415 (in part) 5736 Say("IMPORT is not allowed in a BLOCK DATA subprogram"_err_en_US); 5737 return false; 5738 default:; 5739 } 5740 if (auto error{scope.SetImportKind(x.kind)}) { 5741 Say(std::move(*error)); 5742 } 5743 for (auto &name : x.names) { 5744 if (FindSymbol(scope.parent(), name)) { 5745 scope.add_importName(name.source); 5746 } else { 5747 Say(name, "'%s' not found in host scope"_err_en_US); 5748 } 5749 } 5750 prevImportStmt_ = currStmtSource(); 5751 return false; 5752 } 5753 5754 const parser::Name *DeclarationVisitor::ResolveStructureComponent( 5755 const parser::StructureComponent &x) { 5756 return FindComponent(ResolveDataRef(x.base), x.component); 5757 } 5758 5759 const parser::Name *DeclarationVisitor::ResolveDesignator( 5760 const parser::Designator &x) { 5761 return std::visit( 5762 common::visitors{ 5763 [&](const parser::DataRef &x) { return ResolveDataRef(x); }, 5764 [&](const parser::Substring &x) { 5765 return ResolveDataRef(std::get<parser::DataRef>(x.t)); 5766 }, 5767 }, 5768 x.u); 5769 } 5770 5771 const parser::Name *DeclarationVisitor::ResolveDataRef( 5772 const parser::DataRef &x) { 5773 return std::visit( 5774 common::visitors{ 5775 [=](const parser::Name &y) { return ResolveName(y); }, 5776 [=](const Indirection<parser::StructureComponent> &y) { 5777 return ResolveStructureComponent(y.value()); 5778 }, 5779 [&](const Indirection<parser::ArrayElement> &y) { 5780 Walk(y.value().subscripts); 5781 const parser::Name *name{ResolveDataRef(y.value().base)}; 5782 if (!name) { 5783 } else if (!name->symbol->has<ProcEntityDetails>()) { 5784 ConvertToObjectEntity(*name->symbol); 5785 } else if (!context().HasError(*name->symbol)) { 5786 SayWithDecl(*name, *name->symbol, 5787 "Cannot reference function '%s' as data"_err_en_US); 5788 } 5789 return name; 5790 }, 5791 [&](const Indirection<parser::CoindexedNamedObject> &y) { 5792 Walk(y.value().imageSelector); 5793 return ResolveDataRef(y.value().base); 5794 }, 5795 }, 5796 x.u); 5797 } 5798 5799 // If implicit types are allowed, ensure name is in the symbol table. 5800 // Otherwise, report an error if it hasn't been declared. 5801 const parser::Name *DeclarationVisitor::ResolveName(const parser::Name &name) { 5802 FindSymbol(name); 5803 if (CheckForHostAssociatedImplicit(name)) { 5804 NotePossibleBadForwardRef(name); 5805 return &name; 5806 } 5807 if (Symbol * symbol{name.symbol}) { 5808 if (CheckUseError(name)) { 5809 return nullptr; // reported an error 5810 } 5811 NotePossibleBadForwardRef(name); 5812 symbol->set(Symbol::Flag::ImplicitOrError, false); 5813 if (IsUplevelReference(*symbol)) { 5814 MakeHostAssocSymbol(name, *symbol); 5815 } else if (IsDummy(*symbol) || 5816 (!symbol->GetType() && FindCommonBlockContaining(*symbol))) { 5817 ConvertToObjectEntity(*symbol); 5818 ApplyImplicitRules(*symbol); 5819 } 5820 return &name; 5821 } 5822 if (isImplicitNoneType()) { 5823 Say(name, "No explicit type declared for '%s'"_err_en_US); 5824 return nullptr; 5825 } 5826 // Create the symbol then ensure it is accessible 5827 MakeSymbol(InclusiveScope(), name.source, Attrs{}); 5828 auto *symbol{FindSymbol(name)}; 5829 if (!symbol) { 5830 Say(name, 5831 "'%s' from host scoping unit is not accessible due to IMPORT"_err_en_US); 5832 return nullptr; 5833 } 5834 ConvertToObjectEntity(*symbol); 5835 ApplyImplicitRules(*symbol); 5836 NotePossibleBadForwardRef(name); 5837 return &name; 5838 } 5839 5840 // A specification expression may refer to a symbol in the host procedure that 5841 // is implicitly typed. Because specification parts are processed before 5842 // execution parts, this may be the first time we see the symbol. It can't be a 5843 // local in the current scope (because it's in a specification expression) so 5844 // either it is implicitly declared in the host procedure or it is an error. 5845 // We create a symbol in the host assuming it is the former; if that proves to 5846 // be wrong we report an error later in CheckDeclarations(). 5847 bool DeclarationVisitor::CheckForHostAssociatedImplicit( 5848 const parser::Name &name) { 5849 if (inExecutionPart_) { 5850 return false; 5851 } 5852 if (name.symbol) { 5853 ApplyImplicitRules(*name.symbol, true); 5854 } 5855 Symbol *hostSymbol; 5856 Scope *host{GetHostProcedure()}; 5857 if (!host || isImplicitNoneType(*host)) { 5858 return false; 5859 } 5860 if (!name.symbol) { 5861 hostSymbol = &MakeSymbol(*host, name.source, Attrs{}); 5862 ConvertToObjectEntity(*hostSymbol); 5863 ApplyImplicitRules(*hostSymbol); 5864 hostSymbol->set(Symbol::Flag::ImplicitOrError); 5865 } else if (name.symbol->test(Symbol::Flag::ImplicitOrError)) { 5866 hostSymbol = name.symbol; 5867 } else { 5868 return false; 5869 } 5870 Symbol &symbol{MakeHostAssocSymbol(name, *hostSymbol)}; 5871 if (isImplicitNoneType()) { 5872 symbol.get<HostAssocDetails>().implicitOrExplicitTypeError = true; 5873 } else { 5874 symbol.get<HostAssocDetails>().implicitOrSpecExprError = true; 5875 } 5876 return true; 5877 } 5878 5879 bool DeclarationVisitor::IsUplevelReference(const Symbol &symbol) { 5880 const Scope &symbolUnit{GetProgramUnitContaining(symbol)}; 5881 if (symbolUnit == GetProgramUnitContaining(currScope())) { 5882 return false; 5883 } else { 5884 Scope::Kind kind{symbolUnit.kind()}; 5885 return kind == Scope::Kind::Subprogram || kind == Scope::Kind::MainProgram; 5886 } 5887 } 5888 5889 // base is a part-ref of a derived type; find the named component in its type. 5890 // Also handles intrinsic type parameter inquiries (%kind, %len) and 5891 // COMPLEX component references (%re, %im). 5892 const parser::Name *DeclarationVisitor::FindComponent( 5893 const parser::Name *base, const parser::Name &component) { 5894 if (!base || !base->symbol) { 5895 return nullptr; 5896 } 5897 auto &symbol{base->symbol->GetUltimate()}; 5898 if (!symbol.has<AssocEntityDetails>() && !ConvertToObjectEntity(symbol)) { 5899 SayWithDecl(*base, symbol, 5900 "'%s' is an invalid base for a component reference"_err_en_US); 5901 return nullptr; 5902 } 5903 auto *type{symbol.GetType()}; 5904 if (!type) { 5905 return nullptr; // should have already reported error 5906 } 5907 if (const IntrinsicTypeSpec * intrinsic{type->AsIntrinsic()}) { 5908 auto name{component.ToString()}; 5909 auto category{intrinsic->category()}; 5910 MiscDetails::Kind miscKind{MiscDetails::Kind::None}; 5911 if (name == "kind") { 5912 miscKind = MiscDetails::Kind::KindParamInquiry; 5913 } else if (category == TypeCategory::Character) { 5914 if (name == "len") { 5915 miscKind = MiscDetails::Kind::LenParamInquiry; 5916 } 5917 } else if (category == TypeCategory::Complex) { 5918 if (name == "re") { 5919 miscKind = MiscDetails::Kind::ComplexPartRe; 5920 } else if (name == "im") { 5921 miscKind = MiscDetails::Kind::ComplexPartIm; 5922 } 5923 } 5924 if (miscKind != MiscDetails::Kind::None) { 5925 MakePlaceholder(component, miscKind); 5926 return nullptr; 5927 } 5928 } else if (const DerivedTypeSpec * derived{type->AsDerived()}) { 5929 if (const Scope * scope{derived->scope()}) { 5930 if (Resolve(component, scope->FindComponent(component.source))) { 5931 if (auto msg{ 5932 CheckAccessibleComponent(currScope(), *component.symbol)}) { 5933 context().Say(component.source, *msg); 5934 } 5935 return &component; 5936 } else { 5937 SayDerivedType(component.source, 5938 "Component '%s' not found in derived type '%s'"_err_en_US, *scope); 5939 } 5940 } 5941 return nullptr; 5942 } 5943 if (symbol.test(Symbol::Flag::Implicit)) { 5944 Say(*base, 5945 "'%s' is not an object of derived type; it is implicitly typed"_err_en_US); 5946 } else { 5947 SayWithDecl( 5948 *base, symbol, "'%s' is not an object of derived type"_err_en_US); 5949 } 5950 return nullptr; 5951 } 5952 5953 void DeclarationVisitor::Initialization(const parser::Name &name, 5954 const parser::Initialization &init, bool inComponentDecl) { 5955 // Traversal of the initializer was deferred to here so that the 5956 // symbol being declared can be available for use in the expression, e.g.: 5957 // real, parameter :: x = tiny(x) 5958 if (!name.symbol) { 5959 return; 5960 } 5961 Symbol &ultimate{name.symbol->GetUltimate()}; 5962 if (IsAllocatable(ultimate)) { 5963 Say(name, "Allocatable object '%s' cannot be initialized"_err_en_US); 5964 return; 5965 } 5966 if (auto *object{ultimate.detailsIf<ObjectEntityDetails>()}) { 5967 // TODO: check C762 - all bounds and type parameters of component 5968 // are colons or constant expressions if component is initialized 5969 std::visit( 5970 common::visitors{ 5971 [&](const parser::ConstantExpr &expr) { 5972 NonPointerInitialization(name, expr); 5973 }, 5974 [&](const parser::NullInit &null) { 5975 Walk(null); 5976 if (auto nullInit{EvaluateExpr(null)}) { 5977 if (!evaluate::IsNullPointer(*nullInit)) { 5978 Say(name, 5979 "Pointer initializer must be intrinsic NULL()"_err_en_US); // C813 5980 } else if (IsPointer(ultimate)) { 5981 object->set_init(std::move(*nullInit)); 5982 } else { 5983 Say(name, 5984 "Non-pointer component '%s' initialized with null pointer"_err_en_US); 5985 } 5986 } 5987 }, 5988 [&](const parser::InitialDataTarget &) { 5989 // Defer analysis to the end of the specification part 5990 // so that forward references and attribute checks like SAVE 5991 // work better. 5992 }, 5993 [&](const std::list<Indirection<parser::DataStmtValue>> &) { 5994 // TODO: Need to Walk(init.u); when implementing this case 5995 if (inComponentDecl) { 5996 Say(name, 5997 "Component '%s' initialized with DATA statement values"_err_en_US); 5998 } else { 5999 // TODO - DATA statements and DATA-like initialization extension 6000 } 6001 }, 6002 }, 6003 init.u); 6004 } 6005 } 6006 6007 void DeclarationVisitor::PointerInitialization( 6008 const parser::Name &name, const parser::InitialDataTarget &target) { 6009 if (name.symbol) { 6010 Symbol &ultimate{name.symbol->GetUltimate()}; 6011 if (!context().HasError(ultimate)) { 6012 if (IsPointer(ultimate)) { 6013 if (auto *details{ultimate.detailsIf<ObjectEntityDetails>()}) { 6014 CHECK(!details->init()); 6015 Walk(target); 6016 if (MaybeExpr expr{EvaluateExpr(target)}) { 6017 // Validation is done in declaration checking. 6018 details->set_init(std::move(*expr)); 6019 } 6020 } 6021 } else { 6022 Say(name, 6023 "'%s' is not a pointer but is initialized like one"_err_en_US); 6024 context().SetError(ultimate); 6025 } 6026 } 6027 } 6028 } 6029 void DeclarationVisitor::PointerInitialization( 6030 const parser::Name &name, const parser::ProcPointerInit &target) { 6031 if (name.symbol) { 6032 Symbol &ultimate{name.symbol->GetUltimate()}; 6033 if (!context().HasError(ultimate)) { 6034 if (IsProcedurePointer(ultimate)) { 6035 auto &details{ultimate.get<ProcEntityDetails>()}; 6036 CHECK(!details.init()); 6037 Walk(target); 6038 if (const auto *targetName{std::get_if<parser::Name>(&target.u)}) { 6039 if (targetName->symbol) { 6040 // Validation is done in declaration checking. 6041 details.set_init(*targetName->symbol); 6042 } 6043 } else { 6044 details.set_init(nullptr); // explicit NULL() 6045 } 6046 } else { 6047 Say(name, 6048 "'%s' is not a procedure pointer but is initialized " 6049 "like one"_err_en_US); 6050 context().SetError(ultimate); 6051 } 6052 } 6053 } 6054 } 6055 6056 void DeclarationVisitor::NonPointerInitialization( 6057 const parser::Name &name, const parser::ConstantExpr &expr) { 6058 if (name.symbol) { 6059 Symbol &ultimate{name.symbol->GetUltimate()}; 6060 if (!context().HasError(ultimate)) { 6061 if (IsPointer(ultimate)) { 6062 Say(name, 6063 "'%s' is a pointer but is not initialized like one"_err_en_US); 6064 } else if (auto *details{ultimate.detailsIf<ObjectEntityDetails>()}) { 6065 CHECK(!details->init()); 6066 Walk(expr); 6067 if (ultimate.owner().IsParameterizedDerivedType()) { 6068 // Can't convert to type of component, which might not yet 6069 // be known; that's done later during PDT instantiation. 6070 if (MaybeExpr value{EvaluateExpr(expr)}) { 6071 details->set_init(std::move(*value)); 6072 } 6073 } else if (MaybeExpr folded{EvaluateNonPointerInitializer( 6074 ultimate, expr, expr.thing.value().source)}) { 6075 details->set_init(std::move(*folded)); 6076 } 6077 } 6078 } 6079 } 6080 } 6081 6082 void ResolveNamesVisitor::HandleCall( 6083 Symbol::Flag procFlag, const parser::Call &call) { 6084 std::visit( 6085 common::visitors{ 6086 [&](const parser::Name &x) { HandleProcedureName(procFlag, x); }, 6087 [&](const parser::ProcComponentRef &x) { Walk(x); }, 6088 }, 6089 std::get<parser::ProcedureDesignator>(call.t).u); 6090 Walk(std::get<std::list<parser::ActualArgSpec>>(call.t)); 6091 } 6092 6093 void ResolveNamesVisitor::HandleProcedureName( 6094 Symbol::Flag flag, const parser::Name &name) { 6095 CHECK(flag == Symbol::Flag::Function || flag == Symbol::Flag::Subroutine); 6096 auto *symbol{FindSymbol(NonDerivedTypeScope(), name)}; 6097 if (!symbol) { 6098 if (IsIntrinsic(name.source, flag)) { 6099 symbol = 6100 &MakeSymbol(InclusiveScope(), name.source, Attrs{Attr::INTRINSIC}); 6101 } else { 6102 symbol = &MakeSymbol(context().globalScope(), name.source, Attrs{}); 6103 } 6104 Resolve(name, *symbol); 6105 if (symbol->has<ModuleDetails>()) { 6106 SayWithDecl(name, *symbol, 6107 "Use of '%s' as a procedure conflicts with its declaration"_err_en_US); 6108 return; 6109 } 6110 if (!symbol->attrs().test(Attr::INTRINSIC)) { 6111 if (!CheckImplicitNoneExternal(name.source, *symbol)) { 6112 return; 6113 } 6114 MakeExternal(*symbol); 6115 } 6116 ConvertToProcEntity(*symbol); 6117 SetProcFlag(name, *symbol, flag); 6118 } else if (CheckUseError(name)) { 6119 // error was reported 6120 } else { 6121 symbol = &Resolve(name, symbol)->GetUltimate(); 6122 bool convertedToProcEntity{ConvertToProcEntity(*symbol)}; 6123 if (convertedToProcEntity && !symbol->attrs().test(Attr::EXTERNAL) && 6124 IsIntrinsic(symbol->name(), flag) && !IsDummy(*symbol)) { 6125 AcquireIntrinsicProcedureFlags(*symbol); 6126 } 6127 if (!SetProcFlag(name, *symbol, flag)) { 6128 return; // reported error 6129 } 6130 CheckImplicitNoneExternal(name.source, *symbol); 6131 if (symbol->has<SubprogramDetails>() && 6132 symbol->attrs().test(Attr::ABSTRACT)) { 6133 Say(name, "Abstract interface '%s' may not be called"_err_en_US); 6134 } else if (IsProcedure(*symbol) || symbol->has<DerivedTypeDetails>() || 6135 symbol->has<ObjectEntityDetails>() || 6136 symbol->has<AssocEntityDetails>()) { 6137 // Symbols with DerivedTypeDetails, ObjectEntityDetails and 6138 // AssocEntityDetails are accepted here as procedure-designators because 6139 // this means the related FunctionReference are mis-parsed structure 6140 // constructors or array references that will be fixed later when 6141 // analyzing expressions. 6142 } else if (symbol->test(Symbol::Flag::Implicit)) { 6143 Say(name, 6144 "Use of '%s' as a procedure conflicts with its implicit definition"_err_en_US); 6145 } else { 6146 SayWithDecl(name, *symbol, 6147 "Use of '%s' as a procedure conflicts with its declaration"_err_en_US); 6148 } 6149 } 6150 } 6151 6152 bool ResolveNamesVisitor::CheckImplicitNoneExternal( 6153 const SourceName &name, const Symbol &symbol) { 6154 if (isImplicitNoneExternal() && !symbol.attrs().test(Attr::EXTERNAL) && 6155 !symbol.attrs().test(Attr::INTRINSIC) && !symbol.HasExplicitInterface()) { 6156 Say(name, 6157 "'%s' is an external procedure without the EXTERNAL" 6158 " attribute in a scope with IMPLICIT NONE(EXTERNAL)"_err_en_US); 6159 return false; 6160 } 6161 return true; 6162 } 6163 6164 // Variant of HandleProcedureName() for use while skimming the executable 6165 // part of a subprogram to catch calls to dummy procedures that are part 6166 // of the subprogram's interface, and to mark as procedures any symbols 6167 // that might otherwise have been miscategorized as objects. 6168 void ResolveNamesVisitor::NoteExecutablePartCall( 6169 Symbol::Flag flag, const parser::Call &call) { 6170 auto &designator{std::get<parser::ProcedureDesignator>(call.t)}; 6171 if (const auto *name{std::get_if<parser::Name>(&designator.u)}) { 6172 // Subtlety: The symbol pointers in the parse tree are not set, because 6173 // they might end up resolving elsewhere (e.g., construct entities in 6174 // SELECT TYPE). 6175 if (Symbol * symbol{currScope().FindSymbol(name->source)}) { 6176 Symbol::Flag other{flag == Symbol::Flag::Subroutine 6177 ? Symbol::Flag::Function 6178 : Symbol::Flag::Subroutine}; 6179 if (!symbol->test(other)) { 6180 ConvertToProcEntity(*symbol); 6181 if (symbol->has<ProcEntityDetails>()) { 6182 symbol->set(flag); 6183 if (IsDummy(*symbol)) { 6184 symbol->attrs().set(Attr::EXTERNAL); 6185 } 6186 ApplyImplicitRules(*symbol); 6187 } 6188 } 6189 } 6190 } 6191 } 6192 6193 // Check and set the Function or Subroutine flag on symbol; false on error. 6194 bool ResolveNamesVisitor::SetProcFlag( 6195 const parser::Name &name, Symbol &symbol, Symbol::Flag flag) { 6196 if (symbol.test(Symbol::Flag::Function) && flag == Symbol::Flag::Subroutine) { 6197 SayWithDecl( 6198 name, symbol, "Cannot call function '%s' like a subroutine"_err_en_US); 6199 return false; 6200 } else if (symbol.test(Symbol::Flag::Subroutine) && 6201 flag == Symbol::Flag::Function) { 6202 SayWithDecl( 6203 name, symbol, "Cannot call subroutine '%s' like a function"_err_en_US); 6204 return false; 6205 } else if (symbol.has<ProcEntityDetails>()) { 6206 symbol.set(flag); // in case it hasn't been set yet 6207 if (flag == Symbol::Flag::Function) { 6208 ApplyImplicitRules(symbol); 6209 } 6210 if (symbol.attrs().test(Attr::INTRINSIC)) { 6211 AcquireIntrinsicProcedureFlags(symbol); 6212 } 6213 } else if (symbol.GetType() && flag == Symbol::Flag::Subroutine) { 6214 SayWithDecl( 6215 name, symbol, "Cannot call function '%s' like a subroutine"_err_en_US); 6216 } else if (symbol.attrs().test(Attr::INTRINSIC)) { 6217 AcquireIntrinsicProcedureFlags(symbol); 6218 } 6219 return true; 6220 } 6221 6222 bool ModuleVisitor::Pre(const parser::AccessStmt &x) { 6223 Attr accessAttr{AccessSpecToAttr(std::get<parser::AccessSpec>(x.t))}; 6224 if (!currScope().IsModule()) { // C869 6225 Say(currStmtSource().value(), 6226 "%s statement may only appear in the specification part of a module"_err_en_US, 6227 EnumToString(accessAttr)); 6228 return false; 6229 } 6230 const auto &accessIds{std::get<std::list<parser::AccessId>>(x.t)}; 6231 if (accessIds.empty()) { 6232 if (prevAccessStmt_) { // C869 6233 Say("The default accessibility of this module has already been declared"_err_en_US) 6234 .Attach(*prevAccessStmt_, "Previous declaration"_en_US); 6235 } 6236 prevAccessStmt_ = currStmtSource(); 6237 defaultAccess_ = accessAttr; 6238 } else { 6239 for (const auto &accessId : accessIds) { 6240 std::visit( 6241 common::visitors{ 6242 [=](const parser::Name &y) { 6243 Resolve(y, SetAccess(y.source, accessAttr)); 6244 }, 6245 [=](const Indirection<parser::GenericSpec> &y) { 6246 auto info{GenericSpecInfo{y.value()}}; 6247 const auto &symbolName{info.symbolName()}; 6248 if (auto *symbol{FindInScope(symbolName)}) { 6249 info.Resolve(&SetAccess(symbolName, accessAttr, symbol)); 6250 } else if (info.kind().IsName()) { 6251 info.Resolve(&SetAccess(symbolName, accessAttr)); 6252 } else { 6253 Say(symbolName, "Generic spec '%s' not found"_err_en_US); 6254 } 6255 }, 6256 }, 6257 accessId.u); 6258 } 6259 } 6260 return false; 6261 } 6262 6263 // Set the access specification for this symbol. 6264 Symbol &ModuleVisitor::SetAccess( 6265 const SourceName &name, Attr attr, Symbol *symbol) { 6266 if (!symbol) { 6267 symbol = &MakeSymbol(name); 6268 } 6269 Attrs &attrs{symbol->attrs()}; 6270 if (attrs.HasAny({Attr::PUBLIC, Attr::PRIVATE})) { 6271 // PUBLIC/PRIVATE already set: make it a fatal error if it changed 6272 Attr prev = attrs.test(Attr::PUBLIC) ? Attr::PUBLIC : Attr::PRIVATE; 6273 Say(name, 6274 WithIsFatal( 6275 "The accessibility of '%s' has already been specified as %s"_en_US, 6276 attr != prev), 6277 MakeOpName(name), EnumToString(prev)); 6278 } else { 6279 attrs.set(attr); 6280 } 6281 return *symbol; 6282 } 6283 6284 static bool NeedsExplicitType(const Symbol &symbol) { 6285 if (symbol.has<UnknownDetails>()) { 6286 return true; 6287 } else if (const auto *details{symbol.detailsIf<EntityDetails>()}) { 6288 return !details->type(); 6289 } else if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) { 6290 return !details->type(); 6291 } else if (const auto *details{symbol.detailsIf<ProcEntityDetails>()}) { 6292 return !details->interface().symbol() && !details->interface().type(); 6293 } else { 6294 return false; 6295 } 6296 } 6297 6298 bool ResolveNamesVisitor::Pre(const parser::SpecificationPart &x) { 6299 const auto &[accDecls, ompDecls, compilerDirectives, useStmts, importStmts, 6300 implicitPart, decls] = x.t; 6301 auto flagRestorer{common::ScopedSet(inSpecificationPart_, true)}; 6302 auto stateRestorer{ 6303 common::ScopedSet(specPartState_, SpecificationPartState{})}; 6304 Walk(accDecls); 6305 Walk(ompDecls); 6306 Walk(compilerDirectives); 6307 Walk(useStmts); 6308 Walk(importStmts); 6309 Walk(implicitPart); 6310 for (const auto &decl : decls) { 6311 if (const auto *spec{ 6312 std::get_if<parser::SpecificationConstruct>(&decl.u)}) { 6313 PreSpecificationConstruct(*spec); 6314 } 6315 } 6316 Walk(decls); 6317 FinishSpecificationPart(decls); 6318 return false; 6319 } 6320 6321 // Initial processing on specification constructs, before visiting them. 6322 void ResolveNamesVisitor::PreSpecificationConstruct( 6323 const parser::SpecificationConstruct &spec) { 6324 std::visit( 6325 common::visitors{ 6326 [&](const parser::Statement<Indirection<parser::GenericStmt>> &y) { 6327 CreateGeneric(std::get<parser::GenericSpec>(y.statement.value().t)); 6328 }, 6329 [&](const Indirection<parser::InterfaceBlock> &y) { 6330 const auto &stmt{std::get<parser::Statement<parser::InterfaceStmt>>( 6331 y.value().t)}; 6332 if (const auto *spec{parser::Unwrap<parser::GenericSpec>(stmt)}) { 6333 CreateGeneric(*spec); 6334 } 6335 }, 6336 [&](const parser::Statement<parser::OtherSpecificationStmt> &y) { 6337 if (const auto *commonStmt{parser::Unwrap<parser::CommonStmt>(y)}) { 6338 CreateCommonBlockSymbols(*commonStmt); 6339 } 6340 }, 6341 [&](const auto &) {}, 6342 }, 6343 spec.u); 6344 } 6345 6346 void ResolveNamesVisitor::CreateCommonBlockSymbols( 6347 const parser::CommonStmt &commonStmt) { 6348 for (const parser::CommonStmt::Block &block : commonStmt.blocks) { 6349 const auto &[name, objects] = block.t; 6350 Symbol &commonBlock{MakeCommonBlockSymbol(name)}; 6351 for (const auto &object : objects) { 6352 Symbol &obj{DeclareObjectEntity(std::get<parser::Name>(object.t))}; 6353 if (auto *details{obj.detailsIf<ObjectEntityDetails>()}) { 6354 details->set_commonBlock(commonBlock); 6355 commonBlock.get<CommonBlockDetails>().add_object(obj); 6356 } 6357 } 6358 } 6359 } 6360 6361 void ResolveNamesVisitor::CreateGeneric(const parser::GenericSpec &x) { 6362 auto info{GenericSpecInfo{x}}; 6363 const SourceName &symbolName{info.symbolName()}; 6364 if (IsLogicalConstant(context(), symbolName)) { 6365 Say(symbolName, 6366 "Logical constant '%s' may not be used as a defined operator"_err_en_US); 6367 return; 6368 } 6369 GenericDetails genericDetails; 6370 if (Symbol * existing{FindInScope(symbolName)}) { 6371 if (existing->has<GenericDetails>()) { 6372 info.Resolve(existing); 6373 return; // already have generic, add to it 6374 } 6375 Symbol &ultimate{existing->GetUltimate()}; 6376 if (auto *ultimateDetails{ultimate.detailsIf<GenericDetails>()}) { 6377 // convert a use-associated generic into a local generic 6378 genericDetails.CopyFrom(*ultimateDetails); 6379 AddGenericUse(genericDetails, existing->name(), 6380 existing->get<UseDetails>().symbol()); 6381 } else if (ultimate.has<SubprogramDetails>() || 6382 ultimate.has<SubprogramNameDetails>()) { 6383 genericDetails.set_specific(ultimate); 6384 } else if (ultimate.has<DerivedTypeDetails>()) { 6385 genericDetails.set_derivedType(ultimate); 6386 } else { 6387 SayAlreadyDeclared(symbolName, *existing); 6388 } 6389 EraseSymbol(*existing); 6390 } 6391 info.Resolve(&MakeSymbol(symbolName, Attrs{}, std::move(genericDetails))); 6392 } 6393 6394 void ResolveNamesVisitor::FinishSpecificationPart( 6395 const std::list<parser::DeclarationConstruct> &decls) { 6396 badStmtFuncFound_ = false; 6397 CheckImports(); 6398 bool inModule{currScope().kind() == Scope::Kind::Module}; 6399 for (auto &pair : currScope()) { 6400 auto &symbol{*pair.second}; 6401 if (NeedsExplicitType(symbol)) { 6402 ApplyImplicitRules(symbol); 6403 } 6404 if (IsDummy(symbol) && isImplicitNoneType() && 6405 symbol.test(Symbol::Flag::Implicit) && !context().HasError(symbol)) { 6406 Say(symbol.name(), 6407 "No explicit type declared for dummy argument '%s'"_err_en_US); 6408 context().SetError(symbol); 6409 } 6410 if (symbol.has<GenericDetails>()) { 6411 CheckGenericProcedures(symbol); 6412 } 6413 if (inModule && symbol.attrs().test(Attr::EXTERNAL) && 6414 !symbol.test(Symbol::Flag::Function) && 6415 !symbol.test(Symbol::Flag::Subroutine)) { 6416 // in a module, external proc without return type is subroutine 6417 symbol.set( 6418 symbol.GetType() ? Symbol::Flag::Function : Symbol::Flag::Subroutine); 6419 } 6420 if (!symbol.has<HostAssocDetails>()) { 6421 CheckPossibleBadForwardRef(symbol); 6422 } 6423 } 6424 currScope().InstantiateDerivedTypes(); 6425 for (const auto &decl : decls) { 6426 if (const auto *statement{std::get_if< 6427 parser::Statement<common::Indirection<parser::StmtFunctionStmt>>>( 6428 &decl.u)}) { 6429 AnalyzeStmtFunctionStmt(statement->statement.value()); 6430 } 6431 } 6432 // TODO: what about instantiations in BLOCK? 6433 CheckSaveStmts(); 6434 CheckCommonBlocks(); 6435 if (!inInterfaceBlock()) { 6436 // TODO: warn for the case where the EQUIVALENCE statement is in a 6437 // procedure declaration in an interface block 6438 CheckEquivalenceSets(); 6439 } 6440 } 6441 6442 // Analyze the bodies of statement functions now that the symbols in this 6443 // specification part have been fully declared and implicitly typed. 6444 void ResolveNamesVisitor::AnalyzeStmtFunctionStmt( 6445 const parser::StmtFunctionStmt &stmtFunc) { 6446 Symbol *symbol{std::get<parser::Name>(stmtFunc.t).symbol}; 6447 if (!symbol || !symbol->has<SubprogramDetails>()) { 6448 return; 6449 } 6450 auto &details{symbol->get<SubprogramDetails>()}; 6451 auto expr{AnalyzeExpr( 6452 context(), std::get<parser::Scalar<parser::Expr>>(stmtFunc.t))}; 6453 if (!expr) { 6454 context().SetError(*symbol); 6455 return; 6456 } 6457 if (auto type{evaluate::DynamicType::From(*symbol)}) { 6458 auto converted{ConvertToType(*type, std::move(*expr))}; 6459 if (!converted) { 6460 context().SetError(*symbol); 6461 return; 6462 } 6463 details.set_stmtFunction(std::move(*converted)); 6464 } else { 6465 details.set_stmtFunction(std::move(*expr)); 6466 } 6467 } 6468 6469 void ResolveNamesVisitor::CheckImports() { 6470 auto &scope{currScope()}; 6471 switch (scope.GetImportKind()) { 6472 case common::ImportKind::None: 6473 break; 6474 case common::ImportKind::All: 6475 // C8102: all entities in host must not be hidden 6476 for (const auto &pair : scope.parent()) { 6477 auto &name{pair.first}; 6478 std::optional<SourceName> scopeName{scope.GetName()}; 6479 if (!scopeName || name != *scopeName) { 6480 CheckImport(prevImportStmt_.value(), name); 6481 } 6482 } 6483 break; 6484 case common::ImportKind::Default: 6485 case common::ImportKind::Only: 6486 // C8102: entities named in IMPORT must not be hidden 6487 for (auto &name : scope.importNames()) { 6488 CheckImport(name, name); 6489 } 6490 break; 6491 } 6492 } 6493 6494 void ResolveNamesVisitor::CheckImport( 6495 const SourceName &location, const SourceName &name) { 6496 if (auto *symbol{FindInScope(name)}) { 6497 Say(location, "'%s' from host is not accessible"_err_en_US, name) 6498 .Attach(symbol->name(), "'%s' is hidden by this entity"_en_US, 6499 symbol->name()); 6500 } 6501 } 6502 6503 bool ResolveNamesVisitor::Pre(const parser::ImplicitStmt &x) { 6504 return CheckNotInBlock("IMPLICIT") && // C1107 6505 ImplicitRulesVisitor::Pre(x); 6506 } 6507 6508 void ResolveNamesVisitor::Post(const parser::PointerObject &x) { 6509 std::visit(common::visitors{ 6510 [&](const parser::Name &x) { ResolveName(x); }, 6511 [&](const parser::StructureComponent &x) { 6512 ResolveStructureComponent(x); 6513 }, 6514 }, 6515 x.u); 6516 } 6517 void ResolveNamesVisitor::Post(const parser::AllocateObject &x) { 6518 std::visit(common::visitors{ 6519 [&](const parser::Name &x) { ResolveName(x); }, 6520 [&](const parser::StructureComponent &x) { 6521 ResolveStructureComponent(x); 6522 }, 6523 }, 6524 x.u); 6525 } 6526 6527 bool ResolveNamesVisitor::Pre(const parser::PointerAssignmentStmt &x) { 6528 const auto &dataRef{std::get<parser::DataRef>(x.t)}; 6529 const auto &bounds{std::get<parser::PointerAssignmentStmt::Bounds>(x.t)}; 6530 const auto &expr{std::get<parser::Expr>(x.t)}; 6531 ResolveDataRef(dataRef); 6532 Walk(bounds); 6533 // Resolve unrestricted specific intrinsic procedures as in "p => cos". 6534 if (const parser::Name * name{parser::Unwrap<parser::Name>(expr)}) { 6535 if (NameIsKnownOrIntrinsic(*name)) { 6536 return false; 6537 } 6538 } 6539 Walk(expr); 6540 return false; 6541 } 6542 void ResolveNamesVisitor::Post(const parser::Designator &x) { 6543 ResolveDesignator(x); 6544 } 6545 6546 void ResolveNamesVisitor::Post(const parser::ProcComponentRef &x) { 6547 ResolveStructureComponent(x.v.thing); 6548 } 6549 void ResolveNamesVisitor::Post(const parser::TypeGuardStmt &x) { 6550 DeclTypeSpecVisitor::Post(x); 6551 ConstructVisitor::Post(x); 6552 } 6553 bool ResolveNamesVisitor::Pre(const parser::StmtFunctionStmt &x) { 6554 CheckNotInBlock("STATEMENT FUNCTION"); // C1107 6555 if (HandleStmtFunction(x)) { 6556 return false; 6557 } else { 6558 // This is an array element assignment: resolve names of indices 6559 const auto &names{std::get<std::list<parser::Name>>(x.t)}; 6560 for (auto &name : names) { 6561 ResolveName(name); 6562 } 6563 return true; 6564 } 6565 } 6566 6567 bool ResolveNamesVisitor::Pre(const parser::DefinedOpName &x) { 6568 const parser::Name &name{x.v}; 6569 if (FindSymbol(name)) { 6570 // OK 6571 } else if (IsLogicalConstant(context(), name.source)) { 6572 Say(name, 6573 "Logical constant '%s' may not be used as a defined operator"_err_en_US); 6574 } else { 6575 // Resolved later in expression semantics 6576 MakePlaceholder(name, MiscDetails::Kind::TypeBoundDefinedOp); 6577 } 6578 return false; 6579 } 6580 6581 void ResolveNamesVisitor::Post(const parser::AssignStmt &x) { 6582 if (auto *name{ResolveName(std::get<parser::Name>(x.t))}) { 6583 ConvertToObjectEntity(DEREF(name->symbol)); 6584 } 6585 } 6586 void ResolveNamesVisitor::Post(const parser::AssignedGotoStmt &x) { 6587 if (auto *name{ResolveName(std::get<parser::Name>(x.t))}) { 6588 ConvertToObjectEntity(DEREF(name->symbol)); 6589 } 6590 } 6591 6592 bool ResolveNamesVisitor::Pre(const parser::ProgramUnit &x) { 6593 if (std::holds_alternative<common::Indirection<parser::CompilerDirective>>( 6594 x.u)) { 6595 // TODO: global directives 6596 return true; 6597 } 6598 auto root{ProgramTree::Build(x)}; 6599 SetScope(context().globalScope()); 6600 ResolveSpecificationParts(root); 6601 FinishSpecificationParts(root); 6602 inExecutionPart_ = true; 6603 ResolveExecutionParts(root); 6604 inExecutionPart_ = false; 6605 ResolveAccParts(context(), x); 6606 ResolveOmpParts(context(), x); 6607 return false; 6608 } 6609 6610 // References to procedures need to record that their symbols are known 6611 // to be procedures, so that they don't get converted to objects by default. 6612 class ExecutionPartSkimmer { 6613 public: 6614 explicit ExecutionPartSkimmer(ResolveNamesVisitor &resolver) 6615 : resolver_{resolver} {} 6616 6617 void Walk(const parser::ExecutionPart *exec) { 6618 if (exec) { 6619 parser::Walk(*exec, *this); 6620 } 6621 } 6622 6623 template <typename A> bool Pre(const A &) { return true; } 6624 template <typename A> void Post(const A &) {} 6625 void Post(const parser::FunctionReference &fr) { 6626 resolver_.NoteExecutablePartCall(Symbol::Flag::Function, fr.v); 6627 } 6628 void Post(const parser::CallStmt &cs) { 6629 resolver_.NoteExecutablePartCall(Symbol::Flag::Subroutine, cs.v); 6630 } 6631 6632 private: 6633 ResolveNamesVisitor &resolver_; 6634 }; 6635 6636 // Build the scope tree and resolve names in the specification parts of this 6637 // node and its children 6638 void ResolveNamesVisitor::ResolveSpecificationParts(ProgramTree &node) { 6639 if (node.isSpecificationPartResolved()) { 6640 return; // been here already 6641 } 6642 node.set_isSpecificationPartResolved(); 6643 if (!BeginScopeForNode(node)) { 6644 return; // an error prevented scope from being created 6645 } 6646 Scope &scope{currScope()}; 6647 node.set_scope(scope); 6648 AddSubpNames(node); 6649 std::visit( 6650 [&](const auto *x) { 6651 if (x) { 6652 Walk(*x); 6653 } 6654 }, 6655 node.stmt()); 6656 Walk(node.spec()); 6657 // If this is a function, convert result to an object. This is to prevent the 6658 // result from being converted later to a function symbol if it is called 6659 // inside the function. 6660 // If the result is function pointer, then ConvertToObjectEntity will not 6661 // convert the result to an object, and calling the symbol inside the function 6662 // will result in calls to the result pointer. 6663 // A function cannot be called recursively if RESULT was not used to define a 6664 // distinct result name (15.6.2.2 point 4.). 6665 if (Symbol * symbol{scope.symbol()}) { 6666 if (auto *details{symbol->detailsIf<SubprogramDetails>()}) { 6667 if (details->isFunction()) { 6668 ConvertToObjectEntity(const_cast<Symbol &>(details->result())); 6669 } 6670 } 6671 } 6672 if (node.IsModule()) { 6673 ApplyDefaultAccess(); 6674 } 6675 for (auto &child : node.children()) { 6676 ResolveSpecificationParts(child); 6677 } 6678 ExecutionPartSkimmer{*this}.Walk(node.exec()); 6679 PopScope(); 6680 // Ensure that every object entity has a type. 6681 for (auto &pair : *node.scope()) { 6682 ApplyImplicitRules(*pair.second); 6683 } 6684 } 6685 6686 // Add SubprogramNameDetails symbols for module and internal subprograms 6687 void ResolveNamesVisitor::AddSubpNames(ProgramTree &node) { 6688 auto kind{ 6689 node.IsModule() ? SubprogramKind::Module : SubprogramKind::Internal}; 6690 for (auto &child : node.children()) { 6691 auto &symbol{MakeSymbol(child.name(), SubprogramNameDetails{kind, child})}; 6692 symbol.set(child.GetSubpFlag()); 6693 } 6694 } 6695 6696 // Push a new scope for this node or return false on error. 6697 bool ResolveNamesVisitor::BeginScopeForNode(const ProgramTree &node) { 6698 switch (node.GetKind()) { 6699 SWITCH_COVERS_ALL_CASES 6700 case ProgramTree::Kind::Program: 6701 PushScope(Scope::Kind::MainProgram, 6702 &MakeSymbol(node.name(), MainProgramDetails{})); 6703 return true; 6704 case ProgramTree::Kind::Function: 6705 case ProgramTree::Kind::Subroutine: 6706 return BeginSubprogram( 6707 node.name(), node.GetSubpFlag(), node.HasModulePrefix()); 6708 case ProgramTree::Kind::MpSubprogram: 6709 return BeginMpSubprogram(node.name()); 6710 case ProgramTree::Kind::Module: 6711 BeginModule(node.name(), false); 6712 return true; 6713 case ProgramTree::Kind::Submodule: 6714 return BeginSubmodule(node.name(), node.GetParentId()); 6715 case ProgramTree::Kind::BlockData: 6716 PushBlockDataScope(node.name()); 6717 return true; 6718 } 6719 } 6720 6721 // Some analyses and checks, such as the processing of initializers of 6722 // pointers, are deferred until all of the pertinent specification parts 6723 // have been visited. This deferred processing enables the use of forward 6724 // references in these circumstances. 6725 class DeferredCheckVisitor { 6726 public: 6727 explicit DeferredCheckVisitor(ResolveNamesVisitor &resolver) 6728 : resolver_{resolver} {} 6729 6730 template <typename A> void Walk(const A &x) { parser::Walk(x, *this); } 6731 6732 template <typename A> bool Pre(const A &) { return true; } 6733 template <typename A> void Post(const A &) {} 6734 6735 void Post(const parser::DerivedTypeStmt &x) { 6736 const auto &name{std::get<parser::Name>(x.t)}; 6737 if (Symbol * symbol{name.symbol}) { 6738 if (Scope * scope{symbol->scope()}) { 6739 if (scope->IsDerivedType()) { 6740 resolver_.PushScope(*scope); 6741 pushedScope_ = true; 6742 } 6743 } 6744 } 6745 } 6746 void Post(const parser::EndTypeStmt &) { 6747 if (pushedScope_) { 6748 resolver_.PopScope(); 6749 pushedScope_ = false; 6750 } 6751 } 6752 6753 void Post(const parser::ProcInterface &pi) { 6754 if (const auto *name{std::get_if<parser::Name>(&pi.u)}) { 6755 resolver_.CheckExplicitInterface(*name); 6756 } 6757 } 6758 bool Pre(const parser::EntityDecl &decl) { 6759 Init(std::get<parser::Name>(decl.t), 6760 std::get<std::optional<parser::Initialization>>(decl.t)); 6761 return false; 6762 } 6763 bool Pre(const parser::ComponentDecl &decl) { 6764 Init(std::get<parser::Name>(decl.t), 6765 std::get<std::optional<parser::Initialization>>(decl.t)); 6766 return false; 6767 } 6768 bool Pre(const parser::ProcDecl &decl) { 6769 if (const auto &init{ 6770 std::get<std::optional<parser::ProcPointerInit>>(decl.t)}) { 6771 resolver_.PointerInitialization(std::get<parser::Name>(decl.t), *init); 6772 } 6773 return false; 6774 } 6775 void Post(const parser::TypeBoundProcedureStmt::WithInterface &tbps) { 6776 resolver_.CheckExplicitInterface(tbps.interfaceName); 6777 } 6778 void Post(const parser::TypeBoundProcedureStmt::WithoutInterface &tbps) { 6779 if (pushedScope_) { 6780 resolver_.CheckBindings(tbps); 6781 } 6782 } 6783 6784 private: 6785 void Init(const parser::Name &name, 6786 const std::optional<parser::Initialization> &init) { 6787 if (init) { 6788 if (const auto *target{ 6789 std::get_if<parser::InitialDataTarget>(&init->u)}) { 6790 resolver_.PointerInitialization(name, *target); 6791 } 6792 } 6793 } 6794 6795 ResolveNamesVisitor &resolver_; 6796 bool pushedScope_{false}; 6797 }; 6798 6799 // Perform checks and completions that need to happen after all of 6800 // the specification parts but before any of the execution parts. 6801 void ResolveNamesVisitor::FinishSpecificationParts(const ProgramTree &node) { 6802 if (!node.scope()) { 6803 return; // error occurred creating scope 6804 } 6805 SetScope(*node.scope()); 6806 // The initializers of pointers, the default initializers of pointer 6807 // components, and non-deferred type-bound procedure bindings have not 6808 // yet been traversed. 6809 // We do that now, when any (formerly) forward references that appear 6810 // in those initializers will resolve to the right symbols without 6811 // incurring spurious errors with IMPLICIT NONE. 6812 DeferredCheckVisitor{*this}.Walk(node.spec()); 6813 DeferredCheckVisitor{*this}.Walk(node.exec()); // for BLOCK 6814 for (Scope &childScope : currScope().children()) { 6815 if (childScope.IsParameterizedDerivedTypeInstantiation()) { 6816 FinishDerivedTypeInstantiation(childScope); 6817 } 6818 } 6819 for (const auto &child : node.children()) { 6820 FinishSpecificationParts(child); 6821 } 6822 } 6823 6824 // Duplicate and fold component object pointer default initializer designators 6825 // using the actual type parameter values of each particular instantiation. 6826 // Validation is done later in declaration checking. 6827 void ResolveNamesVisitor::FinishDerivedTypeInstantiation(Scope &scope) { 6828 CHECK(scope.IsDerivedType() && !scope.symbol()); 6829 if (DerivedTypeSpec * spec{scope.derivedTypeSpec()}) { 6830 spec->Instantiate(currScope(), context()); 6831 const Symbol &origTypeSymbol{spec->typeSymbol()}; 6832 if (const Scope * origTypeScope{origTypeSymbol.scope()}) { 6833 CHECK(origTypeScope->IsDerivedType() && 6834 origTypeScope->symbol() == &origTypeSymbol); 6835 auto &foldingContext{GetFoldingContext()}; 6836 auto restorer{foldingContext.WithPDTInstance(*spec)}; 6837 for (auto &pair : scope) { 6838 Symbol &comp{*pair.second}; 6839 const Symbol &origComp{DEREF(FindInScope(*origTypeScope, comp.name()))}; 6840 if (IsPointer(comp)) { 6841 if (auto *details{comp.detailsIf<ObjectEntityDetails>()}) { 6842 auto origDetails{origComp.get<ObjectEntityDetails>()}; 6843 if (const MaybeExpr & init{origDetails.init()}) { 6844 SomeExpr newInit{*init}; 6845 MaybeExpr folded{ 6846 evaluate::Fold(foldingContext, std::move(newInit))}; 6847 details->set_init(std::move(folded)); 6848 } 6849 } 6850 } 6851 } 6852 } 6853 } 6854 } 6855 6856 // Resolve names in the execution part of this node and its children 6857 void ResolveNamesVisitor::ResolveExecutionParts(const ProgramTree &node) { 6858 if (!node.scope()) { 6859 return; // error occurred creating scope 6860 } 6861 SetScope(*node.scope()); 6862 if (const auto *exec{node.exec()}) { 6863 Walk(*exec); 6864 } 6865 PopScope(); // converts unclassified entities into objects 6866 for (const auto &child : node.children()) { 6867 ResolveExecutionParts(child); 6868 } 6869 } 6870 6871 void ResolveNamesVisitor::Post(const parser::Program &) { 6872 // ensure that all temps were deallocated 6873 CHECK(!attrs_); 6874 CHECK(!GetDeclTypeSpec()); 6875 } 6876 6877 // A singleton instance of the scope -> IMPLICIT rules mapping is 6878 // shared by all instances of ResolveNamesVisitor and accessed by this 6879 // pointer when the visitors (other than the top-level original) are 6880 // constructed. 6881 static ImplicitRulesMap *sharedImplicitRulesMap{nullptr}; 6882 6883 bool ResolveNames(SemanticsContext &context, const parser::Program &program) { 6884 ImplicitRulesMap implicitRulesMap; 6885 auto restorer{common::ScopedSet(sharedImplicitRulesMap, &implicitRulesMap)}; 6886 ResolveNamesVisitor{context, implicitRulesMap}.Walk(program); 6887 return !context.AnyFatalError(); 6888 } 6889 6890 // Processes a module (but not internal) function when it is referenced 6891 // in a specification expression in a sibling procedure. 6892 void ResolveSpecificationParts( 6893 SemanticsContext &context, const Symbol &subprogram) { 6894 auto originalLocation{context.location()}; 6895 ResolveNamesVisitor visitor{context, DEREF(sharedImplicitRulesMap)}; 6896 ProgramTree &node{subprogram.get<SubprogramNameDetails>().node()}; 6897 const Scope &moduleScope{subprogram.owner()}; 6898 visitor.SetScope(const_cast<Scope &>(moduleScope)); 6899 visitor.ResolveSpecificationParts(node); 6900 context.set_location(std::move(originalLocation)); 6901 } 6902 6903 } // namespace Fortran::semantics 6904