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