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