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, details->module().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(), details->module().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(), useDetails->module().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(), useDetails->module().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 (interface.type()) { 3439 symbol.set(Symbol::Flag::Function); 3440 } else if (interface.symbol()) { 3441 if (interface.symbol()->test(Symbol::Flag::Function)) { 3442 symbol.set(Symbol::Flag::Function); 3443 } else if (interface.symbol()->test(Symbol::Flag::Subroutine)) { 3444 symbol.set(Symbol::Flag::Subroutine); 3445 } 3446 } 3447 details->set_interface(interface); 3448 SetBindNameOn(symbol); 3449 SetPassNameOn(symbol); 3450 } 3451 return symbol; 3452 } 3453 3454 Symbol &DeclarationVisitor::DeclareObjectEntity( 3455 const parser::Name &name, Attrs attrs) { 3456 Symbol &symbol{DeclareEntity<ObjectEntityDetails>(name, attrs)}; 3457 if (auto *details{symbol.detailsIf<ObjectEntityDetails>()}) { 3458 if (auto *type{GetDeclTypeSpec()}) { 3459 SetType(name, *type); 3460 } 3461 if (!arraySpec().empty()) { 3462 if (details->IsArray()) { 3463 Say(name, 3464 "The dimensions of '%s' have already been declared"_err_en_US); 3465 context().SetError(symbol); 3466 } else { 3467 details->set_shape(arraySpec()); 3468 } 3469 } 3470 if (!coarraySpec().empty()) { 3471 if (details->IsCoarray()) { 3472 Say(name, 3473 "The codimensions of '%s' have already been declared"_err_en_US); 3474 context().SetError(symbol); 3475 } else { 3476 details->set_coshape(coarraySpec()); 3477 } 3478 } 3479 SetBindNameOn(symbol); 3480 } 3481 ClearArraySpec(); 3482 ClearCoarraySpec(); 3483 charInfo_.length.reset(); 3484 return symbol; 3485 } 3486 3487 void DeclarationVisitor::Post(const parser::IntegerTypeSpec &x) { 3488 SetDeclTypeSpec(MakeNumericType(TypeCategory::Integer, x.v)); 3489 } 3490 void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::Real &x) { 3491 SetDeclTypeSpec(MakeNumericType(TypeCategory::Real, x.kind)); 3492 } 3493 void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::Complex &x) { 3494 SetDeclTypeSpec(MakeNumericType(TypeCategory::Complex, x.kind)); 3495 } 3496 void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::Logical &x) { 3497 SetDeclTypeSpec(MakeLogicalType(x.kind)); 3498 } 3499 void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::Character &) { 3500 if (!charInfo_.length) { 3501 charInfo_.length = ParamValue{1, common::TypeParamAttr::Len}; 3502 } 3503 if (!charInfo_.kind) { 3504 charInfo_.kind = 3505 KindExpr{context().GetDefaultKind(TypeCategory::Character)}; 3506 } 3507 SetDeclTypeSpec(currScope().MakeCharacterType( 3508 std::move(*charInfo_.length), std::move(*charInfo_.kind))); 3509 charInfo_ = {}; 3510 } 3511 void DeclarationVisitor::Post(const parser::CharSelector::LengthAndKind &x) { 3512 charInfo_.kind = EvaluateSubscriptIntExpr(x.kind); 3513 std::optional<std::int64_t> intKind{ToInt64(charInfo_.kind)}; 3514 if (intKind && 3515 !evaluate::IsValidKindOfIntrinsicType( 3516 TypeCategory::Character, *intKind)) { // C715, C719 3517 Say(currStmtSource().value(), 3518 "KIND value (%jd) not valid for CHARACTER"_err_en_US, *intKind); 3519 } 3520 if (x.length) { 3521 charInfo_.length = GetParamValue(*x.length, common::TypeParamAttr::Len); 3522 } 3523 } 3524 void DeclarationVisitor::Post(const parser::CharLength &x) { 3525 if (const auto *length{std::get_if<std::uint64_t>(&x.u)}) { 3526 charInfo_.length = ParamValue{ 3527 static_cast<ConstantSubscript>(*length), common::TypeParamAttr::Len}; 3528 } else { 3529 charInfo_.length = GetParamValue( 3530 std::get<parser::TypeParamValue>(x.u), common::TypeParamAttr::Len); 3531 } 3532 } 3533 void DeclarationVisitor::Post(const parser::LengthSelector &x) { 3534 if (const auto *param{std::get_if<parser::TypeParamValue>(&x.u)}) { 3535 charInfo_.length = GetParamValue(*param, common::TypeParamAttr::Len); 3536 } 3537 } 3538 3539 bool DeclarationVisitor::Pre(const parser::KindParam &x) { 3540 if (const auto *kind{std::get_if< 3541 parser::Scalar<parser::Integer<parser::Constant<parser::Name>>>>( 3542 &x.u)}) { 3543 const parser::Name &name{kind->thing.thing.thing}; 3544 if (!FindSymbol(name)) { 3545 Say(name, "Parameter '%s' not found"_err_en_US); 3546 } 3547 } 3548 return false; 3549 } 3550 3551 bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Type &) { 3552 CHECK(GetDeclTypeSpecCategory() == DeclTypeSpec::Category::TypeDerived); 3553 return true; 3554 } 3555 3556 void DeclarationVisitor::Post(const parser::DeclarationTypeSpec::Type &type) { 3557 const parser::Name &derivedName{std::get<parser::Name>(type.derived.t)}; 3558 if (const Symbol * derivedSymbol{derivedName.symbol}) { 3559 CheckForAbstractType(*derivedSymbol); // C706 3560 } 3561 } 3562 3563 bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Class &) { 3564 SetDeclTypeSpecCategory(DeclTypeSpec::Category::ClassDerived); 3565 return true; 3566 } 3567 3568 void DeclarationVisitor::Post( 3569 const parser::DeclarationTypeSpec::Class &parsedClass) { 3570 const auto &typeName{std::get<parser::Name>(parsedClass.derived.t)}; 3571 if (auto spec{ResolveDerivedType(typeName)}; 3572 spec && !IsExtensibleType(&*spec)) { // C705 3573 SayWithDecl(typeName, *typeName.symbol, 3574 "Non-extensible derived type '%s' may not be used with CLASS" 3575 " keyword"_err_en_US); 3576 } 3577 } 3578 3579 bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Record &) { 3580 // TODO 3581 return true; 3582 } 3583 3584 void DeclarationVisitor::Post(const parser::DerivedTypeSpec &x) { 3585 const auto &typeName{std::get<parser::Name>(x.t)}; 3586 auto spec{ResolveDerivedType(typeName)}; 3587 if (!spec) { 3588 return; 3589 } 3590 bool seenAnyName{false}; 3591 for (const auto &typeParamSpec : 3592 std::get<std::list<parser::TypeParamSpec>>(x.t)) { 3593 const auto &optKeyword{ 3594 std::get<std::optional<parser::Keyword>>(typeParamSpec.t)}; 3595 std::optional<SourceName> name; 3596 if (optKeyword) { 3597 seenAnyName = true; 3598 name = optKeyword->v.source; 3599 } else if (seenAnyName) { 3600 Say(typeName.source, "Type parameter value must have a name"_err_en_US); 3601 continue; 3602 } 3603 const auto &value{std::get<parser::TypeParamValue>(typeParamSpec.t)}; 3604 // The expressions in a derived type specifier whose values define 3605 // non-defaulted type parameters are evaluated (folded) in the enclosing 3606 // scope. The KIND/LEN distinction is resolved later in 3607 // DerivedTypeSpec::CookParameters(). 3608 ParamValue param{GetParamValue(value, common::TypeParamAttr::Kind)}; 3609 if (!param.isExplicit() || param.GetExplicit()) { 3610 spec->AddRawParamValue(optKeyword, std::move(param)); 3611 } 3612 } 3613 3614 // The DerivedTypeSpec *spec is used initially as a search key. 3615 // If it turns out to have the same name and actual parameter 3616 // value expressions as another DerivedTypeSpec in the current 3617 // scope does, then we'll use that extant spec; otherwise, when this 3618 // spec is distinct from all derived types previously instantiated 3619 // in the current scope, this spec will be moved into that collection. 3620 const auto &dtDetails{spec->typeSymbol().get<DerivedTypeDetails>()}; 3621 auto category{GetDeclTypeSpecCategory()}; 3622 if (dtDetails.isForwardReferenced()) { 3623 DeclTypeSpec &type{currScope().MakeDerivedType(category, std::move(*spec))}; 3624 SetDeclTypeSpec(type); 3625 return; 3626 } 3627 // Normalize parameters to produce a better search key. 3628 spec->CookParameters(GetFoldingContext()); 3629 if (!spec->MightBeParameterized()) { 3630 spec->EvaluateParameters(GetFoldingContext()); 3631 } 3632 if (const DeclTypeSpec * 3633 extant{currScope().FindInstantiatedDerivedType(*spec, category)}) { 3634 // This derived type and parameter expressions (if any) are already present 3635 // in this scope. 3636 SetDeclTypeSpec(*extant); 3637 } else { 3638 DeclTypeSpec &type{currScope().MakeDerivedType(category, std::move(*spec))}; 3639 DerivedTypeSpec &derived{type.derivedTypeSpec()}; 3640 if (derived.MightBeParameterized() && 3641 currScope().IsParameterizedDerivedType()) { 3642 // Defer instantiation; use the derived type's definition's scope. 3643 derived.set_scope(DEREF(spec->typeSymbol().scope())); 3644 } else { 3645 auto restorer{ 3646 GetFoldingContext().messages().SetLocation(currStmtSource().value())}; 3647 derived.Instantiate(currScope(), context()); 3648 } 3649 SetDeclTypeSpec(type); 3650 } 3651 // Capture the DerivedTypeSpec in the parse tree for use in building 3652 // structure constructor expressions. 3653 x.derivedTypeSpec = &GetDeclTypeSpec()->derivedTypeSpec(); 3654 } 3655 3656 // The descendents of DerivedTypeDef in the parse tree are visited directly 3657 // in this Pre() routine so that recursive use of the derived type can be 3658 // supported in the components. 3659 bool DeclarationVisitor::Pre(const parser::DerivedTypeDef &x) { 3660 auto &stmt{std::get<parser::Statement<parser::DerivedTypeStmt>>(x.t)}; 3661 Walk(stmt); 3662 Walk(std::get<std::list<parser::Statement<parser::TypeParamDefStmt>>>(x.t)); 3663 auto &scope{currScope()}; 3664 CHECK(scope.symbol()); 3665 CHECK(scope.symbol()->scope() == &scope); 3666 auto &details{scope.symbol()->get<DerivedTypeDetails>()}; 3667 std::set<SourceName> paramNames; 3668 for (auto ¶mName : std::get<std::list<parser::Name>>(stmt.statement.t)) { 3669 details.add_paramName(paramName.source); 3670 auto *symbol{FindInScope(scope, paramName)}; 3671 if (!symbol) { 3672 Say(paramName, 3673 "No definition found for type parameter '%s'"_err_en_US); // C742 3674 // No symbol for a type param. Create one and mark it as containing an 3675 // error to improve subsequent semantic processing 3676 BeginAttrs(); 3677 Symbol *typeParam{MakeTypeSymbol( 3678 paramName, TypeParamDetails{common::TypeParamAttr::Len})}; 3679 typeParam->set(Symbol::Flag::Error); 3680 EndAttrs(); 3681 } else if (!symbol->has<TypeParamDetails>()) { 3682 Say2(paramName, "'%s' is not defined as a type parameter"_err_en_US, 3683 *symbol, "Definition of '%s'"_en_US); // C741 3684 } 3685 if (!paramNames.insert(paramName.source).second) { 3686 Say(paramName, 3687 "Duplicate type parameter name: '%s'"_err_en_US); // C731 3688 } 3689 } 3690 for (const auto &[name, symbol] : currScope()) { 3691 if (symbol->has<TypeParamDetails>() && !paramNames.count(name)) { 3692 SayDerivedType(name, 3693 "'%s' is not a type parameter of this derived type"_err_en_US, 3694 currScope()); // C741 3695 } 3696 } 3697 Walk(std::get<std::list<parser::Statement<parser::PrivateOrSequence>>>(x.t)); 3698 const auto &componentDefs{ 3699 std::get<std::list<parser::Statement<parser::ComponentDefStmt>>>(x.t)}; 3700 Walk(componentDefs); 3701 if (derivedTypeInfo_.sequence) { 3702 details.set_sequence(true); 3703 if (componentDefs.empty()) { // C740 3704 Say(stmt.source, 3705 "A sequence type must have at least one component"_err_en_US); 3706 } 3707 if (!details.paramNames().empty()) { // C740 3708 Say(stmt.source, 3709 "A sequence type may not have type parameters"_err_en_US); 3710 } 3711 if (derivedTypeInfo_.extends) { // C735 3712 Say(stmt.source, 3713 "A sequence type may not have the EXTENDS attribute"_err_en_US); 3714 } else { 3715 for (const auto &componentName : details.componentNames()) { 3716 const Symbol *componentSymbol{scope.FindComponent(componentName)}; 3717 if (componentSymbol && componentSymbol->has<ObjectEntityDetails>()) { 3718 const auto &componentDetails{ 3719 componentSymbol->get<ObjectEntityDetails>()}; 3720 const DeclTypeSpec *componentType{componentDetails.type()}; 3721 if (componentType && // C740 3722 !componentType->AsIntrinsic() && 3723 !componentType->IsSequenceType()) { 3724 Say(componentSymbol->name(), 3725 "A sequence type data component must either be of an" 3726 " intrinsic type or a derived sequence type"_err_en_US); 3727 } 3728 } 3729 } 3730 } 3731 } 3732 Walk(std::get<std::optional<parser::TypeBoundProcedurePart>>(x.t)); 3733 Walk(std::get<parser::Statement<parser::EndTypeStmt>>(x.t)); 3734 derivedTypeInfo_ = {}; 3735 PopScope(); 3736 return false; 3737 } 3738 bool DeclarationVisitor::Pre(const parser::DerivedTypeStmt &) { 3739 return BeginAttrs(); 3740 } 3741 void DeclarationVisitor::Post(const parser::DerivedTypeStmt &x) { 3742 auto &name{std::get<parser::Name>(x.t)}; 3743 // Resolve the EXTENDS() clause before creating the derived 3744 // type's symbol to foil attempts to recursively extend a type. 3745 auto *extendsName{derivedTypeInfo_.extends}; 3746 std::optional<DerivedTypeSpec> extendsType{ 3747 ResolveExtendsType(name, extendsName)}; 3748 auto &symbol{MakeSymbol(name, GetAttrs(), DerivedTypeDetails{})}; 3749 symbol.ReplaceName(name.source); 3750 derivedTypeInfo_.type = &symbol; 3751 PushScope(Scope::Kind::DerivedType, &symbol); 3752 if (extendsType) { 3753 // Declare the "parent component"; private if the type is. 3754 // Any symbol stored in the EXTENDS() clause is temporarily 3755 // hidden so that a new symbol can be created for the parent 3756 // component without producing spurious errors about already 3757 // existing. 3758 const Symbol &extendsSymbol{extendsType->typeSymbol()}; 3759 auto restorer{common::ScopedSet(extendsName->symbol, nullptr)}; 3760 if (OkToAddComponent(*extendsName, &extendsSymbol)) { 3761 auto &comp{DeclareEntity<ObjectEntityDetails>(*extendsName, Attrs{})}; 3762 comp.attrs().set( 3763 Attr::PRIVATE, extendsSymbol.attrs().test(Attr::PRIVATE)); 3764 comp.set(Symbol::Flag::ParentComp); 3765 DeclTypeSpec &type{currScope().MakeDerivedType( 3766 DeclTypeSpec::TypeDerived, std::move(*extendsType))}; 3767 type.derivedTypeSpec().set_scope(*extendsSymbol.scope()); 3768 comp.SetType(type); 3769 DerivedTypeDetails &details{symbol.get<DerivedTypeDetails>()}; 3770 details.add_component(comp); 3771 } 3772 } 3773 EndAttrs(); 3774 } 3775 3776 void DeclarationVisitor::Post(const parser::TypeParamDefStmt &x) { 3777 auto *type{GetDeclTypeSpec()}; 3778 auto attr{std::get<common::TypeParamAttr>(x.t)}; 3779 for (auto &decl : std::get<std::list<parser::TypeParamDecl>>(x.t)) { 3780 auto &name{std::get<parser::Name>(decl.t)}; 3781 if (Symbol * symbol{MakeTypeSymbol(name, TypeParamDetails{attr})}) { 3782 SetType(name, *type); 3783 if (auto &init{ 3784 std::get<std::optional<parser::ScalarIntConstantExpr>>(decl.t)}) { 3785 if (auto maybeExpr{EvaluateConvertedExpr( 3786 *symbol, *init, init->thing.thing.thing.value().source)}) { 3787 auto *intExpr{std::get_if<SomeIntExpr>(&maybeExpr->u)}; 3788 CHECK(intExpr); 3789 symbol->get<TypeParamDetails>().set_init(std::move(*intExpr)); 3790 } 3791 } 3792 } 3793 } 3794 EndDecl(); 3795 } 3796 bool DeclarationVisitor::Pre(const parser::TypeAttrSpec::Extends &x) { 3797 if (derivedTypeInfo_.extends) { 3798 Say(currStmtSource().value(), 3799 "Attribute 'EXTENDS' cannot be used more than once"_err_en_US); 3800 } else { 3801 derivedTypeInfo_.extends = &x.v; 3802 } 3803 return false; 3804 } 3805 3806 bool DeclarationVisitor::Pre(const parser::PrivateStmt &) { 3807 if (!currScope().parent().IsModule()) { 3808 Say("PRIVATE is only allowed in a derived type that is" 3809 " in a module"_err_en_US); // C766 3810 } else if (derivedTypeInfo_.sawContains) { 3811 derivedTypeInfo_.privateBindings = true; 3812 } else if (!derivedTypeInfo_.privateComps) { 3813 derivedTypeInfo_.privateComps = true; 3814 } else { 3815 Say("PRIVATE may not appear more than once in" 3816 " derived type components"_en_US); // C738 3817 } 3818 return false; 3819 } 3820 bool DeclarationVisitor::Pre(const parser::SequenceStmt &) { 3821 if (derivedTypeInfo_.sequence) { 3822 Say("SEQUENCE may not appear more than once in" 3823 " derived type components"_en_US); // C738 3824 } 3825 derivedTypeInfo_.sequence = true; 3826 return false; 3827 } 3828 void DeclarationVisitor::Post(const parser::ComponentDecl &x) { 3829 const auto &name{std::get<parser::Name>(x.t)}; 3830 auto attrs{GetAttrs()}; 3831 if (derivedTypeInfo_.privateComps && 3832 !attrs.HasAny({Attr::PUBLIC, Attr::PRIVATE})) { 3833 attrs.set(Attr::PRIVATE); 3834 } 3835 if (const auto *declType{GetDeclTypeSpec()}) { 3836 if (const auto *derived{declType->AsDerived()}) { 3837 if (!attrs.HasAny({Attr::POINTER, Attr::ALLOCATABLE})) { 3838 if (derivedTypeInfo_.type == &derived->typeSymbol()) { // C744 3839 Say("Recursive use of the derived type requires " 3840 "POINTER or ALLOCATABLE"_err_en_US); 3841 } 3842 } 3843 if (!coarraySpec().empty()) { // C747 3844 if (IsTeamType(derived)) { 3845 Say("A coarray component may not be of type TEAM_TYPE from " 3846 "ISO_FORTRAN_ENV"_err_en_US); 3847 } else { 3848 if (IsIsoCType(derived)) { 3849 Say("A coarray component may not be of type C_PTR or C_FUNPTR from " 3850 "ISO_C_BINDING"_err_en_US); 3851 } 3852 } 3853 } 3854 if (auto it{FindCoarrayUltimateComponent(*derived)}) { // C748 3855 std::string ultimateName{it.BuildResultDesignatorName()}; 3856 // Strip off the leading "%" 3857 if (ultimateName.length() > 1) { 3858 ultimateName.erase(0, 1); 3859 if (attrs.HasAny({Attr::POINTER, Attr::ALLOCATABLE})) { 3860 evaluate::AttachDeclaration( 3861 Say(name.source, 3862 "A component with a POINTER or ALLOCATABLE attribute may " 3863 "not " 3864 "be of a type with a coarray ultimate component (named " 3865 "'%s')"_err_en_US, 3866 ultimateName), 3867 derived->typeSymbol()); 3868 } 3869 if (!arraySpec().empty() || !coarraySpec().empty()) { 3870 evaluate::AttachDeclaration( 3871 Say(name.source, 3872 "An array or coarray component may not be of a type with a " 3873 "coarray ultimate component (named '%s')"_err_en_US, 3874 ultimateName), 3875 derived->typeSymbol()); 3876 } 3877 } 3878 } 3879 } 3880 } 3881 if (OkToAddComponent(name)) { 3882 auto &symbol{DeclareObjectEntity(name, attrs)}; 3883 if (symbol.has<ObjectEntityDetails>()) { 3884 if (auto &init{std::get<std::optional<parser::Initialization>>(x.t)}) { 3885 Initialization(name, *init, true); 3886 } 3887 } 3888 currScope().symbol()->get<DerivedTypeDetails>().add_component(symbol); 3889 } 3890 ClearArraySpec(); 3891 ClearCoarraySpec(); 3892 } 3893 bool DeclarationVisitor::Pre(const parser::ProcedureDeclarationStmt &) { 3894 CHECK(!interfaceName_); 3895 return BeginDecl(); 3896 } 3897 void DeclarationVisitor::Post(const parser::ProcedureDeclarationStmt &) { 3898 interfaceName_ = nullptr; 3899 EndDecl(); 3900 } 3901 bool DeclarationVisitor::Pre(const parser::DataComponentDefStmt &x) { 3902 // Overrides parse tree traversal so as to handle attributes first, 3903 // so POINTER & ALLOCATABLE enable forward references to derived types. 3904 Walk(std::get<std::list<parser::ComponentAttrSpec>>(x.t)); 3905 set_allowForwardReferenceToDerivedType( 3906 GetAttrs().HasAny({Attr::POINTER, Attr::ALLOCATABLE})); 3907 Walk(std::get<parser::DeclarationTypeSpec>(x.t)); 3908 set_allowForwardReferenceToDerivedType(false); 3909 Walk(std::get<std::list<parser::ComponentDecl>>(x.t)); 3910 return false; 3911 } 3912 bool DeclarationVisitor::Pre(const parser::ProcComponentDefStmt &) { 3913 CHECK(!interfaceName_); 3914 return true; 3915 } 3916 void DeclarationVisitor::Post(const parser::ProcComponentDefStmt &stmt) { 3917 interfaceName_ = nullptr; 3918 } 3919 bool DeclarationVisitor::Pre(const parser::ProcPointerInit &x) { 3920 if (auto *name{std::get_if<parser::Name>(&x.u)}) { 3921 return !NameIsKnownOrIntrinsic(*name); 3922 } 3923 return true; 3924 } 3925 void DeclarationVisitor::Post(const parser::ProcInterface &x) { 3926 if (auto *name{std::get_if<parser::Name>(&x.u)}) { 3927 interfaceName_ = name; 3928 NoteInterfaceName(*name); 3929 } 3930 } 3931 3932 void DeclarationVisitor::Post(const parser::ProcDecl &x) { 3933 const auto &name{std::get<parser::Name>(x.t)}; 3934 ProcInterface interface; 3935 if (interfaceName_) { 3936 interface.set_symbol(*interfaceName_->symbol); 3937 } else if (auto *type{GetDeclTypeSpec()}) { 3938 interface.set_type(*type); 3939 } 3940 auto attrs{HandleSaveName(name.source, GetAttrs())}; 3941 DerivedTypeDetails *dtDetails{nullptr}; 3942 if (Symbol * symbol{currScope().symbol()}) { 3943 dtDetails = symbol->detailsIf<DerivedTypeDetails>(); 3944 } 3945 if (!dtDetails) { 3946 attrs.set(Attr::EXTERNAL); 3947 } 3948 Symbol &symbol{DeclareProcEntity(name, attrs, interface)}; 3949 symbol.ReplaceName(name.source); 3950 if (dtDetails) { 3951 dtDetails->add_component(symbol); 3952 } 3953 } 3954 3955 bool DeclarationVisitor::Pre(const parser::TypeBoundProcedurePart &) { 3956 derivedTypeInfo_.sawContains = true; 3957 return true; 3958 } 3959 3960 // Resolve binding names from type-bound generics, saved in genericBindings_. 3961 void DeclarationVisitor::Post(const parser::TypeBoundProcedurePart &) { 3962 // track specifics seen for the current generic to detect duplicates: 3963 const Symbol *currGeneric{nullptr}; 3964 std::set<SourceName> specifics; 3965 for (const auto &[generic, bindingName] : genericBindings_) { 3966 if (generic != currGeneric) { 3967 currGeneric = generic; 3968 specifics.clear(); 3969 } 3970 auto [it, inserted]{specifics.insert(bindingName->source)}; 3971 if (!inserted) { 3972 Say(*bindingName, // C773 3973 "Binding name '%s' was already specified for generic '%s'"_err_en_US, 3974 bindingName->source, generic->name()) 3975 .Attach(*it, "Previous specification of '%s'"_en_US, *it); 3976 continue; 3977 } 3978 auto *symbol{FindInTypeOrParents(*bindingName)}; 3979 if (!symbol) { 3980 Say(*bindingName, // C772 3981 "Binding name '%s' not found in this derived type"_err_en_US); 3982 } else if (!symbol->has<ProcBindingDetails>()) { 3983 SayWithDecl(*bindingName, *symbol, // C772 3984 "'%s' is not the name of a specific binding of this type"_err_en_US); 3985 } else { 3986 generic->get<GenericDetails>().AddSpecificProc( 3987 *symbol, bindingName->source); 3988 } 3989 } 3990 genericBindings_.clear(); 3991 } 3992 3993 void DeclarationVisitor::Post(const parser::ContainsStmt &) { 3994 if (derivedTypeInfo_.sequence) { 3995 Say("A sequence type may not have a CONTAINS statement"_err_en_US); // C740 3996 } 3997 } 3998 3999 void DeclarationVisitor::Post( 4000 const parser::TypeBoundProcedureStmt::WithoutInterface &x) { 4001 if (GetAttrs().test(Attr::DEFERRED)) { // C783 4002 Say("DEFERRED is only allowed when an interface-name is provided"_err_en_US); 4003 } 4004 for (auto &declaration : x.declarations) { 4005 auto &bindingName{std::get<parser::Name>(declaration.t)}; 4006 auto &optName{std::get<std::optional<parser::Name>>(declaration.t)}; 4007 const parser::Name &procedureName{optName ? *optName : bindingName}; 4008 Symbol *procedure{FindSymbol(procedureName)}; 4009 if (!procedure) { 4010 procedure = NoteInterfaceName(procedureName); 4011 } 4012 if (auto *s{MakeTypeSymbol(bindingName, ProcBindingDetails{*procedure})}) { 4013 SetPassNameOn(*s); 4014 if (GetAttrs().test(Attr::DEFERRED)) { 4015 context().SetError(*s); 4016 } 4017 } 4018 } 4019 } 4020 4021 void DeclarationVisitor::CheckBindings( 4022 const parser::TypeBoundProcedureStmt::WithoutInterface &tbps) { 4023 CHECK(currScope().IsDerivedType()); 4024 for (auto &declaration : tbps.declarations) { 4025 auto &bindingName{std::get<parser::Name>(declaration.t)}; 4026 if (Symbol * binding{FindInScope(currScope(), bindingName)}) { 4027 if (auto *details{binding->detailsIf<ProcBindingDetails>()}) { 4028 const Symbol *procedure{FindSubprogram(details->symbol())}; 4029 if (!CanBeTypeBoundProc(procedure)) { 4030 if (details->symbol().name() != binding->name()) { 4031 Say(binding->name(), 4032 "The binding of '%s' ('%s') must be either an accessible " 4033 "module procedure or an external procedure with " 4034 "an explicit interface"_err_en_US, 4035 binding->name(), details->symbol().name()); 4036 } else { 4037 Say(binding->name(), 4038 "'%s' must be either an accessible module procedure " 4039 "or an external procedure with an explicit interface"_err_en_US, 4040 binding->name()); 4041 } 4042 context().SetError(*binding); 4043 } 4044 } 4045 } 4046 } 4047 } 4048 4049 void DeclarationVisitor::Post( 4050 const parser::TypeBoundProcedureStmt::WithInterface &x) { 4051 if (!GetAttrs().test(Attr::DEFERRED)) { // C783 4052 Say("DEFERRED is required when an interface-name is provided"_err_en_US); 4053 } 4054 if (Symbol * interface{NoteInterfaceName(x.interfaceName)}) { 4055 for (auto &bindingName : x.bindingNames) { 4056 if (auto *s{ 4057 MakeTypeSymbol(bindingName, ProcBindingDetails{*interface})}) { 4058 SetPassNameOn(*s); 4059 if (!GetAttrs().test(Attr::DEFERRED)) { 4060 context().SetError(*s); 4061 } 4062 } 4063 } 4064 } 4065 } 4066 4067 void DeclarationVisitor::Post(const parser::FinalProcedureStmt &x) { 4068 for (auto &name : x.v) { 4069 MakeTypeSymbol(name, FinalProcDetails{}); 4070 } 4071 } 4072 4073 bool DeclarationVisitor::Pre(const parser::TypeBoundGenericStmt &x) { 4074 const auto &accessSpec{std::get<std::optional<parser::AccessSpec>>(x.t)}; 4075 const auto &genericSpec{std::get<Indirection<parser::GenericSpec>>(x.t)}; 4076 const auto &bindingNames{std::get<std::list<parser::Name>>(x.t)}; 4077 auto info{GenericSpecInfo{genericSpec.value()}}; 4078 SourceName symbolName{info.symbolName()}; 4079 bool isPrivate{accessSpec ? accessSpec->v == parser::AccessSpec::Kind::Private 4080 : derivedTypeInfo_.privateBindings}; 4081 auto *genericSymbol{info.FindInScope(context(), currScope())}; 4082 if (genericSymbol) { 4083 if (!genericSymbol->has<GenericDetails>()) { 4084 genericSymbol = nullptr; // MakeTypeSymbol will report the error below 4085 } 4086 } else { 4087 // look in parent types: 4088 Symbol *inheritedSymbol{nullptr}; 4089 for (const auto &name : info.GetAllNames(context())) { 4090 inheritedSymbol = currScope().FindComponent(SourceName{name}); 4091 if (inheritedSymbol) { 4092 break; 4093 } 4094 } 4095 if (inheritedSymbol && inheritedSymbol->has<GenericDetails>()) { 4096 CheckAccessibility(symbolName, isPrivate, *inheritedSymbol); // C771 4097 } 4098 } 4099 if (genericSymbol) { 4100 CheckAccessibility(symbolName, isPrivate, *genericSymbol); // C771 4101 } else { 4102 genericSymbol = MakeTypeSymbol(symbolName, GenericDetails{}); 4103 if (!genericSymbol) { 4104 return false; 4105 } 4106 if (isPrivate) { 4107 genericSymbol->attrs().set(Attr::PRIVATE); 4108 } 4109 } 4110 for (const parser::Name &bindingName : bindingNames) { 4111 genericBindings_.emplace(genericSymbol, &bindingName); 4112 } 4113 info.Resolve(genericSymbol); 4114 return false; 4115 } 4116 4117 bool DeclarationVisitor::Pre(const parser::AllocateStmt &) { 4118 BeginDeclTypeSpec(); 4119 return true; 4120 } 4121 void DeclarationVisitor::Post(const parser::AllocateStmt &) { 4122 EndDeclTypeSpec(); 4123 } 4124 4125 bool DeclarationVisitor::Pre(const parser::StructureConstructor &x) { 4126 auto &parsedType{std::get<parser::DerivedTypeSpec>(x.t)}; 4127 const DeclTypeSpec *type{ProcessTypeSpec(parsedType)}; 4128 if (!type) { 4129 return false; 4130 } 4131 const DerivedTypeSpec *spec{type->AsDerived()}; 4132 const Scope *typeScope{spec ? spec->scope() : nullptr}; 4133 if (!typeScope) { 4134 return false; 4135 } 4136 4137 // N.B C7102 is implicitly enforced by having inaccessible types not 4138 // being found in resolution. 4139 // More constraints are enforced in expression.cpp so that they 4140 // can apply to structure constructors that have been converted 4141 // from misparsed function references. 4142 for (const auto &component : 4143 std::get<std::list<parser::ComponentSpec>>(x.t)) { 4144 // Visit the component spec expression, but not the keyword, since 4145 // we need to resolve its symbol in the scope of the derived type. 4146 Walk(std::get<parser::ComponentDataSource>(component.t)); 4147 if (const auto &kw{std::get<std::optional<parser::Keyword>>(component.t)}) { 4148 FindInTypeOrParents(*typeScope, kw->v); 4149 } 4150 } 4151 return false; 4152 } 4153 4154 bool DeclarationVisitor::Pre(const parser::BasedPointerStmt &x) { 4155 for (const parser::BasedPointer &bp : x.v) { 4156 const parser::ObjectName &pointerName{std::get<0>(bp.t)}; 4157 const parser::ObjectName &pointeeName{std::get<1>(bp.t)}; 4158 auto *pointer{FindSymbol(pointerName)}; 4159 if (!pointer) { 4160 pointer = &MakeSymbol(pointerName, ObjectEntityDetails{}); 4161 } else if (!ConvertToObjectEntity(*pointer) || IsNamedConstant(*pointer)) { 4162 SayWithDecl(pointerName, *pointer, "'%s' is not a variable"_err_en_US); 4163 } else if (pointer->Rank() > 0) { 4164 SayWithDecl(pointerName, *pointer, 4165 "Cray pointer '%s' must be a scalar"_err_en_US); 4166 } else if (pointer->test(Symbol::Flag::CrayPointee)) { 4167 Say(pointerName, 4168 "'%s' cannot be a Cray pointer as it is already a Cray pointee"_err_en_US); 4169 } 4170 pointer->set(Symbol::Flag::CrayPointer); 4171 const DeclTypeSpec &pointerType{MakeNumericType(TypeCategory::Integer, 4172 context().defaultKinds().subscriptIntegerKind())}; 4173 const auto *type{pointer->GetType()}; 4174 if (!type) { 4175 pointer->SetType(pointerType); 4176 } else if (*type != pointerType) { 4177 Say(pointerName.source, "Cray pointer '%s' must have type %s"_err_en_US, 4178 pointerName.source, pointerType.AsFortran()); 4179 } 4180 if (ResolveName(pointeeName)) { 4181 Symbol &pointee{*pointeeName.symbol}; 4182 if (pointee.has<UseDetails>()) { 4183 Say(pointeeName, 4184 "'%s' cannot be a Cray pointee as it is use-associated"_err_en_US); 4185 continue; 4186 } else if (!ConvertToObjectEntity(pointee) || IsNamedConstant(pointee)) { 4187 Say(pointeeName, "'%s' is not a variable"_err_en_US); 4188 continue; 4189 } else if (pointee.test(Symbol::Flag::CrayPointer)) { 4190 Say(pointeeName, 4191 "'%s' cannot be a Cray pointee as it is already a Cray pointer"_err_en_US); 4192 } else if (pointee.test(Symbol::Flag::CrayPointee)) { 4193 Say(pointeeName, 4194 "'%s' was already declared as a Cray pointee"_err_en_US); 4195 } else { 4196 pointee.set(Symbol::Flag::CrayPointee); 4197 } 4198 if (const auto *pointeeType{pointee.GetType()}) { 4199 if (const auto *derived{pointeeType->AsDerived()}) { 4200 if (!derived->typeSymbol().get<DerivedTypeDetails>().sequence()) { 4201 Say(pointeeName, 4202 "Type of Cray pointee '%s' is a non-sequence derived type"_err_en_US); 4203 } 4204 } 4205 } 4206 // process the pointee array-spec, if present 4207 BeginArraySpec(); 4208 Walk(std::get<std::optional<parser::ArraySpec>>(bp.t)); 4209 const auto &spec{arraySpec()}; 4210 if (!spec.empty()) { 4211 auto &details{pointee.get<ObjectEntityDetails>()}; 4212 if (details.shape().empty()) { 4213 details.set_shape(spec); 4214 } else { 4215 SayWithDecl(pointeeName, pointee, 4216 "Array spec was already declared for '%s'"_err_en_US); 4217 } 4218 } 4219 ClearArraySpec(); 4220 currScope().add_crayPointer(pointeeName.source, *pointer); 4221 } 4222 } 4223 return false; 4224 } 4225 4226 bool DeclarationVisitor::Pre(const parser::NamelistStmt::Group &x) { 4227 if (!CheckNotInBlock("NAMELIST")) { // C1107 4228 return false; 4229 } 4230 4231 NamelistDetails details; 4232 for (const auto &name : std::get<std::list<parser::Name>>(x.t)) { 4233 auto *symbol{FindSymbol(name)}; 4234 if (!symbol) { 4235 symbol = &MakeSymbol(name, ObjectEntityDetails{}); 4236 ApplyImplicitRules(*symbol); 4237 } else if (!ConvertToObjectEntity(*symbol)) { 4238 SayWithDecl(name, *symbol, "'%s' is not a variable"_err_en_US); 4239 } 4240 details.add_object(*symbol); 4241 } 4242 4243 const auto &groupName{std::get<parser::Name>(x.t)}; 4244 auto *groupSymbol{FindInScope(currScope(), groupName)}; 4245 if (!groupSymbol || !groupSymbol->has<NamelistDetails>()) { 4246 groupSymbol = &MakeSymbol(groupName, std::move(details)); 4247 groupSymbol->ReplaceName(groupName.source); 4248 } 4249 groupSymbol->get<NamelistDetails>().add_objects(details.objects()); 4250 return false; 4251 } 4252 4253 bool DeclarationVisitor::Pre(const parser::IoControlSpec &x) { 4254 if (const auto *name{std::get_if<parser::Name>(&x.u)}) { 4255 auto *symbol{FindSymbol(*name)}; 4256 if (!symbol) { 4257 Say(*name, "Namelist group '%s' not found"_err_en_US); 4258 } else if (!symbol->GetUltimate().has<NamelistDetails>()) { 4259 SayWithDecl( 4260 *name, *symbol, "'%s' is not the name of a namelist group"_err_en_US); 4261 } 4262 } 4263 return true; 4264 } 4265 4266 bool DeclarationVisitor::Pre(const parser::CommonStmt::Block &x) { 4267 CheckNotInBlock("COMMON"); // C1107 4268 const auto &optName{std::get<std::optional<parser::Name>>(x.t)}; 4269 parser::Name blankCommon; 4270 blankCommon.source = 4271 SourceName{currStmtSource().value().begin(), std::size_t{0}}; 4272 CHECK(!commonBlockInfo_.curr); 4273 commonBlockInfo_.curr = 4274 &MakeCommonBlockSymbol(optName ? *optName : blankCommon); 4275 return true; 4276 } 4277 4278 void DeclarationVisitor::Post(const parser::CommonStmt::Block &) { 4279 commonBlockInfo_.curr = nullptr; 4280 } 4281 4282 bool DeclarationVisitor::Pre(const parser::CommonBlockObject &) { 4283 BeginArraySpec(); 4284 return true; 4285 } 4286 4287 void DeclarationVisitor::Post(const parser::CommonBlockObject &x) { 4288 CHECK(commonBlockInfo_.curr); 4289 const auto &name{std::get<parser::Name>(x.t)}; 4290 auto &symbol{DeclareObjectEntity(name, Attrs{})}; 4291 ClearArraySpec(); 4292 ClearCoarraySpec(); 4293 auto *details{symbol.detailsIf<ObjectEntityDetails>()}; 4294 if (!details) { 4295 return; // error was reported 4296 } 4297 commonBlockInfo_.curr->get<CommonBlockDetails>().add_object(symbol); 4298 auto pair{commonBlockInfo_.names.insert(name.source)}; 4299 if (!pair.second) { 4300 const SourceName &prev{*pair.first}; 4301 Say2(name.source, "'%s' is already in a COMMON block"_err_en_US, prev, 4302 "Previous occurrence of '%s' in a COMMON block"_en_US); 4303 return; 4304 } 4305 details->set_commonBlock(*commonBlockInfo_.curr); 4306 } 4307 4308 bool DeclarationVisitor::Pre(const parser::EquivalenceStmt &x) { 4309 // save equivalence sets to be processed after specification part 4310 CheckNotInBlock("EQUIVALENCE"); // C1107 4311 for (const std::list<parser::EquivalenceObject> &set : x.v) { 4312 equivalenceSets_.push_back(&set); 4313 } 4314 return false; // don't implicitly declare names yet 4315 } 4316 4317 void DeclarationVisitor::CheckEquivalenceSets() { 4318 EquivalenceSets equivSets{context()}; 4319 for (const auto *set : equivalenceSets_) { 4320 const auto &source{set->front().v.value().source}; 4321 if (set->size() <= 1) { // R871 4322 Say(source, "Equivalence set must have more than one object"_err_en_US); 4323 } 4324 for (const parser::EquivalenceObject &object : *set) { 4325 const auto &designator{object.v.value()}; 4326 // The designator was not resolved when it was encountered so do it now. 4327 // AnalyzeExpr causes array sections to be changed to substrings as needed 4328 Walk(designator); 4329 if (AnalyzeExpr(context(), designator)) { 4330 equivSets.AddToSet(designator); 4331 } 4332 } 4333 equivSets.FinishSet(source); 4334 } 4335 for (auto &set : equivSets.sets()) { 4336 if (!set.empty()) { 4337 currScope().add_equivalenceSet(std::move(set)); 4338 } 4339 } 4340 equivalenceSets_.clear(); 4341 } 4342 4343 bool DeclarationVisitor::Pre(const parser::SaveStmt &x) { 4344 if (x.v.empty()) { 4345 saveInfo_.saveAll = currStmtSource(); 4346 } else { 4347 for (const parser::SavedEntity &y : x.v) { 4348 auto kind{std::get<parser::SavedEntity::Kind>(y.t)}; 4349 const auto &name{std::get<parser::Name>(y.t)}; 4350 if (kind == parser::SavedEntity::Kind::Common) { 4351 MakeCommonBlockSymbol(name); 4352 AddSaveName(saveInfo_.commons, name.source); 4353 } else { 4354 HandleAttributeStmt(Attr::SAVE, name); 4355 } 4356 } 4357 } 4358 return false; 4359 } 4360 4361 void DeclarationVisitor::CheckSaveStmts() { 4362 for (const SourceName &name : saveInfo_.entities) { 4363 auto *symbol{FindInScope(currScope(), name)}; 4364 if (!symbol) { 4365 // error was reported 4366 } else if (saveInfo_.saveAll) { 4367 // C889 - note that pgi, ifort, xlf do not enforce this constraint 4368 Say2(name, 4369 "Explicit SAVE of '%s' is redundant due to global SAVE statement"_err_en_US, 4370 *saveInfo_.saveAll, "Global SAVE statement"_en_US); 4371 } else if (auto msg{CheckSaveAttr(*symbol)}) { 4372 Say(name, std::move(*msg)); 4373 } else { 4374 SetSaveAttr(*symbol); 4375 } 4376 } 4377 for (const SourceName &name : saveInfo_.commons) { 4378 if (auto *symbol{currScope().FindCommonBlock(name)}) { 4379 auto &objects{symbol->get<CommonBlockDetails>().objects()}; 4380 if (objects.empty()) { 4381 if (currScope().kind() != Scope::Kind::Block) { 4382 Say(name, 4383 "'%s' appears as a COMMON block in a SAVE statement but not in" 4384 " a COMMON statement"_err_en_US); 4385 } else { // C1108 4386 Say(name, 4387 "SAVE statement in BLOCK construct may not contain a" 4388 " common block name '%s'"_err_en_US); 4389 } 4390 } else { 4391 for (auto &object : symbol->get<CommonBlockDetails>().objects()) { 4392 SetSaveAttr(*object); 4393 } 4394 } 4395 } 4396 } 4397 if (saveInfo_.saveAll) { 4398 // Apply SAVE attribute to applicable symbols 4399 for (auto pair : currScope()) { 4400 auto &symbol{*pair.second}; 4401 if (!CheckSaveAttr(symbol)) { 4402 SetSaveAttr(symbol); 4403 } 4404 } 4405 } 4406 saveInfo_ = {}; 4407 } 4408 4409 // If SAVE attribute can't be set on symbol, return error message. 4410 std::optional<MessageFixedText> DeclarationVisitor::CheckSaveAttr( 4411 const Symbol &symbol) { 4412 if (symbol.IsDummy()) { 4413 return "SAVE attribute may not be applied to dummy argument '%s'"_err_en_US; 4414 } else if (symbol.IsFuncResult()) { 4415 return "SAVE attribute may not be applied to function result '%s'"_err_en_US; 4416 } else if (symbol.has<ProcEntityDetails>() && 4417 !symbol.attrs().test(Attr::POINTER)) { 4418 return "Procedure '%s' with SAVE attribute must also have POINTER attribute"_err_en_US; 4419 } else { 4420 return std::nullopt; 4421 } 4422 } 4423 4424 // Instead of setting SAVE attribute, record the name in saveInfo_.entities. 4425 Attrs DeclarationVisitor::HandleSaveName(const SourceName &name, Attrs attrs) { 4426 if (attrs.test(Attr::SAVE)) { 4427 attrs.set(Attr::SAVE, false); 4428 AddSaveName(saveInfo_.entities, name); 4429 } 4430 return attrs; 4431 } 4432 4433 // Record a name in a set of those to be saved. 4434 void DeclarationVisitor::AddSaveName( 4435 std::set<SourceName> &set, const SourceName &name) { 4436 auto pair{set.insert(name)}; 4437 if (!pair.second) { 4438 Say2(name, "SAVE attribute was already specified on '%s'"_err_en_US, 4439 *pair.first, "Previous specification of SAVE attribute"_en_US); 4440 } 4441 } 4442 4443 // Set the SAVE attribute on symbol unless it is implicitly saved anyway. 4444 void DeclarationVisitor::SetSaveAttr(Symbol &symbol) { 4445 if (!IsSaved(symbol)) { 4446 symbol.attrs().set(Attr::SAVE); 4447 } 4448 } 4449 4450 // Check types of common block objects, now that they are known. 4451 void DeclarationVisitor::CheckCommonBlocks() { 4452 // check for empty common blocks 4453 for (const auto &pair : currScope().commonBlocks()) { 4454 const auto &symbol{*pair.second}; 4455 if (symbol.get<CommonBlockDetails>().objects().empty() && 4456 symbol.attrs().test(Attr::BIND_C)) { 4457 Say(symbol.name(), 4458 "'%s' appears as a COMMON block in a BIND statement but not in" 4459 " a COMMON statement"_err_en_US); 4460 } 4461 } 4462 // check objects in common blocks 4463 for (const auto &name : commonBlockInfo_.names) { 4464 const auto *symbol{currScope().FindSymbol(name)}; 4465 if (!symbol) { 4466 continue; 4467 } 4468 const auto &attrs{symbol->attrs()}; 4469 if (attrs.test(Attr::ALLOCATABLE)) { 4470 Say(name, 4471 "ALLOCATABLE object '%s' may not appear in a COMMON block"_err_en_US); 4472 } else if (attrs.test(Attr::BIND_C)) { 4473 Say(name, 4474 "Variable '%s' with BIND attribute may not appear in a COMMON block"_err_en_US); 4475 } else if (symbol->IsDummy()) { 4476 Say(name, 4477 "Dummy argument '%s' may not appear in a COMMON block"_err_en_US); 4478 } else if (symbol->IsFuncResult()) { 4479 Say(name, 4480 "Function result '%s' may not appear in a COMMON block"_err_en_US); 4481 } else if (const DeclTypeSpec * type{symbol->GetType()}) { 4482 if (type->category() == DeclTypeSpec::ClassStar) { 4483 Say(name, 4484 "Unlimited polymorphic pointer '%s' may not appear in a COMMON block"_err_en_US); 4485 } else if (const auto *derived{type->AsDerived()}) { 4486 auto &typeSymbol{derived->typeSymbol()}; 4487 if (!typeSymbol.attrs().test(Attr::BIND_C) && 4488 !typeSymbol.get<DerivedTypeDetails>().sequence()) { 4489 Say(name, 4490 "Derived type '%s' in COMMON block must have the BIND or" 4491 " SEQUENCE attribute"_err_en_US); 4492 } 4493 CheckCommonBlockDerivedType(name, typeSymbol); 4494 } 4495 } 4496 } 4497 commonBlockInfo_ = {}; 4498 } 4499 4500 Symbol &DeclarationVisitor::MakeCommonBlockSymbol(const parser::Name &name) { 4501 return Resolve(name, currScope().MakeCommonBlock(name.source)); 4502 } 4503 4504 bool DeclarationVisitor::NameIsKnownOrIntrinsic(const parser::Name &name) { 4505 return FindSymbol(name) || HandleUnrestrictedSpecificIntrinsicFunction(name); 4506 } 4507 4508 // Check if this derived type can be in a COMMON block. 4509 void DeclarationVisitor::CheckCommonBlockDerivedType( 4510 const SourceName &name, const Symbol &typeSymbol) { 4511 if (const auto *scope{typeSymbol.scope()}) { 4512 for (const auto &pair : *scope) { 4513 const Symbol &component{*pair.second}; 4514 if (component.attrs().test(Attr::ALLOCATABLE)) { 4515 Say2(name, 4516 "Derived type variable '%s' may not appear in a COMMON block" 4517 " due to ALLOCATABLE component"_err_en_US, 4518 component.name(), "Component with ALLOCATABLE attribute"_en_US); 4519 return; 4520 } 4521 if (const auto *details{component.detailsIf<ObjectEntityDetails>()}) { 4522 if (details->init()) { 4523 Say2(name, 4524 "Derived type variable '%s' may not appear in a COMMON block" 4525 " due to component with default initialization"_err_en_US, 4526 component.name(), "Component with default initialization"_en_US); 4527 return; 4528 } 4529 if (const auto *type{details->type()}) { 4530 if (const auto *derived{type->AsDerived()}) { 4531 CheckCommonBlockDerivedType(name, derived->typeSymbol()); 4532 } 4533 } 4534 } 4535 } 4536 } 4537 } 4538 4539 bool DeclarationVisitor::HandleUnrestrictedSpecificIntrinsicFunction( 4540 const parser::Name &name) { 4541 if (auto interface{context().intrinsics().IsSpecificIntrinsicFunction( 4542 name.source.ToString())}) { 4543 // Unrestricted specific intrinsic function names (e.g., "cos") 4544 // are acceptable as procedure interfaces. 4545 Symbol &symbol{ 4546 MakeSymbol(InclusiveScope(), name.source, Attrs{Attr::INTRINSIC})}; 4547 if (interface->IsElemental()) { 4548 symbol.attrs().set(Attr::ELEMENTAL); 4549 } 4550 symbol.set_details(ProcEntityDetails{}); 4551 Resolve(name, symbol); 4552 return true; 4553 } else { 4554 return false; 4555 } 4556 } 4557 4558 // Checks for all locality-specs: LOCAL, LOCAL_INIT, and SHARED 4559 bool DeclarationVisitor::PassesSharedLocalityChecks( 4560 const parser::Name &name, Symbol &symbol) { 4561 if (!IsVariableName(symbol)) { 4562 SayLocalMustBeVariable(name, symbol); // C1124 4563 return false; 4564 } 4565 if (symbol.owner() == currScope()) { // C1125 and C1126 4566 SayAlreadyDeclared(name, symbol); 4567 return false; 4568 } 4569 return true; 4570 } 4571 4572 // Checks for locality-specs LOCAL and LOCAL_INIT 4573 bool DeclarationVisitor::PassesLocalityChecks( 4574 const parser::Name &name, Symbol &symbol) { 4575 if (IsAllocatable(symbol)) { // C1128 4576 SayWithDecl(name, symbol, 4577 "ALLOCATABLE variable '%s' not allowed in a locality-spec"_err_en_US); 4578 return false; 4579 } 4580 if (IsOptional(symbol)) { // C1128 4581 SayWithDecl(name, symbol, 4582 "OPTIONAL argument '%s' not allowed in a locality-spec"_err_en_US); 4583 return false; 4584 } 4585 if (IsIntentIn(symbol)) { // C1128 4586 SayWithDecl(name, symbol, 4587 "INTENT IN argument '%s' not allowed in a locality-spec"_err_en_US); 4588 return false; 4589 } 4590 if (IsFinalizable(symbol)) { // C1128 4591 SayWithDecl(name, symbol, 4592 "Finalizable variable '%s' not allowed in a locality-spec"_err_en_US); 4593 return false; 4594 } 4595 if (IsCoarray(symbol)) { // C1128 4596 SayWithDecl( 4597 name, symbol, "Coarray '%s' not allowed in a locality-spec"_err_en_US); 4598 return false; 4599 } 4600 if (const DeclTypeSpec * type{symbol.GetType()}) { 4601 if (type->IsPolymorphic() && symbol.IsDummy() && 4602 !IsPointer(symbol)) { // C1128 4603 SayWithDecl(name, symbol, 4604 "Nonpointer polymorphic argument '%s' not allowed in a " 4605 "locality-spec"_err_en_US); 4606 return false; 4607 } 4608 } 4609 if (IsAssumedSizeArray(symbol)) { // C1128 4610 SayWithDecl(name, symbol, 4611 "Assumed size array '%s' not allowed in a locality-spec"_err_en_US); 4612 return false; 4613 } 4614 if (std::optional<MessageFixedText> msg{ 4615 WhyNotModifiable(symbol, currScope())}) { 4616 SayWithReason(name, symbol, 4617 "'%s' may not appear in a locality-spec because it is not " 4618 "definable"_err_en_US, 4619 std::move(*msg)); 4620 return false; 4621 } 4622 return PassesSharedLocalityChecks(name, symbol); 4623 } 4624 4625 Symbol &DeclarationVisitor::FindOrDeclareEnclosingEntity( 4626 const parser::Name &name) { 4627 Symbol *prev{FindSymbol(name)}; 4628 if (!prev) { 4629 // Declare the name as an object in the enclosing scope so that 4630 // the name can't be repurposed there later as something else. 4631 prev = &MakeSymbol(InclusiveScope(), name.source, Attrs{}); 4632 ConvertToObjectEntity(*prev); 4633 ApplyImplicitRules(*prev); 4634 } 4635 return *prev; 4636 } 4637 4638 Symbol *DeclarationVisitor::DeclareLocalEntity(const parser::Name &name) { 4639 Symbol &prev{FindOrDeclareEnclosingEntity(name)}; 4640 if (!PassesLocalityChecks(name, prev)) { 4641 return nullptr; 4642 } 4643 Symbol &symbol{MakeSymbol(name, HostAssocDetails{prev})}; 4644 name.symbol = &symbol; 4645 return &symbol; 4646 } 4647 4648 Symbol *DeclarationVisitor::DeclareStatementEntity(const parser::Name &name, 4649 const std::optional<parser::IntegerTypeSpec> &type) { 4650 const DeclTypeSpec *declTypeSpec{nullptr}; 4651 if (auto *prev{FindSymbol(name)}) { 4652 if (prev->owner() == currScope()) { 4653 SayAlreadyDeclared(name, *prev); 4654 return nullptr; 4655 } 4656 name.symbol = nullptr; 4657 declTypeSpec = prev->GetType(); 4658 } 4659 Symbol &symbol{DeclareEntity<ObjectEntityDetails>(name, {})}; 4660 if (!symbol.has<ObjectEntityDetails>()) { 4661 return nullptr; // error was reported in DeclareEntity 4662 } 4663 if (type) { 4664 declTypeSpec = ProcessTypeSpec(*type); 4665 } 4666 if (declTypeSpec) { 4667 // Subtlety: Don't let a "*length" specifier (if any is pending) affect the 4668 // declaration of this implied DO loop control variable. 4669 auto restorer{ 4670 common::ScopedSet(charInfo_.length, std::optional<ParamValue>{})}; 4671 SetType(name, *declTypeSpec); 4672 } else { 4673 ApplyImplicitRules(symbol); 4674 } 4675 return Resolve(name, &symbol); 4676 } 4677 4678 // Set the type of an entity or report an error. 4679 void DeclarationVisitor::SetType( 4680 const parser::Name &name, const DeclTypeSpec &type) { 4681 CHECK(name.symbol); 4682 auto &symbol{*name.symbol}; 4683 if (charInfo_.length) { // Declaration has "*length" (R723) 4684 auto length{std::move(*charInfo_.length)}; 4685 charInfo_.length.reset(); 4686 if (type.category() == DeclTypeSpec::Character) { 4687 auto kind{type.characterTypeSpec().kind()}; 4688 // Recurse with correct type. 4689 SetType(name, 4690 currScope().MakeCharacterType(std::move(length), std::move(kind))); 4691 return; 4692 } else { // C753 4693 Say(name, 4694 "A length specifier cannot be used to declare the non-character entity '%s'"_err_en_US); 4695 } 4696 } 4697 auto *prevType{symbol.GetType()}; 4698 if (!prevType) { 4699 symbol.SetType(type); 4700 } else if (symbol.has<UseDetails>()) { 4701 // error recovery case, redeclaration of use-associated name 4702 } else if (!symbol.test(Symbol::Flag::Implicit)) { 4703 SayWithDecl( 4704 name, symbol, "The type of '%s' has already been declared"_err_en_US); 4705 } else if (type != *prevType) { 4706 SayWithDecl(name, symbol, 4707 "The type of '%s' has already been implicitly declared"_err_en_US); 4708 } else { 4709 symbol.set(Symbol::Flag::Implicit, false); 4710 } 4711 } 4712 4713 std::optional<DerivedTypeSpec> DeclarationVisitor::ResolveDerivedType( 4714 const parser::Name &name) { 4715 Symbol *symbol{FindSymbol(name)}; 4716 if (!symbol || symbol->has<UnknownDetails>()) { 4717 if (allowForwardReferenceToDerivedType()) { 4718 if (!symbol) { 4719 symbol = &MakeSymbol(InclusiveScope(), name.source, Attrs{}); 4720 Resolve(name, *symbol); 4721 }; 4722 DerivedTypeDetails details; 4723 details.set_isForwardReferenced(); 4724 symbol->set_details(std::move(details)); 4725 } else { // C732 4726 Say(name, "Derived type '%s' not found"_err_en_US); 4727 return std::nullopt; 4728 } 4729 } 4730 if (CheckUseError(name)) { 4731 return std::nullopt; 4732 } 4733 symbol = &symbol->GetUltimate(); 4734 if (auto *details{symbol->detailsIf<GenericDetails>()}) { 4735 if (details->derivedType()) { 4736 symbol = details->derivedType(); 4737 } 4738 } 4739 if (symbol->has<DerivedTypeDetails>()) { 4740 return DerivedTypeSpec{name.source, *symbol}; 4741 } else { 4742 Say(name, "'%s' is not a derived type"_err_en_US); 4743 return std::nullopt; 4744 } 4745 } 4746 4747 std::optional<DerivedTypeSpec> DeclarationVisitor::ResolveExtendsType( 4748 const parser::Name &typeName, const parser::Name *extendsName) { 4749 if (!extendsName) { 4750 return std::nullopt; 4751 } else if (typeName.source == extendsName->source) { 4752 Say(extendsName->source, 4753 "Derived type '%s' cannot extend itself"_err_en_US); 4754 return std::nullopt; 4755 } else { 4756 return ResolveDerivedType(*extendsName); 4757 } 4758 } 4759 4760 Symbol *DeclarationVisitor::NoteInterfaceName(const parser::Name &name) { 4761 // The symbol is checked later by CheckExplicitInterface() and 4762 // CheckBindings(). It can be a forward reference. 4763 if (!NameIsKnownOrIntrinsic(name)) { 4764 Symbol &symbol{MakeSymbol(InclusiveScope(), name.source, Attrs{})}; 4765 Resolve(name, symbol); 4766 } 4767 return name.symbol; 4768 } 4769 4770 void DeclarationVisitor::CheckExplicitInterface(const parser::Name &name) { 4771 if (const Symbol * symbol{name.symbol}) { 4772 if (!symbol->HasExplicitInterface()) { 4773 Say(name, 4774 "'%s' must be an abstract interface or a procedure with " 4775 "an explicit interface"_err_en_US, 4776 symbol->name()); 4777 } 4778 } 4779 } 4780 4781 // Create a symbol for a type parameter, component, or procedure binding in 4782 // the current derived type scope. Return false on error. 4783 Symbol *DeclarationVisitor::MakeTypeSymbol( 4784 const parser::Name &name, Details &&details) { 4785 return Resolve(name, MakeTypeSymbol(name.source, std::move(details))); 4786 } 4787 Symbol *DeclarationVisitor::MakeTypeSymbol( 4788 const SourceName &name, Details &&details) { 4789 Scope &derivedType{currScope()}; 4790 CHECK(derivedType.IsDerivedType()); 4791 if (auto *symbol{FindInScope(derivedType, name)}) { // C742 4792 Say2(name, 4793 "Type parameter, component, or procedure binding '%s'" 4794 " already defined in this type"_err_en_US, 4795 *symbol, "Previous definition of '%s'"_en_US); 4796 return nullptr; 4797 } else { 4798 auto attrs{GetAttrs()}; 4799 // Apply binding-private-stmt if present and this is a procedure binding 4800 if (derivedTypeInfo_.privateBindings && 4801 !attrs.HasAny({Attr::PUBLIC, Attr::PRIVATE}) && 4802 std::holds_alternative<ProcBindingDetails>(details)) { 4803 attrs.set(Attr::PRIVATE); 4804 } 4805 Symbol &result{MakeSymbol(name, attrs, std::move(details))}; 4806 if (result.has<TypeParamDetails>()) { 4807 derivedType.symbol()->get<DerivedTypeDetails>().add_paramDecl(result); 4808 } 4809 return &result; 4810 } 4811 } 4812 4813 // Return true if it is ok to declare this component in the current scope. 4814 // Otherwise, emit an error and return false. 4815 bool DeclarationVisitor::OkToAddComponent( 4816 const parser::Name &name, const Symbol *extends) { 4817 for (const Scope *scope{&currScope()}; scope;) { 4818 CHECK(scope->IsDerivedType()); 4819 if (auto *prev{FindInScope(*scope, name)}) { 4820 if (!prev->test(Symbol::Flag::Error)) { 4821 auto msg{""_en_US}; 4822 if (extends) { 4823 msg = "Type cannot be extended as it has a component named" 4824 " '%s'"_err_en_US; 4825 } else if (prev->test(Symbol::Flag::ParentComp)) { 4826 msg = "'%s' is a parent type of this type and so cannot be" 4827 " a component"_err_en_US; 4828 } else if (scope != &currScope()) { 4829 msg = "Component '%s' is already declared in a parent of this" 4830 " derived type"_err_en_US; 4831 } else { 4832 msg = "Component '%s' is already declared in this" 4833 " derived type"_err_en_US; 4834 } 4835 Say2(name, std::move(msg), *prev, "Previous declaration of '%s'"_en_US); 4836 } 4837 return false; 4838 } 4839 if (scope == &currScope() && extends) { 4840 // The parent component has not yet been added to the scope. 4841 scope = extends->scope(); 4842 } else { 4843 scope = scope->GetDerivedTypeParent(); 4844 } 4845 } 4846 return true; 4847 } 4848 4849 ParamValue DeclarationVisitor::GetParamValue( 4850 const parser::TypeParamValue &x, common::TypeParamAttr attr) { 4851 return std::visit( 4852 common::visitors{ 4853 [=](const parser::ScalarIntExpr &x) { // C704 4854 return ParamValue{EvaluateIntExpr(x), attr}; 4855 }, 4856 [=](const parser::Star &) { return ParamValue::Assumed(attr); }, 4857 [=](const parser::TypeParamValue::Deferred &) { 4858 return ParamValue::Deferred(attr); 4859 }, 4860 }, 4861 x.u); 4862 } 4863 4864 // ConstructVisitor implementation 4865 4866 void ConstructVisitor::ResolveIndexName( 4867 const parser::ConcurrentControl &control) { 4868 const parser::Name &name{std::get<parser::Name>(control.t)}; 4869 auto *prev{FindSymbol(name)}; 4870 if (prev) { 4871 if (prev->owner().kind() == Scope::Kind::Forall || 4872 prev->owner() == currScope()) { 4873 SayAlreadyDeclared(name, *prev); 4874 return; 4875 } 4876 name.symbol = nullptr; 4877 } 4878 auto &symbol{DeclareObjectEntity(name, {})}; 4879 4880 if (symbol.GetType()) { 4881 // type came from explicit type-spec 4882 } else if (!prev) { 4883 ApplyImplicitRules(symbol); 4884 } else if (!prev->has<ObjectEntityDetails>() && !prev->has<EntityDetails>()) { 4885 Say2(name, "Index name '%s' conflicts with existing identifier"_err_en_US, 4886 *prev, "Previous declaration of '%s'"_en_US); 4887 return; 4888 } else { 4889 if (const auto *type{prev->GetType()}) { 4890 symbol.SetType(*type); 4891 } 4892 if (prev->IsObjectArray()) { 4893 SayWithDecl(name, *prev, "Index variable '%s' is not scalar"_err_en_US); 4894 return; 4895 } 4896 } 4897 EvaluateExpr(parser::Scalar{parser::Integer{common::Clone(name)}}); 4898 } 4899 4900 // We need to make sure that all of the index-names get declared before the 4901 // expressions in the loop control are evaluated so that references to the 4902 // index-names in the expressions are correctly detected. 4903 bool ConstructVisitor::Pre(const parser::ConcurrentHeader &header) { 4904 BeginDeclTypeSpec(); 4905 Walk(std::get<std::optional<parser::IntegerTypeSpec>>(header.t)); 4906 const auto &controls{ 4907 std::get<std::list<parser::ConcurrentControl>>(header.t)}; 4908 for (const auto &control : controls) { 4909 ResolveIndexName(control); 4910 } 4911 Walk(controls); 4912 Walk(std::get<std::optional<parser::ScalarLogicalExpr>>(header.t)); 4913 EndDeclTypeSpec(); 4914 return false; 4915 } 4916 4917 bool ConstructVisitor::Pre(const parser::LocalitySpec::Local &x) { 4918 for (auto &name : x.v) { 4919 if (auto *symbol{DeclareLocalEntity(name)}) { 4920 symbol->set(Symbol::Flag::LocalityLocal); 4921 } 4922 } 4923 return false; 4924 } 4925 4926 bool ConstructVisitor::Pre(const parser::LocalitySpec::LocalInit &x) { 4927 for (auto &name : x.v) { 4928 if (auto *symbol{DeclareLocalEntity(name)}) { 4929 symbol->set(Symbol::Flag::LocalityLocalInit); 4930 } 4931 } 4932 return false; 4933 } 4934 4935 bool ConstructVisitor::Pre(const parser::LocalitySpec::Shared &x) { 4936 for (const auto &name : x.v) { 4937 if (!FindSymbol(name)) { 4938 Say(name, "Variable '%s' with SHARED locality implicitly declared"_en_US); 4939 } 4940 Symbol &prev{FindOrDeclareEnclosingEntity(name)}; 4941 if (PassesSharedLocalityChecks(name, prev)) { 4942 auto &symbol{MakeSymbol(name, HostAssocDetails{prev})}; 4943 symbol.set(Symbol::Flag::LocalityShared); 4944 name.symbol = &symbol; // override resolution to parent 4945 } 4946 } 4947 return false; 4948 } 4949 4950 bool ConstructVisitor::Pre(const parser::AcSpec &x) { 4951 ProcessTypeSpec(x.type); 4952 PushScope(Scope::Kind::ImpliedDos, nullptr); 4953 Walk(x.values); 4954 PopScope(); 4955 return false; 4956 } 4957 4958 bool ConstructVisitor::Pre(const parser::AcImpliedDo &x) { 4959 auto &values{std::get<std::list<parser::AcValue>>(x.t)}; 4960 auto &control{std::get<parser::AcImpliedDoControl>(x.t)}; 4961 auto &type{std::get<std::optional<parser::IntegerTypeSpec>>(control.t)}; 4962 auto &bounds{std::get<parser::AcImpliedDoControl::Bounds>(control.t)}; 4963 DeclareStatementEntity(bounds.name.thing.thing, type); 4964 Walk(bounds); 4965 Walk(values); 4966 return false; 4967 } 4968 4969 bool ConstructVisitor::Pre(const parser::DataImpliedDo &x) { 4970 auto &objects{std::get<std::list<parser::DataIDoObject>>(x.t)}; 4971 auto &type{std::get<std::optional<parser::IntegerTypeSpec>>(x.t)}; 4972 auto &bounds{std::get<parser::DataImpliedDo::Bounds>(x.t)}; 4973 DeclareStatementEntity(bounds.name.thing.thing, type); 4974 Walk(bounds); 4975 Walk(objects); 4976 return false; 4977 } 4978 4979 bool ConstructVisitor::Pre(const parser::DataStmtObject &x) { 4980 std::visit(common::visitors{ 4981 [&](const Indirection<parser::Variable> &y) { 4982 Walk(y.value()); 4983 if (const auto *designator{ 4984 std::get_if<Indirection<parser::Designator>>( 4985 &y.value().u)}) { 4986 if (const parser::Name * 4987 name{ResolveDesignator(designator->value())}) { 4988 if (name->symbol) { 4989 name->symbol->set(Symbol::Flag::InDataStmt); 4990 } 4991 } 4992 // TODO check C874 - C881 4993 } else { 4994 // TODO report C875 error: variable is not a designator 4995 // here? 4996 } 4997 }, 4998 [&](const parser::DataImpliedDo &y) { 4999 PushScope(Scope::Kind::ImpliedDos, nullptr); 5000 Walk(y); 5001 PopScope(); 5002 }, 5003 }, 5004 x.u); 5005 return false; 5006 } 5007 5008 bool ConstructVisitor::Pre(const parser::DataStmtValue &x) { 5009 const auto &data{std::get<parser::DataStmtConstant>(x.t)}; 5010 auto &mutableData{const_cast<parser::DataStmtConstant &>(data)}; 5011 if (auto *elem{parser::Unwrap<parser::ArrayElement>(mutableData)}) { 5012 if (const auto *name{std::get_if<parser::Name>(&elem->base.u)}) { 5013 if (const Symbol * symbol{FindSymbol(*name)}) { 5014 if (const Symbol * ultimate{GetAssociationRoot(*symbol)}) { 5015 if (ultimate->has<DerivedTypeDetails>()) { 5016 mutableData.u = elem->ConvertToStructureConstructor( 5017 DerivedTypeSpec{name->source, *ultimate}); 5018 } 5019 } 5020 } 5021 } 5022 } 5023 return true; 5024 } 5025 5026 bool ConstructVisitor::Pre(const parser::DoConstruct &x) { 5027 if (x.IsDoConcurrent()) { 5028 PushScope(Scope::Kind::Block, nullptr); 5029 } 5030 return true; 5031 } 5032 void ConstructVisitor::Post(const parser::DoConstruct &x) { 5033 if (x.IsDoConcurrent()) { 5034 PopScope(); 5035 } 5036 } 5037 5038 bool ConstructVisitor::Pre(const parser::ForallConstruct &) { 5039 PushScope(Scope::Kind::Forall, nullptr); 5040 return true; 5041 } 5042 void ConstructVisitor::Post(const parser::ForallConstruct &) { PopScope(); } 5043 bool ConstructVisitor::Pre(const parser::ForallStmt &) { 5044 PushScope(Scope::Kind::Forall, nullptr); 5045 return true; 5046 } 5047 void ConstructVisitor::Post(const parser::ForallStmt &) { PopScope(); } 5048 5049 bool ConstructVisitor::Pre(const parser::BlockStmt &x) { 5050 CheckDef(x.v); 5051 PushScope(Scope::Kind::Block, nullptr); 5052 return false; 5053 } 5054 bool ConstructVisitor::Pre(const parser::EndBlockStmt &x) { 5055 PopScope(); 5056 CheckRef(x.v); 5057 return false; 5058 } 5059 5060 void ConstructVisitor::Post(const parser::Selector &x) { 5061 GetCurrentAssociation().selector = ResolveSelector(x); 5062 } 5063 5064 bool ConstructVisitor::Pre(const parser::AssociateStmt &x) { 5065 CheckDef(x.t); 5066 PushScope(Scope::Kind::Block, nullptr); 5067 PushAssociation(); 5068 return true; 5069 } 5070 void ConstructVisitor::Post(const parser::EndAssociateStmt &x) { 5071 PopAssociation(); 5072 PopScope(); 5073 CheckRef(x.v); 5074 } 5075 5076 void ConstructVisitor::Post(const parser::Association &x) { 5077 const auto &name{std::get<parser::Name>(x.t)}; 5078 GetCurrentAssociation().name = &name; 5079 if (auto *symbol{MakeAssocEntity()}) { 5080 SetTypeFromAssociation(*symbol); 5081 SetAttrsFromAssociation(*symbol); 5082 } 5083 GetCurrentAssociation() = {}; // clean for further parser::Association. 5084 } 5085 5086 bool ConstructVisitor::Pre(const parser::ChangeTeamStmt &x) { 5087 CheckDef(x.t); 5088 PushScope(Scope::Kind::Block, nullptr); 5089 PushAssociation(); 5090 return true; 5091 } 5092 5093 void ConstructVisitor::Post(const parser::CoarrayAssociation &x) { 5094 const auto &decl{std::get<parser::CodimensionDecl>(x.t)}; 5095 const auto &name{std::get<parser::Name>(decl.t)}; 5096 if (auto *symbol{FindInScope(currScope(), name)}) { 5097 const auto &selector{std::get<parser::Selector>(x.t)}; 5098 if (auto sel{ResolveSelector(selector)}) { 5099 const Symbol *whole{UnwrapWholeSymbolDataRef(sel.expr)}; 5100 if (!whole || whole->Corank() == 0) { 5101 Say(sel.source, // C1116 5102 "Selector in coarray association must name a coarray"_err_en_US); 5103 } else if (auto dynType{sel.expr->GetType()}) { 5104 if (!symbol->GetType()) { 5105 symbol->SetType(ToDeclTypeSpec(std::move(*dynType))); 5106 } 5107 } 5108 } 5109 } 5110 } 5111 5112 void ConstructVisitor::Post(const parser::EndChangeTeamStmt &x) { 5113 PopAssociation(); 5114 PopScope(); 5115 CheckRef(x.t); 5116 } 5117 5118 bool ConstructVisitor::Pre(const parser::SelectTypeConstruct &) { 5119 PushAssociation(); 5120 return true; 5121 } 5122 5123 void ConstructVisitor::Post(const parser::SelectTypeConstruct &) { 5124 PopAssociation(); 5125 } 5126 5127 void ConstructVisitor::Post(const parser::SelectTypeStmt &x) { 5128 auto &association{GetCurrentAssociation()}; 5129 if (const std::optional<parser::Name> &name{std::get<1>(x.t)}) { 5130 // This isn't a name in the current scope, it is in each TypeGuardStmt 5131 MakePlaceholder(*name, MiscDetails::Kind::SelectTypeAssociateName); 5132 association.name = &*name; 5133 } else { 5134 if (const Symbol * 5135 whole{UnwrapWholeSymbolDataRef(association.selector.expr)}) { 5136 ConvertToObjectEntity(const_cast<Symbol &>(*whole)); 5137 if (!IsVariableName(*whole)) { 5138 Say(association.selector.source, // C901 5139 "Selector is not a variable"_err_en_US); 5140 association = {}; 5141 } 5142 } else { 5143 Say(association.selector.source, // C1157 5144 "Selector is not a named variable: 'associate-name =>' is required"_err_en_US); 5145 association = {}; 5146 } 5147 } 5148 } 5149 5150 void ConstructVisitor::Post(const parser::SelectRankStmt &x) { 5151 auto &association{GetCurrentAssociation()}; 5152 if (const std::optional<parser::Name> &name{std::get<1>(x.t)}) { 5153 // This isn't a name in the current scope, it is in each SelectRankCaseStmt 5154 MakePlaceholder(*name, MiscDetails::Kind::SelectRankAssociateName); 5155 association.name = &*name; 5156 } 5157 } 5158 5159 bool ConstructVisitor::Pre(const parser::SelectTypeConstruct::TypeCase &) { 5160 PushScope(Scope::Kind::Block, nullptr); 5161 return true; 5162 } 5163 void ConstructVisitor::Post(const parser::SelectTypeConstruct::TypeCase &) { 5164 PopScope(); 5165 } 5166 5167 bool ConstructVisitor::Pre(const parser::SelectRankConstruct::RankCase &) { 5168 PushScope(Scope::Kind::Block, nullptr); 5169 return true; 5170 } 5171 void ConstructVisitor::Post(const parser::SelectRankConstruct::RankCase &) { 5172 PopScope(); 5173 } 5174 5175 void ConstructVisitor::Post(const parser::TypeGuardStmt::Guard &x) { 5176 if (auto *symbol{MakeAssocEntity()}) { 5177 if (std::holds_alternative<parser::Default>(x.u)) { 5178 SetTypeFromAssociation(*symbol); 5179 } else if (const auto *type{GetDeclTypeSpec()}) { 5180 symbol->SetType(*type); 5181 } 5182 SetAttrsFromAssociation(*symbol); 5183 } 5184 } 5185 5186 void ConstructVisitor::Post(const parser::SelectRankCaseStmt::Rank &x) { 5187 if (auto *symbol{MakeAssocEntity()}) { 5188 SetTypeFromAssociation(*symbol); 5189 SetAttrsFromAssociation(*symbol); 5190 if (const auto *init{std::get_if<parser::ScalarIntConstantExpr>(&x.u)}) { 5191 MaybeIntExpr expr{EvaluateIntExpr(*init)}; 5192 if (auto val{evaluate::ToInt64(expr)}) { 5193 auto &details{symbol->get<AssocEntityDetails>()}; 5194 details.set_rank(*val); 5195 } 5196 } 5197 } 5198 } 5199 5200 bool ConstructVisitor::Pre(const parser::SelectRankConstruct &) { 5201 PushAssociation(); 5202 return true; 5203 } 5204 5205 void ConstructVisitor::Post(const parser::SelectRankConstruct &) { 5206 PopAssociation(); 5207 } 5208 5209 bool ConstructVisitor::CheckDef(const std::optional<parser::Name> &x) { 5210 if (x) { 5211 MakeSymbol(*x, MiscDetails{MiscDetails::Kind::ConstructName}); 5212 } 5213 return true; 5214 } 5215 5216 void ConstructVisitor::CheckRef(const std::optional<parser::Name> &x) { 5217 if (x) { 5218 // Just add an occurrence of this name; checking is done in ValidateLabels 5219 FindSymbol(*x); 5220 } 5221 } 5222 5223 // Make a symbol representing an associating entity from current association. 5224 Symbol *ConstructVisitor::MakeAssocEntity() { 5225 Symbol *symbol{nullptr}; 5226 auto &association{GetCurrentAssociation()}; 5227 if (association.name) { 5228 symbol = &MakeSymbol(*association.name, UnknownDetails{}); 5229 if (symbol->has<AssocEntityDetails>() && symbol->owner() == currScope()) { 5230 Say(*association.name, // C1104 5231 "The associate name '%s' is already used in this associate statement"_err_en_US); 5232 return nullptr; 5233 } 5234 } else if (const Symbol * 5235 whole{UnwrapWholeSymbolDataRef(association.selector.expr)}) { 5236 symbol = &MakeSymbol(whole->name()); 5237 } else { 5238 return nullptr; 5239 } 5240 if (auto &expr{association.selector.expr}) { 5241 symbol->set_details(AssocEntityDetails{common::Clone(*expr)}); 5242 } else { 5243 symbol->set_details(AssocEntityDetails{}); 5244 } 5245 return symbol; 5246 } 5247 5248 // Set the type of symbol based on the current association selector. 5249 void ConstructVisitor::SetTypeFromAssociation(Symbol &symbol) { 5250 auto &details{symbol.get<AssocEntityDetails>()}; 5251 const MaybeExpr *pexpr{&details.expr()}; 5252 if (!*pexpr) { 5253 pexpr = &GetCurrentAssociation().selector.expr; 5254 } 5255 if (*pexpr) { 5256 const SomeExpr &expr{**pexpr}; 5257 if (std::optional<evaluate::DynamicType> type{expr.GetType()}) { 5258 if (const auto *charExpr{ 5259 evaluate::UnwrapExpr<evaluate::Expr<evaluate::SomeCharacter>>( 5260 expr)}) { 5261 symbol.SetType(ToDeclTypeSpec(std::move(*type), 5262 FoldExpr( 5263 std::visit([](const auto &kindChar) { return kindChar.LEN(); }, 5264 charExpr->u)))); 5265 } else { 5266 symbol.SetType(ToDeclTypeSpec(std::move(*type))); 5267 } 5268 } else { 5269 // BOZ literals, procedure designators, &c. are not acceptable 5270 Say(symbol.name(), "Associate name '%s' must have a type"_err_en_US); 5271 } 5272 } 5273 } 5274 5275 // If current selector is a variable, set some of its attributes on symbol. 5276 void ConstructVisitor::SetAttrsFromAssociation(Symbol &symbol) { 5277 Attrs attrs{evaluate::GetAttrs(GetCurrentAssociation().selector.expr)}; 5278 symbol.attrs() |= attrs & 5279 Attrs{Attr::TARGET, Attr::ASYNCHRONOUS, Attr::VOLATILE, Attr::CONTIGUOUS}; 5280 if (attrs.test(Attr::POINTER)) { 5281 symbol.attrs().set(Attr::TARGET); 5282 } 5283 } 5284 5285 ConstructVisitor::Selector ConstructVisitor::ResolveSelector( 5286 const parser::Selector &x) { 5287 return std::visit(common::visitors{ 5288 [&](const parser::Expr &expr) { 5289 return Selector{expr.source, EvaluateExpr(expr)}; 5290 }, 5291 [&](const parser::Variable &var) { 5292 return Selector{var.GetSource(), EvaluateExpr(var)}; 5293 }, 5294 }, 5295 x.u); 5296 } 5297 5298 ConstructVisitor::Association &ConstructVisitor::GetCurrentAssociation() { 5299 CHECK(!associationStack_.empty()); 5300 return associationStack_.back(); 5301 } 5302 5303 void ConstructVisitor::PushAssociation() { 5304 associationStack_.emplace_back(Association{}); 5305 } 5306 5307 void ConstructVisitor::PopAssociation() { 5308 CHECK(!associationStack_.empty()); 5309 associationStack_.pop_back(); 5310 } 5311 5312 const DeclTypeSpec &ConstructVisitor::ToDeclTypeSpec( 5313 evaluate::DynamicType &&type) { 5314 switch (type.category()) { 5315 SWITCH_COVERS_ALL_CASES 5316 case common::TypeCategory::Integer: 5317 case common::TypeCategory::Real: 5318 case common::TypeCategory::Complex: 5319 return context().MakeNumericType(type.category(), type.kind()); 5320 case common::TypeCategory::Logical: 5321 return context().MakeLogicalType(type.kind()); 5322 case common::TypeCategory::Derived: 5323 if (type.IsAssumedType()) { 5324 return currScope().MakeTypeStarType(); 5325 } else if (type.IsUnlimitedPolymorphic()) { 5326 return currScope().MakeClassStarType(); 5327 } else { 5328 return currScope().MakeDerivedType( 5329 type.IsPolymorphic() ? DeclTypeSpec::ClassDerived 5330 : DeclTypeSpec::TypeDerived, 5331 common::Clone(type.GetDerivedTypeSpec()) 5332 5333 ); 5334 } 5335 case common::TypeCategory::Character: 5336 CRASH_NO_CASE; 5337 } 5338 } 5339 5340 const DeclTypeSpec &ConstructVisitor::ToDeclTypeSpec( 5341 evaluate::DynamicType &&type, MaybeSubscriptIntExpr &&length) { 5342 CHECK(type.category() == common::TypeCategory::Character); 5343 if (length) { 5344 return currScope().MakeCharacterType( 5345 ParamValue{SomeIntExpr{*std::move(length)}, common::TypeParamAttr::Len}, 5346 KindExpr{type.kind()}); 5347 } else { 5348 return currScope().MakeCharacterType( 5349 ParamValue::Deferred(common::TypeParamAttr::Len), 5350 KindExpr{type.kind()}); 5351 } 5352 } 5353 5354 // ResolveNamesVisitor implementation 5355 5356 // Ensures that bare undeclared intrinsic procedure names passed as actual 5357 // arguments get recognized as being intrinsics. 5358 bool ResolveNamesVisitor::Pre(const parser::ActualArg &arg) { 5359 if (const auto *expr{std::get_if<Indirection<parser::Expr>>(&arg.u)}) { 5360 if (const auto *designator{ 5361 std::get_if<Indirection<parser::Designator>>(&expr->value().u)}) { 5362 if (const auto *dataRef{ 5363 std::get_if<parser::DataRef>(&designator->value().u)}) { 5364 if (const auto *name{std::get_if<parser::Name>(&dataRef->u)}) { 5365 NameIsKnownOrIntrinsic(*name); 5366 } 5367 } 5368 } 5369 } 5370 return true; 5371 } 5372 5373 bool ResolveNamesVisitor::Pre(const parser::FunctionReference &x) { 5374 HandleCall(Symbol::Flag::Function, x.v); 5375 return false; 5376 } 5377 bool ResolveNamesVisitor::Pre(const parser::CallStmt &x) { 5378 HandleCall(Symbol::Flag::Subroutine, x.v); 5379 return false; 5380 } 5381 5382 bool ResolveNamesVisitor::Pre(const parser::ImportStmt &x) { 5383 auto &scope{currScope()}; 5384 // Check C896 and C899: where IMPORT statements are allowed 5385 switch (scope.kind()) { 5386 case Scope::Kind::Module: 5387 if (scope.IsModule()) { 5388 Say("IMPORT is not allowed in a module scoping unit"_err_en_US); 5389 return false; 5390 } else if (x.kind == common::ImportKind::None) { 5391 Say("IMPORT,NONE is not allowed in a submodule scoping unit"_err_en_US); 5392 return false; 5393 } 5394 break; 5395 case Scope::Kind::MainProgram: 5396 Say("IMPORT is not allowed in a main program scoping unit"_err_en_US); 5397 return false; 5398 case Scope::Kind::Subprogram: 5399 if (scope.parent().IsGlobal()) { 5400 Say("IMPORT is not allowed in an external subprogram scoping unit"_err_en_US); 5401 return false; 5402 } 5403 break; 5404 case Scope::Kind::BlockData: // C1415 (in part) 5405 Say("IMPORT is not allowed in a BLOCK DATA subprogram"_err_en_US); 5406 return false; 5407 default:; 5408 } 5409 if (auto error{scope.SetImportKind(x.kind)}) { 5410 Say(std::move(*error)); 5411 } 5412 for (auto &name : x.names) { 5413 if (FindSymbol(scope.parent(), name)) { 5414 scope.add_importName(name.source); 5415 } else { 5416 Say(name, "'%s' not found in host scope"_err_en_US); 5417 } 5418 } 5419 prevImportStmt_ = currStmtSource(); 5420 return false; 5421 } 5422 5423 const parser::Name *DeclarationVisitor::ResolveStructureComponent( 5424 const parser::StructureComponent &x) { 5425 return FindComponent(ResolveDataRef(x.base), x.component); 5426 } 5427 5428 const parser::Name *DeclarationVisitor::ResolveDesignator( 5429 const parser::Designator &x) { 5430 return std::visit( 5431 common::visitors{ 5432 [&](const parser::DataRef &x) { return ResolveDataRef(x); }, 5433 [&](const parser::Substring &x) { 5434 return ResolveDataRef(std::get<parser::DataRef>(x.t)); 5435 }, 5436 }, 5437 x.u); 5438 } 5439 5440 const parser::Name *DeclarationVisitor::ResolveDataRef( 5441 const parser::DataRef &x) { 5442 return std::visit( 5443 common::visitors{ 5444 [=](const parser::Name &y) { return ResolveName(y); }, 5445 [=](const Indirection<parser::StructureComponent> &y) { 5446 return ResolveStructureComponent(y.value()); 5447 }, 5448 [&](const Indirection<parser::ArrayElement> &y) { 5449 Walk(y.value().subscripts); 5450 return ResolveDataRef(y.value().base); 5451 }, 5452 [&](const Indirection<parser::CoindexedNamedObject> &y) { 5453 Walk(y.value().imageSelector); 5454 return ResolveDataRef(y.value().base); 5455 }, 5456 }, 5457 x.u); 5458 } 5459 5460 const parser::Name *DeclarationVisitor::ResolveVariable( 5461 const parser::Variable &x) { 5462 return std::visit( 5463 common::visitors{ 5464 [&](const Indirection<parser::Designator> &y) { 5465 return ResolveDesignator(y.value()); 5466 }, 5467 [&](const Indirection<parser::FunctionReference> &y) { 5468 const auto &proc{ 5469 std::get<parser::ProcedureDesignator>(y.value().v.t)}; 5470 return std::visit(common::visitors{ 5471 [&](const parser::Name &z) { return &z; }, 5472 [&](const parser::ProcComponentRef &z) { 5473 return ResolveStructureComponent(z.v.thing); 5474 }, 5475 }, 5476 proc.u); 5477 }, 5478 }, 5479 x.u); 5480 } 5481 5482 // If implicit types are allowed, ensure name is in the symbol table. 5483 // Otherwise, report an error if it hasn't been declared. 5484 const parser::Name *DeclarationVisitor::ResolveName(const parser::Name &name) { 5485 if (Symbol * symbol{FindSymbol(name)}) { 5486 if (CheckUseError(name)) { 5487 return nullptr; // reported an error 5488 } 5489 if (symbol->IsDummy() || 5490 (!symbol->GetType() && FindCommonBlockContaining(*symbol))) { 5491 ConvertToObjectEntity(*symbol); 5492 ApplyImplicitRules(*symbol); 5493 } 5494 return &name; 5495 } 5496 if (isImplicitNoneType()) { 5497 Say(name, "No explicit type declared for '%s'"_err_en_US); 5498 return nullptr; 5499 } 5500 // Create the symbol then ensure it is accessible 5501 MakeSymbol(InclusiveScope(), name.source, Attrs{}); 5502 auto *symbol{FindSymbol(name)}; 5503 if (!symbol) { 5504 Say(name, 5505 "'%s' from host scoping unit is not accessible due to IMPORT"_err_en_US); 5506 return nullptr; 5507 } 5508 ConvertToObjectEntity(*symbol); 5509 ApplyImplicitRules(*symbol); 5510 return &name; 5511 } 5512 5513 // base is a part-ref of a derived type; find the named component in its type. 5514 // Also handles intrinsic type parameter inquiries (%kind, %len) and 5515 // COMPLEX component references (%re, %im). 5516 const parser::Name *DeclarationVisitor::FindComponent( 5517 const parser::Name *base, const parser::Name &component) { 5518 if (!base || !base->symbol) { 5519 return nullptr; 5520 } 5521 auto &symbol{base->symbol->GetUltimate()}; 5522 if (!symbol.has<AssocEntityDetails>() && !ConvertToObjectEntity(symbol)) { 5523 SayWithDecl(*base, symbol, 5524 "'%s' is an invalid base for a component reference"_err_en_US); 5525 return nullptr; 5526 } 5527 auto *type{symbol.GetType()}; 5528 if (!type) { 5529 return nullptr; // should have already reported error 5530 } 5531 if (const IntrinsicTypeSpec * intrinsic{type->AsIntrinsic()}) { 5532 auto name{component.ToString()}; 5533 auto category{intrinsic->category()}; 5534 MiscDetails::Kind miscKind{MiscDetails::Kind::None}; 5535 if (name == "kind") { 5536 miscKind = MiscDetails::Kind::KindParamInquiry; 5537 } else if (category == TypeCategory::Character) { 5538 if (name == "len") { 5539 miscKind = MiscDetails::Kind::LenParamInquiry; 5540 } 5541 } else if (category == TypeCategory::Complex) { 5542 if (name == "re") { 5543 miscKind = MiscDetails::Kind::ComplexPartRe; 5544 } else if (name == "im") { 5545 miscKind = MiscDetails::Kind::ComplexPartIm; 5546 } 5547 } 5548 if (miscKind != MiscDetails::Kind::None) { 5549 MakePlaceholder(component, miscKind); 5550 return nullptr; 5551 } 5552 } else if (const DerivedTypeSpec * derived{type->AsDerived()}) { 5553 if (const Scope * scope{derived->scope()}) { 5554 if (Resolve(component, scope->FindComponent(component.source))) { 5555 if (auto msg{ 5556 CheckAccessibleComponent(currScope(), *component.symbol)}) { 5557 context().Say(component.source, *msg); 5558 } 5559 return &component; 5560 } else { 5561 SayDerivedType(component.source, 5562 "Component '%s' not found in derived type '%s'"_err_en_US, *scope); 5563 } 5564 } 5565 return nullptr; 5566 } 5567 if (symbol.test(Symbol::Flag::Implicit)) { 5568 Say(*base, 5569 "'%s' is not an object of derived type; it is implicitly typed"_err_en_US); 5570 } else { 5571 SayWithDecl( 5572 *base, symbol, "'%s' is not an object of derived type"_err_en_US); 5573 } 5574 return nullptr; 5575 } 5576 5577 // C764, C765 5578 void DeclarationVisitor::CheckInitialDataTarget( 5579 const Symbol &pointer, const SomeExpr &expr, SourceName source) { 5580 auto &messages{GetFoldingContext().messages()}; 5581 auto restorer{messages.SetLocation(source)}; 5582 if (!evaluate::IsInitialDataTarget(expr, &messages)) { 5583 Say(source, 5584 "Pointer '%s' cannot be initialized with a reference to a designator with non-constant subscripts"_err_en_US, 5585 pointer.name()); 5586 return; 5587 } 5588 if (pointer.Rank() != expr.Rank()) { 5589 Say(source, 5590 "Pointer '%s' of rank %d cannot be initialized with a target of different rank (%d)"_err_en_US, 5591 pointer.name(), pointer.Rank(), expr.Rank()); 5592 return; 5593 } 5594 // TODO: check type compatibility 5595 // TODO: check non-deferred type parameter values 5596 // TODO: check contiguity if pointer is CONTIGUOUS 5597 } 5598 5599 void DeclarationVisitor::CheckInitialProcTarget( 5600 const Symbol &pointer, const parser::Name &target, SourceName source) { 5601 // C1519 - must be nonelemental external or module procedure, 5602 // or an unrestricted specific intrinsic function. 5603 if (const Symbol * targetSym{target.symbol}) { 5604 const Symbol &ultimate{targetSym->GetUltimate()}; 5605 if (ultimate.attrs().test(Attr::INTRINSIC)) { 5606 } else if (!ultimate.attrs().test(Attr::EXTERNAL) && 5607 ultimate.owner().kind() != Scope::Kind::Module) { 5608 Say(source, 5609 "Procedure pointer '%s' initializer '%s' is neither " 5610 "an external nor a module procedure"_err_en_US, 5611 pointer.name(), ultimate.name()); 5612 } else if (ultimate.attrs().test(Attr::ELEMENTAL)) { 5613 Say(source, 5614 "Procedure pointer '%s' cannot be initialized with the " 5615 "elemental procedure '%s"_err_en_US, 5616 pointer.name(), ultimate.name()); 5617 } else { 5618 // TODO: Check the "shalls" in the 15.4.3.6 paragraphs 7-10. 5619 } 5620 } 5621 } 5622 5623 void DeclarationVisitor::Initialization(const parser::Name &name, 5624 const parser::Initialization &init, bool inComponentDecl) { 5625 if (!name.symbol) { 5626 return; 5627 } 5628 if (std::holds_alternative<parser::InitialDataTarget>(init.u)) { 5629 // Defer analysis to the end of the specification parts so that forward 5630 // references work better. 5631 return; 5632 } 5633 // Traversal of the initializer was deferred to here so that the 5634 // symbol being declared can be available for use in the expression, e.g.: 5635 // real, parameter :: x = tiny(x) 5636 Walk(init.u); 5637 Symbol &ultimate{name.symbol->GetUltimate()}; 5638 if (auto *details{ultimate.detailsIf<ObjectEntityDetails>()}) { 5639 // TODO: check C762 - all bounds and type parameters of component 5640 // are colons or constant expressions if component is initialized 5641 bool isPointer{false}; 5642 std::visit( 5643 common::visitors{ 5644 [&](const parser::ConstantExpr &expr) { 5645 if (inComponentDecl) { 5646 // Can't convert to type of component, which might not yet 5647 // be known; that's done later during instantiation. 5648 if (MaybeExpr value{EvaluateExpr(expr)}) { 5649 details->set_init(std::move(*value)); 5650 } 5651 } else { 5652 if (MaybeExpr folded{EvaluateConvertedExpr( 5653 ultimate, expr, expr.thing.value().source)}) { 5654 details->set_init(std::move(*folded)); 5655 } 5656 } 5657 }, 5658 [&](const parser::NullInit &) { 5659 isPointer = true; 5660 details->set_init(SomeExpr{evaluate::NullPointer{}}); 5661 }, 5662 [&](const parser::InitialDataTarget &initExpr) { 5663 isPointer = true; 5664 if (MaybeExpr expr{EvaluateExpr(initExpr)}) { 5665 CheckInitialDataTarget( 5666 ultimate, *expr, initExpr.value().source); 5667 details->set_init(std::move(*expr)); 5668 } 5669 }, 5670 [&](const std::list<Indirection<parser::DataStmtValue>> &) { 5671 if (inComponentDecl) { 5672 Say(name, 5673 "Component '%s' initialized with DATA statement values"_err_en_US); 5674 } else { 5675 // TODO - DATA statements and DATA-like initialization extension 5676 } 5677 }, 5678 }, 5679 init.u); 5680 if (isPointer) { 5681 if (!IsPointer(ultimate)) { 5682 Say(name, 5683 "Non-pointer component '%s' initialized with pointer target"_err_en_US); 5684 } 5685 } else { 5686 if (IsPointer(ultimate)) { 5687 Say(name, 5688 "Object pointer component '%s' initialized with non-pointer expression"_err_en_US); 5689 } else if (IsAllocatable(ultimate)) { 5690 Say(name, "Allocatable component '%s' cannot be initialized"_err_en_US); 5691 } 5692 } 5693 } 5694 } 5695 5696 void DeclarationVisitor::PointerInitialization( 5697 const parser::Name &name, const parser::InitialDataTarget &target) { 5698 if (name.symbol) { 5699 Symbol &ultimate{name.symbol->GetUltimate()}; 5700 if (IsPointer(ultimate)) { 5701 if (auto *details{ultimate.detailsIf<ObjectEntityDetails>()}) { 5702 CHECK(!details->init()); 5703 Walk(target); 5704 if (MaybeExpr expr{EvaluateExpr(target)}) { 5705 CheckInitialDataTarget(ultimate, *expr, target.value().source); 5706 details->set_init(std::move(*expr)); 5707 } 5708 } 5709 } else { 5710 Say(name, "'%s' is not a pointer but is initialized like one"_err_en_US); 5711 } 5712 } 5713 } 5714 void DeclarationVisitor::PointerInitialization( 5715 const parser::Name &name, const parser::ProcPointerInit &target) { 5716 if (name.symbol) { 5717 Symbol &ultimate{name.symbol->GetUltimate()}; 5718 if (IsProcedurePointer(ultimate)) { 5719 auto &details{ultimate.get<ProcEntityDetails>()}; 5720 CHECK(!details.init()); 5721 Walk(target); 5722 if (const auto *targetName{std::get_if<parser::Name>(&target.u)}) { 5723 CheckInitialProcTarget(ultimate, *targetName, name.source); 5724 if (targetName->symbol) { 5725 details.set_init(*targetName->symbol); 5726 } 5727 } else { 5728 details.set_init(nullptr); // explicit NULL() 5729 } 5730 } else { 5731 Say(name, 5732 "'%s' is not a procedure pointer but is initialized " 5733 "like one"_err_en_US); 5734 } 5735 } 5736 } 5737 5738 void ResolveNamesVisitor::HandleCall( 5739 Symbol::Flag procFlag, const parser::Call &call) { 5740 std::visit( 5741 common::visitors{ 5742 [&](const parser::Name &x) { HandleProcedureName(procFlag, x); }, 5743 [&](const parser::ProcComponentRef &x) { Walk(x); }, 5744 }, 5745 std::get<parser::ProcedureDesignator>(call.t).u); 5746 Walk(std::get<std::list<parser::ActualArgSpec>>(call.t)); 5747 } 5748 5749 void ResolveNamesVisitor::HandleProcedureName( 5750 Symbol::Flag flag, const parser::Name &name) { 5751 CHECK(flag == Symbol::Flag::Function || flag == Symbol::Flag::Subroutine); 5752 auto *symbol{FindSymbol(name)}; 5753 if (!symbol) { 5754 if (context().intrinsics().IsIntrinsic(name.source.ToString())) { 5755 symbol = 5756 &MakeSymbol(InclusiveScope(), name.source, Attrs{Attr::INTRINSIC}); 5757 } else { 5758 symbol = &MakeSymbol(context().globalScope(), name.source, Attrs{}); 5759 } 5760 Resolve(name, *symbol); 5761 if (symbol->has<ModuleDetails>()) { 5762 SayWithDecl(name, *symbol, 5763 "Use of '%s' as a procedure conflicts with its declaration"_err_en_US); 5764 return; 5765 } 5766 if (!symbol->attrs().test(Attr::INTRINSIC)) { 5767 if (isImplicitNoneExternal() && !symbol->attrs().test(Attr::EXTERNAL)) { 5768 Say(name, 5769 "'%s' is an external procedure without the EXTERNAL" 5770 " attribute in a scope with IMPLICIT NONE(EXTERNAL)"_err_en_US); 5771 return; 5772 } 5773 MakeExternal(*symbol); 5774 } 5775 ConvertToProcEntity(*symbol); 5776 SetProcFlag(name, *symbol, flag); 5777 } else if (symbol->has<UnknownDetails>()) { 5778 DIE("unexpected UnknownDetails"); 5779 } else if (CheckUseError(name)) { 5780 // error was reported 5781 } else { 5782 symbol = &Resolve(name, symbol)->GetUltimate(); 5783 ConvertToProcEntity(*symbol); 5784 if (!SetProcFlag(name, *symbol, flag)) { 5785 return; // reported error 5786 } 5787 if (IsProcedure(*symbol) || symbol->has<DerivedTypeDetails>() || 5788 symbol->has<ObjectEntityDetails>() || 5789 symbol->has<AssocEntityDetails>()) { 5790 // Symbols with DerivedTypeDetails, ObjectEntityDetails and 5791 // AssocEntityDetails are accepted here as procedure-designators because 5792 // this means the related FunctionReference are mis-parsed structure 5793 // constructors or array references that will be fixed later when 5794 // analyzing expressions. 5795 } else if (symbol->test(Symbol::Flag::Implicit)) { 5796 Say(name, 5797 "Use of '%s' as a procedure conflicts with its implicit definition"_err_en_US); 5798 } else { 5799 SayWithDecl(name, *symbol, 5800 "Use of '%s' as a procedure conflicts with its declaration"_err_en_US); 5801 } 5802 } 5803 } 5804 5805 // Variant of HandleProcedureName() for use while skimming the executable 5806 // part of a subprogram to catch calls to dummy procedures that are part 5807 // of the subprogram's interface, and to mark as procedures any symbols 5808 // that might otherwise have been miscategorized as objects. 5809 void ResolveNamesVisitor::NoteExecutablePartCall( 5810 Symbol::Flag flag, const parser::Call &call) { 5811 auto &designator{std::get<parser::ProcedureDesignator>(call.t)}; 5812 if (const auto *name{std::get_if<parser::Name>(&designator.u)}) { 5813 // Subtlety: The symbol pointers in the parse tree are not set, because 5814 // they might end up resolving elsewhere (e.g., construct entities in 5815 // SELECT TYPE). 5816 if (Symbol * symbol{currScope().FindSymbol(name->source)}) { 5817 Symbol::Flag other{flag == Symbol::Flag::Subroutine 5818 ? Symbol::Flag::Function 5819 : Symbol::Flag::Subroutine}; 5820 if (!symbol->test(other)) { 5821 ConvertToProcEntity(*symbol); 5822 if (symbol->has<ProcEntityDetails>()) { 5823 symbol->set(flag); 5824 if (symbol->IsDummy()) { 5825 symbol->attrs().set(Attr::EXTERNAL); 5826 } 5827 ApplyImplicitRules(*symbol); 5828 } 5829 } 5830 } 5831 } 5832 } 5833 5834 // Check and set the Function or Subroutine flag on symbol; false on error. 5835 bool ResolveNamesVisitor::SetProcFlag( 5836 const parser::Name &name, Symbol &symbol, Symbol::Flag flag) { 5837 if (symbol.test(Symbol::Flag::Function) && flag == Symbol::Flag::Subroutine) { 5838 SayWithDecl( 5839 name, symbol, "Cannot call function '%s' like a subroutine"_err_en_US); 5840 return false; 5841 } else if (symbol.test(Symbol::Flag::Subroutine) && 5842 flag == Symbol::Flag::Function) { 5843 SayWithDecl( 5844 name, symbol, "Cannot call subroutine '%s' like a function"_err_en_US); 5845 return false; 5846 } else if (symbol.has<ProcEntityDetails>()) { 5847 symbol.set(flag); // in case it hasn't been set yet 5848 if (flag == Symbol::Flag::Function) { 5849 ApplyImplicitRules(symbol); 5850 } 5851 } else if (symbol.GetType() && flag == Symbol::Flag::Subroutine) { 5852 SayWithDecl( 5853 name, symbol, "Cannot call function '%s' like a subroutine"_err_en_US); 5854 } 5855 return true; 5856 } 5857 5858 bool ModuleVisitor::Pre(const parser::AccessStmt &x) { 5859 Attr accessAttr{AccessSpecToAttr(std::get<parser::AccessSpec>(x.t))}; 5860 if (!currScope().IsModule()) { // C869 5861 Say(currStmtSource().value(), 5862 "%s statement may only appear in the specification part of a module"_err_en_US, 5863 EnumToString(accessAttr)); 5864 return false; 5865 } 5866 const auto &accessIds{std::get<std::list<parser::AccessId>>(x.t)}; 5867 if (accessIds.empty()) { 5868 if (prevAccessStmt_) { // C869 5869 Say("The default accessibility of this module has already been declared"_err_en_US) 5870 .Attach(*prevAccessStmt_, "Previous declaration"_en_US); 5871 } 5872 prevAccessStmt_ = currStmtSource(); 5873 defaultAccess_ = accessAttr; 5874 } else { 5875 for (const auto &accessId : accessIds) { 5876 std::visit( 5877 common::visitors{ 5878 [=](const parser::Name &y) { 5879 Resolve(y, SetAccess(y.source, accessAttr)); 5880 }, 5881 [=](const Indirection<parser::GenericSpec> &y) { 5882 auto info{GenericSpecInfo{y.value()}}; 5883 const auto &symbolName{info.symbolName()}; 5884 if (auto *symbol{info.FindInScope(context(), currScope())}) { 5885 info.Resolve(&SetAccess(symbolName, accessAttr, symbol)); 5886 } else if (info.kind().IsName()) { 5887 info.Resolve(&SetAccess(symbolName, accessAttr)); 5888 } else { 5889 Say(symbolName, "Generic spec '%s' not found"_err_en_US); 5890 } 5891 }, 5892 }, 5893 accessId.u); 5894 } 5895 } 5896 return false; 5897 } 5898 5899 // Set the access specification for this symbol. 5900 Symbol &ModuleVisitor::SetAccess( 5901 const SourceName &name, Attr attr, Symbol *symbol) { 5902 if (!symbol) { 5903 symbol = &MakeSymbol(name); 5904 } 5905 Attrs &attrs{symbol->attrs()}; 5906 if (attrs.HasAny({Attr::PUBLIC, Attr::PRIVATE})) { 5907 // PUBLIC/PRIVATE already set: make it a fatal error if it changed 5908 Attr prev = attrs.test(Attr::PUBLIC) ? Attr::PUBLIC : Attr::PRIVATE; 5909 auto msg{IsDefinedOperator(name) 5910 ? "The accessibility of operator '%s' has already been specified as %s"_en_US 5911 : "The accessibility of '%s' has already been specified as %s"_en_US}; 5912 Say(name, WithIsFatal(msg, attr != prev), name, EnumToString(prev)); 5913 } else { 5914 attrs.set(attr); 5915 } 5916 return *symbol; 5917 } 5918 5919 static bool NeedsExplicitType(const Symbol &symbol) { 5920 if (symbol.has<UnknownDetails>()) { 5921 return true; 5922 } else if (const auto *details{symbol.detailsIf<EntityDetails>()}) { 5923 return !details->type(); 5924 } else if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) { 5925 return !details->type(); 5926 } else if (const auto *details{symbol.detailsIf<ProcEntityDetails>()}) { 5927 return !details->interface().symbol() && !details->interface().type(); 5928 } else { 5929 return false; 5930 } 5931 } 5932 5933 bool ResolveNamesVisitor::Pre(const parser::SpecificationPart &x) { 5934 Walk(std::get<0>(x.t)); 5935 Walk(std::get<1>(x.t)); 5936 Walk(std::get<2>(x.t)); 5937 Walk(std::get<3>(x.t)); 5938 const std::list<parser::DeclarationConstruct> &decls{std::get<4>(x.t)}; 5939 for (const auto &decl : decls) { 5940 if (const auto *spec{ 5941 std::get_if<parser::SpecificationConstruct>(&decl.u)}) { 5942 PreSpecificationConstruct(*spec); 5943 } 5944 } 5945 Walk(decls); 5946 FinishSpecificationPart(); 5947 return false; 5948 } 5949 5950 // Initial processing on specification constructs, before visiting them. 5951 void ResolveNamesVisitor::PreSpecificationConstruct( 5952 const parser::SpecificationConstruct &spec) { 5953 std::visit( 5954 common::visitors{ 5955 [&](const Indirection<parser::DerivedTypeDef> &) {}, 5956 [&](const parser::Statement<Indirection<parser::GenericStmt>> &y) { 5957 CreateGeneric(std::get<parser::GenericSpec>(y.statement.value().t)); 5958 }, 5959 [&](const Indirection<parser::InterfaceBlock> &y) { 5960 const auto &stmt{std::get<parser::Statement<parser::InterfaceStmt>>( 5961 y.value().t)}; 5962 const auto *spec{std::get_if<std::optional<parser::GenericSpec>>( 5963 &stmt.statement.u)}; 5964 if (spec && *spec) { 5965 CreateGeneric(**spec); 5966 } 5967 }, 5968 [&](const auto &) {}, 5969 }, 5970 spec.u); 5971 } 5972 5973 void ResolveNamesVisitor::CreateGeneric(const parser::GenericSpec &x) { 5974 auto info{GenericSpecInfo{x}}; 5975 const SourceName &symbolName{info.symbolName()}; 5976 if (IsLogicalConstant(context(), symbolName)) { 5977 Say(symbolName, 5978 "Logical constant '%s' may not be used as a defined operator"_err_en_US); 5979 return; 5980 } 5981 GenericDetails genericDetails; 5982 if (Symbol * existing{info.FindInScope(context(), currScope())}) { 5983 if (existing->has<GenericDetails>()) { 5984 info.Resolve(existing); 5985 return; // already have generic, add to it 5986 } 5987 Symbol &ultimate{existing->GetUltimate()}; 5988 if (auto *ultimateDetails{ultimate.detailsIf<GenericDetails>()}) { 5989 genericDetails.CopyFrom(*ultimateDetails); 5990 } else if (ultimate.has<SubprogramDetails>() || 5991 ultimate.has<SubprogramNameDetails>()) { 5992 genericDetails.set_specific(ultimate); 5993 } else if (ultimate.has<DerivedTypeDetails>()) { 5994 genericDetails.set_derivedType(ultimate); 5995 } else { 5996 SayAlreadyDeclared(symbolName, *existing); 5997 } 5998 EraseSymbol(*existing); 5999 } 6000 info.Resolve(&MakeSymbol(symbolName, Attrs{}, std::move(genericDetails))); 6001 } 6002 6003 void ResolveNamesVisitor::FinishSpecificationPart() { 6004 badStmtFuncFound_ = false; 6005 CheckImports(); 6006 bool inModule{currScope().kind() == Scope::Kind::Module}; 6007 for (auto &pair : currScope()) { 6008 auto &symbol{*pair.second}; 6009 if (NeedsExplicitType(symbol)) { 6010 ApplyImplicitRules(symbol); 6011 } 6012 if (symbol.has<GenericDetails>()) { 6013 CheckGenericProcedures(symbol); 6014 } 6015 if (inModule && symbol.attrs().test(Attr::EXTERNAL) && 6016 !symbol.test(Symbol::Flag::Function)) { 6017 // in a module, external proc without return type is subroutine 6018 symbol.set(Symbol::Flag::Subroutine); 6019 } 6020 } 6021 currScope().InstantiateDerivedTypes(context()); 6022 // TODO: what about instantiations in BLOCK? 6023 CheckSaveStmts(); 6024 CheckCommonBlocks(); 6025 CheckEquivalenceSets(); 6026 } 6027 6028 void ResolveNamesVisitor::CheckImports() { 6029 auto &scope{currScope()}; 6030 switch (scope.GetImportKind()) { 6031 case common::ImportKind::None: 6032 break; 6033 case common::ImportKind::All: 6034 // C8102: all entities in host must not be hidden 6035 for (const auto &pair : scope.parent()) { 6036 auto &name{pair.first}; 6037 std::optional<SourceName> scopeName{scope.GetName()}; 6038 if (!scopeName || name != *scopeName) { 6039 CheckImport(prevImportStmt_.value(), name); 6040 } 6041 } 6042 break; 6043 case common::ImportKind::Default: 6044 case common::ImportKind::Only: 6045 // C8102: entities named in IMPORT must not be hidden 6046 for (auto &name : scope.importNames()) { 6047 CheckImport(name, name); 6048 } 6049 break; 6050 } 6051 } 6052 6053 void ResolveNamesVisitor::CheckImport( 6054 const SourceName &location, const SourceName &name) { 6055 if (auto *symbol{FindInScope(currScope(), name)}) { 6056 Say(location, "'%s' from host is not accessible"_err_en_US, name) 6057 .Attach(symbol->name(), "'%s' is hidden by this entity"_en_US, 6058 symbol->name()); 6059 } 6060 } 6061 6062 bool ResolveNamesVisitor::Pre(const parser::ImplicitStmt &x) { 6063 return CheckNotInBlock("IMPLICIT") && // C1107 6064 ImplicitRulesVisitor::Pre(x); 6065 } 6066 6067 void ResolveNamesVisitor::Post(const parser::PointerObject &x) { 6068 std::visit(common::visitors{ 6069 [&](const parser::Name &x) { ResolveName(x); }, 6070 [&](const parser::StructureComponent &x) { 6071 ResolveStructureComponent(x); 6072 }, 6073 }, 6074 x.u); 6075 } 6076 void ResolveNamesVisitor::Post(const parser::AllocateObject &x) { 6077 std::visit(common::visitors{ 6078 [&](const parser::Name &x) { ResolveName(x); }, 6079 [&](const parser::StructureComponent &x) { 6080 ResolveStructureComponent(x); 6081 }, 6082 }, 6083 x.u); 6084 } 6085 6086 bool ResolveNamesVisitor::Pre(const parser::PointerAssignmentStmt &x) { 6087 const auto &dataRef{std::get<parser::DataRef>(x.t)}; 6088 const auto &bounds{std::get<parser::PointerAssignmentStmt::Bounds>(x.t)}; 6089 const auto &expr{std::get<parser::Expr>(x.t)}; 6090 ResolveDataRef(dataRef); 6091 Walk(bounds); 6092 // Resolve unrestricted specific intrinsic procedures as in "p => cos". 6093 if (const parser::Name * name{parser::Unwrap<parser::Name>(expr)}) { 6094 if (NameIsKnownOrIntrinsic(*name)) { 6095 return false; 6096 } 6097 } 6098 Walk(expr); 6099 return false; 6100 } 6101 void ResolveNamesVisitor::Post(const parser::Designator &x) { 6102 ResolveDesignator(x); 6103 } 6104 6105 void ResolveNamesVisitor::Post(const parser::ProcComponentRef &x) { 6106 ResolveStructureComponent(x.v.thing); 6107 } 6108 void ResolveNamesVisitor::Post(const parser::TypeGuardStmt &x) { 6109 DeclTypeSpecVisitor::Post(x); 6110 ConstructVisitor::Post(x); 6111 } 6112 bool ResolveNamesVisitor::Pre(const parser::StmtFunctionStmt &x) { 6113 CheckNotInBlock("STATEMENT FUNCTION"); // C1107 6114 if (HandleStmtFunction(x)) { 6115 return false; 6116 } else { 6117 // This is an array element assignment: resolve names of indices 6118 const auto &names{std::get<std::list<parser::Name>>(x.t)}; 6119 for (auto &name : names) { 6120 ResolveName(name); 6121 } 6122 return true; 6123 } 6124 } 6125 6126 bool ResolveNamesVisitor::Pre(const parser::DefinedOpName &x) { 6127 const parser::Name &name{x.v}; 6128 if (FindSymbol(name)) { 6129 // OK 6130 } else if (IsLogicalConstant(context(), name.source)) { 6131 Say(name, 6132 "Logical constant '%s' may not be used as a defined operator"_err_en_US); 6133 } else { 6134 // Resolved later in expression semantics 6135 MakePlaceholder(name, MiscDetails::Kind::TypeBoundDefinedOp); 6136 } 6137 return false; 6138 } 6139 6140 void ResolveNamesVisitor::Post(const parser::AssignStmt &x) { 6141 if (auto *name{ResolveName(std::get<parser::Name>(x.t))}) { 6142 ConvertToObjectEntity(DEREF(name->symbol)); 6143 } 6144 } 6145 void ResolveNamesVisitor::Post(const parser::AssignedGotoStmt &x) { 6146 if (auto *name{ResolveName(std::get<parser::Name>(x.t))}) { 6147 ConvertToObjectEntity(DEREF(name->symbol)); 6148 } 6149 } 6150 6151 bool ResolveNamesVisitor::Pre(const parser::ProgramUnit &x) { 6152 auto root{ProgramTree::Build(x)}; 6153 SetScope(context().globalScope()); 6154 ResolveSpecificationParts(root); 6155 FinishSpecificationParts(root); 6156 inExecutionPart_ = true; 6157 ResolveExecutionParts(root); 6158 inExecutionPart_ = false; 6159 ResolveOmpParts(x); 6160 return false; 6161 } 6162 6163 // References to procedures need to record that their symbols are known 6164 // to be procedures, so that they don't get converted to objects by default. 6165 class ExecutionPartSkimmer { 6166 public: 6167 explicit ExecutionPartSkimmer(ResolveNamesVisitor &resolver) 6168 : resolver_{resolver} {} 6169 6170 void Walk(const parser::ExecutionPart *exec) { 6171 if (exec) { 6172 parser::Walk(*exec, *this); 6173 } 6174 } 6175 6176 template <typename A> bool Pre(const A &) { return true; } 6177 template <typename A> void Post(const A &) {} 6178 void Post(const parser::FunctionReference &fr) { 6179 resolver_.NoteExecutablePartCall(Symbol::Flag::Function, fr.v); 6180 } 6181 void Post(const parser::CallStmt &cs) { 6182 resolver_.NoteExecutablePartCall(Symbol::Flag::Subroutine, cs.v); 6183 } 6184 6185 private: 6186 ResolveNamesVisitor &resolver_; 6187 }; 6188 6189 // Build the scope tree and resolve names in the specification parts of this 6190 // node and its children 6191 void ResolveNamesVisitor::ResolveSpecificationParts(ProgramTree &node) { 6192 if (node.isSpecificationPartResolved()) { 6193 return; // been here already 6194 } 6195 node.set_isSpecificationPartResolved(); 6196 if (!BeginScopeForNode(node)) { 6197 return; // an error prevented scope from being created 6198 } 6199 Scope &scope{currScope()}; 6200 node.set_scope(scope); 6201 AddSubpNames(node); 6202 std::visit( 6203 [&](const auto *x) { 6204 if (x) { 6205 Walk(*x); 6206 } 6207 }, 6208 node.stmt()); 6209 Walk(node.spec()); 6210 // If this is a function, convert result to an object. This is to prevent the 6211 // result to be converted later to a function symbol if it is called inside 6212 // the function. 6213 // If the result is function pointer, then ConvertToObjectEntity will not 6214 // convert the result to an object, and calling the symbol inside the function 6215 // will result in calls to the result pointer. 6216 // A function cannot be called recursively if RESULT was not used to define a 6217 // distinct result name (15.6.2.2 point 4.). 6218 if (Symbol * symbol{scope.symbol()}) { 6219 if (auto *details{symbol->detailsIf<SubprogramDetails>()}) { 6220 if (details->isFunction()) { 6221 ConvertToObjectEntity(const_cast<Symbol &>(details->result())); 6222 } 6223 } 6224 } 6225 if (node.IsModule()) { 6226 ApplyDefaultAccess(); 6227 } 6228 for (auto &child : node.children()) { 6229 ResolveSpecificationParts(child); 6230 } 6231 ExecutionPartSkimmer{*this}.Walk(node.exec()); 6232 PopScope(); 6233 // Ensure that every object entity has a type. 6234 for (auto &pair : *node.scope()) { 6235 ApplyImplicitRules(*pair.second); 6236 } 6237 } 6238 6239 // Add SubprogramNameDetails symbols for module and internal subprograms 6240 void ResolveNamesVisitor::AddSubpNames(ProgramTree &node) { 6241 auto kind{ 6242 node.IsModule() ? SubprogramKind::Module : SubprogramKind::Internal}; 6243 for (auto &child : node.children()) { 6244 auto &symbol{MakeSymbol(child.name(), SubprogramNameDetails{kind, child})}; 6245 symbol.set(child.GetSubpFlag()); 6246 } 6247 } 6248 6249 // Push a new scope for this node or return false on error. 6250 bool ResolveNamesVisitor::BeginScopeForNode(const ProgramTree &node) { 6251 switch (node.GetKind()) { 6252 SWITCH_COVERS_ALL_CASES 6253 case ProgramTree::Kind::Program: 6254 PushScope(Scope::Kind::MainProgram, 6255 &MakeSymbol(node.name(), MainProgramDetails{})); 6256 return true; 6257 case ProgramTree::Kind::Function: 6258 case ProgramTree::Kind::Subroutine: 6259 return BeginSubprogram( 6260 node.name(), node.GetSubpFlag(), node.HasModulePrefix()); 6261 case ProgramTree::Kind::MpSubprogram: 6262 return BeginMpSubprogram(node.name()); 6263 case ProgramTree::Kind::Module: 6264 BeginModule(node.name(), false); 6265 return true; 6266 case ProgramTree::Kind::Submodule: 6267 return BeginSubmodule(node.name(), node.GetParentId()); 6268 case ProgramTree::Kind::BlockData: 6269 PushBlockDataScope(node.name()); 6270 return true; 6271 } 6272 } 6273 6274 // Some analyses and checks, such as the processing of initializers of 6275 // pointers, are deferred until all of the pertinent specification parts 6276 // have been visited. This deferred processing enables the use of forward 6277 // references in these circumstances. 6278 class DeferredCheckVisitor { 6279 public: 6280 explicit DeferredCheckVisitor(ResolveNamesVisitor &resolver) 6281 : resolver_{resolver} {} 6282 6283 template <typename A> void Walk(const A &x) { parser::Walk(x, *this); } 6284 6285 template <typename A> bool Pre(const A &) { return true; } 6286 template <typename A> void Post(const A &) {} 6287 6288 void Post(const parser::DerivedTypeStmt &x) { 6289 const auto &name{std::get<parser::Name>(x.t)}; 6290 if (Symbol * symbol{name.symbol}) { 6291 if (Scope * scope{symbol->scope()}) { 6292 if (scope->IsDerivedType()) { 6293 resolver_.PushScope(*scope); 6294 pushedScope_ = true; 6295 } 6296 } 6297 } 6298 } 6299 void Post(const parser::EndTypeStmt &) { 6300 if (pushedScope_) { 6301 resolver_.PopScope(); 6302 pushedScope_ = false; 6303 } 6304 } 6305 6306 void Post(const parser::ProcInterface &pi) { 6307 if (const auto *name{std::get_if<parser::Name>(&pi.u)}) { 6308 resolver_.CheckExplicitInterface(*name); 6309 } 6310 } 6311 bool Pre(const parser::EntityDecl &decl) { 6312 Init(std::get<parser::Name>(decl.t), 6313 std::get<std::optional<parser::Initialization>>(decl.t)); 6314 return false; 6315 } 6316 bool Pre(const parser::ComponentDecl &decl) { 6317 Init(std::get<parser::Name>(decl.t), 6318 std::get<std::optional<parser::Initialization>>(decl.t)); 6319 return false; 6320 } 6321 bool Pre(const parser::ProcDecl &decl) { 6322 if (const auto &init{ 6323 std::get<std::optional<parser::ProcPointerInit>>(decl.t)}) { 6324 resolver_.PointerInitialization(std::get<parser::Name>(decl.t), *init); 6325 } 6326 return false; 6327 } 6328 void Post(const parser::TypeBoundProcedureStmt::WithInterface &tbps) { 6329 resolver_.CheckExplicitInterface(tbps.interfaceName); 6330 } 6331 void Post(const parser::TypeBoundProcedureStmt::WithoutInterface &tbps) { 6332 if (pushedScope_) { 6333 resolver_.CheckBindings(tbps); 6334 } 6335 } 6336 6337 private: 6338 void Init(const parser::Name &name, 6339 const std::optional<parser::Initialization> &init) { 6340 if (init) { 6341 if (const auto *target{ 6342 std::get_if<parser::InitialDataTarget>(&init->u)}) { 6343 resolver_.PointerInitialization(name, *target); 6344 } 6345 } 6346 } 6347 6348 ResolveNamesVisitor &resolver_; 6349 bool pushedScope_{false}; 6350 }; 6351 6352 bool OmpAttributeVisitor::Pre(const parser::OpenMPBlockConstruct &x) { 6353 const auto &beginBlockDir{std::get<parser::OmpBeginBlockDirective>(x.t)}; 6354 const auto &beginDir{std::get<parser::OmpBlockDirective>(beginBlockDir.t)}; 6355 switch (beginDir.v) { 6356 case parser::OmpBlockDirective::Directive::Master: 6357 PushContext(beginDir.source, OmpDirective::MASTER); 6358 break; 6359 case parser::OmpBlockDirective::Directive::Ordered: 6360 PushContext(beginDir.source, OmpDirective::ORDERED); 6361 break; 6362 case parser::OmpBlockDirective::Directive::Parallel: 6363 PushContext(beginDir.source, OmpDirective::PARALLEL); 6364 break; 6365 case parser::OmpBlockDirective::Directive::Single: 6366 PushContext(beginDir.source, OmpDirective::SINGLE); 6367 break; 6368 case parser::OmpBlockDirective::Directive::Target: 6369 PushContext(beginDir.source, OmpDirective::TARGET); 6370 break; 6371 case parser::OmpBlockDirective::Directive::TargetData: 6372 PushContext(beginDir.source, OmpDirective::TARGET_DATA); 6373 break; 6374 case parser::OmpBlockDirective::Directive::Task: 6375 PushContext(beginDir.source, OmpDirective::TASK); 6376 break; 6377 case parser::OmpBlockDirective::Directive::Teams: 6378 PushContext(beginDir.source, OmpDirective::TEAMS); 6379 break; 6380 case parser::OmpBlockDirective::Directive::Workshare: 6381 PushContext(beginDir.source, OmpDirective::WORKSHARE); 6382 break; 6383 case parser::OmpBlockDirective::Directive::ParallelWorkshare: 6384 PushContext(beginDir.source, OmpDirective::PARALLEL_WORKSHARE); 6385 break; 6386 case parser::OmpBlockDirective::Directive::TargetTeams: 6387 PushContext(beginDir.source, OmpDirective::TARGET_TEAMS); 6388 break; 6389 case parser::OmpBlockDirective::Directive::TargetParallel: 6390 PushContext(beginDir.source, OmpDirective::TARGET_PARALLEL); 6391 break; 6392 default: 6393 // TODO others 6394 break; 6395 } 6396 ClearDataSharingAttributeObjects(); 6397 return true; 6398 } 6399 6400 bool OmpAttributeVisitor::Pre(const parser::OpenMPLoopConstruct &x) { 6401 const auto &beginLoopDir{std::get<parser::OmpBeginLoopDirective>(x.t)}; 6402 const auto &beginDir{std::get<parser::OmpLoopDirective>(beginLoopDir.t)}; 6403 const auto &clauseList{std::get<parser::OmpClauseList>(beginLoopDir.t)}; 6404 switch (beginDir.v) { 6405 case parser::OmpLoopDirective::Directive::Distribute: 6406 PushContext(beginDir.source, OmpDirective::DISTRIBUTE); 6407 break; 6408 case parser::OmpLoopDirective::Directive::DistributeParallelDo: 6409 PushContext(beginDir.source, OmpDirective::DISTRIBUTE_PARALLEL_DO); 6410 break; 6411 case parser::OmpLoopDirective::Directive::DistributeParallelDoSimd: 6412 PushContext(beginDir.source, OmpDirective::DISTRIBUTE_PARALLEL_DO_SIMD); 6413 break; 6414 case parser::OmpLoopDirective::Directive::DistributeSimd: 6415 PushContext(beginDir.source, OmpDirective::DISTRIBUTE_SIMD); 6416 break; 6417 case parser::OmpLoopDirective::Directive::Do: 6418 PushContext(beginDir.source, OmpDirective::DO); 6419 break; 6420 case parser::OmpLoopDirective::Directive::DoSimd: 6421 PushContext(beginDir.source, OmpDirective::DO_SIMD); 6422 break; 6423 case parser::OmpLoopDirective::Directive::ParallelDo: 6424 PushContext(beginDir.source, OmpDirective::PARALLEL_DO); 6425 break; 6426 case parser::OmpLoopDirective::Directive::ParallelDoSimd: 6427 PushContext(beginDir.source, OmpDirective::PARALLEL_DO_SIMD); 6428 break; 6429 case parser::OmpLoopDirective::Directive::Simd: 6430 PushContext(beginDir.source, OmpDirective::SIMD); 6431 break; 6432 case parser::OmpLoopDirective::Directive::TargetParallelDo: 6433 PushContext(beginDir.source, OmpDirective::TARGET_PARALLEL_DO); 6434 break; 6435 case parser::OmpLoopDirective::Directive::TargetParallelDoSimd: 6436 PushContext(beginDir.source, OmpDirective::TARGET_PARALLEL_DO_SIMD); 6437 break; 6438 case parser::OmpLoopDirective::Directive::TargetTeamsDistribute: 6439 PushContext(beginDir.source, OmpDirective::TARGET_TEAMS_DISTRIBUTE); 6440 break; 6441 case parser::OmpLoopDirective::Directive::TargetTeamsDistributeParallelDo: 6442 PushContext( 6443 beginDir.source, OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO); 6444 break; 6445 case parser::OmpLoopDirective::Directive::TargetTeamsDistributeParallelDoSimd: 6446 PushContext(beginDir.source, 6447 OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); 6448 break; 6449 case parser::OmpLoopDirective::Directive::TargetTeamsDistributeSimd: 6450 PushContext(beginDir.source, OmpDirective::TARGET_TEAMS_DISTRIBUTE_SIMD); 6451 break; 6452 case parser::OmpLoopDirective::Directive::TargetSimd: 6453 PushContext(beginDir.source, OmpDirective::TARGET_SIMD); 6454 break; 6455 case parser::OmpLoopDirective::Directive::Taskloop: 6456 PushContext(beginDir.source, OmpDirective::TASKLOOP); 6457 break; 6458 case parser::OmpLoopDirective::Directive::TaskloopSimd: 6459 PushContext(beginDir.source, OmpDirective::TASKLOOP_SIMD); 6460 break; 6461 case parser::OmpLoopDirective::Directive::TeamsDistribute: 6462 PushContext(beginDir.source, OmpDirective::TEAMS_DISTRIBUTE); 6463 break; 6464 case parser::OmpLoopDirective::Directive::TeamsDistributeParallelDo: 6465 PushContext(beginDir.source, OmpDirective::TEAMS_DISTRIBUTE_PARALLEL_DO); 6466 break; 6467 case parser::OmpLoopDirective::Directive::TeamsDistributeParallelDoSimd: 6468 PushContext( 6469 beginDir.source, OmpDirective::TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); 6470 break; 6471 case parser::OmpLoopDirective::Directive::TeamsDistributeSimd: 6472 PushContext(beginDir.source, OmpDirective::TEAMS_DISTRIBUTE_SIMD); 6473 break; 6474 } 6475 ClearDataSharingAttributeObjects(); 6476 SetContextAssociatedLoopLevel(GetAssociatedLoopLevelFromClauses(clauseList)); 6477 PrivatizeAssociatedLoopIndex(x); 6478 return true; 6479 } 6480 6481 const parser::Name &OmpAttributeVisitor::GetLoopIndex( 6482 const parser::DoConstruct &x) { 6483 auto &loopControl{x.GetLoopControl().value()}; 6484 using Bounds = parser::LoopControl::Bounds; 6485 const Bounds &bounds{std::get<Bounds>(loopControl.u)}; 6486 return bounds.name.thing; 6487 } 6488 6489 void OmpAttributeVisitor::ResolveSeqLoopIndexInParallelOrTaskConstruct( 6490 const parser::Name &iv) { 6491 auto targetIt{ompContext_.rbegin()}; 6492 for (;; ++targetIt) { 6493 if (targetIt == ompContext_.rend()) { 6494 return; 6495 } 6496 if (parallelSet.test(targetIt->directive) || 6497 taskGeneratingSet.test(targetIt->directive)) { 6498 break; 6499 } 6500 } 6501 if (auto *symbol{ResolveOmp(iv, Symbol::Flag::OmpPrivate, targetIt->scope)}) { 6502 targetIt++; 6503 symbol->set(Symbol::Flag::OmpPreDetermined); 6504 iv.symbol = symbol; // adjust the symbol within region 6505 for (auto it{ompContext_.rbegin()}; it != targetIt; ++it) { 6506 AddToContextObjectWithDSA(*symbol, Symbol::Flag::OmpPrivate, *it); 6507 } 6508 } 6509 } 6510 6511 // 2.15.1.1 Data-sharing Attribute Rules - Predetermined 6512 // - A loop iteration variable for a sequential loop in a parallel 6513 // or task generating construct is private in the innermost such 6514 // construct that encloses the loop 6515 bool OmpAttributeVisitor::Pre(const parser::DoConstruct &x) { 6516 if (!ompContext_.empty() && GetContext().withinConstruct) { 6517 if (const auto &iv{GetLoopIndex(x)}; iv.symbol) { 6518 if (!iv.symbol->test(Symbol::Flag::OmpPreDetermined)) { 6519 ResolveSeqLoopIndexInParallelOrTaskConstruct(iv); 6520 } else { 6521 // TODO: conflict checks with explicitly determined DSA 6522 } 6523 } 6524 } 6525 return true; 6526 } 6527 6528 const parser::DoConstruct *OmpAttributeVisitor::GetDoConstructIf( 6529 const parser::ExecutionPartConstruct &x) { 6530 if (auto *y{std::get_if<parser::ExecutableConstruct>(&x.u)}) { 6531 if (auto *z{std::get_if<Indirection<parser::DoConstruct>>(&y->u)}) { 6532 return &z->value(); 6533 } 6534 } 6535 return nullptr; 6536 } 6537 6538 std::int64_t OmpAttributeVisitor::GetAssociatedLoopLevelFromClauses( 6539 const parser::OmpClauseList &x) { 6540 std::int64_t orderedLevel{0}; 6541 std::int64_t collapseLevel{0}; 6542 for (const auto &clause : x.v) { 6543 if (const auto *orderedClause{ 6544 std::get_if<parser::OmpClause::Ordered>(&clause.u)}) { 6545 if (const auto v{ 6546 evaluate::ToInt64(resolver_.EvaluateIntExpr(orderedClause->v))}) { 6547 orderedLevel = *v; 6548 } 6549 } 6550 if (const auto *collapseClause{ 6551 std::get_if<parser::OmpClause::Collapse>(&clause.u)}) { 6552 if (const auto v{evaluate::ToInt64( 6553 resolver_.EvaluateIntExpr(collapseClause->v))}) { 6554 collapseLevel = *v; 6555 } 6556 } 6557 } 6558 6559 if (orderedLevel && (!collapseLevel || orderedLevel >= collapseLevel)) { 6560 return orderedLevel; 6561 } else if (!orderedLevel && collapseLevel) { 6562 return collapseLevel; 6563 } // orderedLevel < collapseLevel is an error handled in structural checks 6564 return 1; // default is outermost loop 6565 } 6566 6567 // 2.15.1.1 Data-sharing Attribute Rules - Predetermined 6568 // - The loop iteration variable(s) in the associated do-loop(s) of a do, 6569 // parallel do, taskloop, or distribute construct is (are) private. 6570 // - The loop iteration variable in the associated do-loop of a simd construct 6571 // with just one associated do-loop is linear with a linear-step that is the 6572 // increment of the associated do-loop. 6573 // - The loop iteration variables in the associated do-loops of a simd 6574 // construct with multiple associated do-loops are lastprivate. 6575 // 6576 // TODO: revisit after semantics checks are completed for do-loop association of 6577 // collapse and ordered 6578 void OmpAttributeVisitor::PrivatizeAssociatedLoopIndex( 6579 const parser::OpenMPLoopConstruct &x) { 6580 std::int64_t level{GetContext().associatedLoopLevel}; 6581 if (level <= 0) 6582 return; 6583 Symbol::Flag ivDSA{Symbol::Flag::OmpPrivate}; 6584 if (simdSet.test(GetContext().directive)) { 6585 if (level == 1) { 6586 ivDSA = Symbol::Flag::OmpLinear; 6587 } else { 6588 ivDSA = Symbol::Flag::OmpLastPrivate; 6589 } 6590 } 6591 6592 auto &outer{std::get<std::optional<parser::DoConstruct>>(x.t)}; 6593 for (const parser::DoConstruct *loop{&*outer}; loop && level > 0; --level) { 6594 // go through all the nested do-loops and resolve index variables 6595 const parser::Name &iv{GetLoopIndex(*loop)}; 6596 if (auto *symbol{ResolveOmp(iv, ivDSA, currScope())}) { 6597 symbol->set(Symbol::Flag::OmpPreDetermined); 6598 iv.symbol = symbol; // adjust the symbol within region 6599 AddToContextObjectWithDSA(*symbol, ivDSA); 6600 } 6601 6602 const auto &block{std::get<parser::Block>(loop->t)}; 6603 const auto it{block.begin()}; 6604 loop = it != block.end() ? GetDoConstructIf(*it) : nullptr; 6605 } 6606 CHECK(level == 0); 6607 } 6608 6609 bool OmpAttributeVisitor::Pre(const parser::OpenMPSectionsConstruct &x) { 6610 const auto &beginSectionsDir{ 6611 std::get<parser::OmpBeginSectionsDirective>(x.t)}; 6612 const auto &beginDir{ 6613 std::get<parser::OmpSectionsDirective>(beginSectionsDir.t)}; 6614 switch (beginDir.v) { 6615 case parser::OmpSectionsDirective::Directive::ParallelSections: 6616 PushContext(beginDir.source, OmpDirective::PARALLEL_SECTIONS); 6617 break; 6618 case parser::OmpSectionsDirective::Directive::Sections: 6619 PushContext(beginDir.source, OmpDirective::SECTIONS); 6620 break; 6621 } 6622 ClearDataSharingAttributeObjects(); 6623 return true; 6624 } 6625 6626 bool OmpAttributeVisitor::Pre(const parser::OpenMPThreadprivate &x) { 6627 PushContext(x.source, OmpDirective::THREADPRIVATE); 6628 const auto &list{std::get<parser::OmpObjectList>(x.t)}; 6629 ResolveOmpObjectList(list, Symbol::Flag::OmpThreadprivate); 6630 return false; 6631 } 6632 6633 void OmpAttributeVisitor::Post(const parser::OmpDefaultClause &x) { 6634 if (!ompContext_.empty()) { 6635 switch (x.v) { 6636 case parser::OmpDefaultClause::Type::Private: 6637 SetContextDefaultDSA(Symbol::Flag::OmpPrivate); 6638 break; 6639 case parser::OmpDefaultClause::Type::Firstprivate: 6640 SetContextDefaultDSA(Symbol::Flag::OmpFirstPrivate); 6641 break; 6642 case parser::OmpDefaultClause::Type::Shared: 6643 SetContextDefaultDSA(Symbol::Flag::OmpShared); 6644 break; 6645 case parser::OmpDefaultClause::Type::None: 6646 SetContextDefaultDSA(Symbol::Flag::OmpNone); 6647 break; 6648 } 6649 } 6650 } 6651 6652 // For OpenMP constructs, check all the data-refs within the constructs 6653 // and adjust the symbol for each Name if necessary 6654 void OmpAttributeVisitor::Post(const parser::Name &name) { 6655 auto *symbol{name.symbol}; 6656 if (symbol && !ompContext_.empty() && GetContext().withinConstruct) { 6657 if (!symbol->owner().IsDerivedType() && !symbol->has<ProcEntityDetails>() && 6658 !IsObjectWithDSA(*symbol)) { 6659 // TODO: create a separate function to go through the rules for 6660 // predetermined, explicitly determined, and implicitly 6661 // determined data-sharing attributes (2.15.1.1). 6662 if (Symbol * found{currScope().FindSymbol(name.source)}) { 6663 if (symbol != found) { 6664 name.symbol = found; // adjust the symbol within region 6665 } else if (GetContext().defaultDSA == Symbol::Flag::OmpNone) { 6666 context_.Say(name.source, 6667 "The DEFAULT(NONE) clause requires that '%s' must be listed in " 6668 "a data-sharing attribute clause"_err_en_US, 6669 symbol->name()); 6670 } 6671 } 6672 } 6673 } // within OpenMP construct 6674 } 6675 6676 bool OmpAttributeVisitor::HasDataSharingAttributeObject(const Symbol &object) { 6677 auto it{dataSharingAttributeObjects_.find(object)}; 6678 return it != dataSharingAttributeObjects_.end(); 6679 } 6680 6681 Symbol *OmpAttributeVisitor::ResolveOmpCommonBlockName( 6682 const parser::Name *name) { 6683 if (auto *prev{name 6684 ? GetContext().scope.parent().FindCommonBlock(name->source) 6685 : nullptr}) { 6686 name->symbol = prev; 6687 return prev; 6688 } else { 6689 return nullptr; 6690 } 6691 } 6692 6693 void OmpAttributeVisitor::ResolveOmpObjectList( 6694 const parser::OmpObjectList &ompObjectList, Symbol::Flag ompFlag) { 6695 for (const auto &ompObject : ompObjectList.v) { 6696 ResolveOmpObject(ompObject, ompFlag); 6697 } 6698 } 6699 6700 void OmpAttributeVisitor::ResolveOmpObject( 6701 const parser::OmpObject &ompObject, Symbol::Flag ompFlag) { 6702 std::visit( 6703 common::visitors{ 6704 [&](const parser::Designator &designator) { 6705 if (const auto *name{GetDesignatorNameIfDataRef(designator)}) { 6706 if (auto *symbol{ResolveOmp(*name, ompFlag, currScope())}) { 6707 AddToContextObjectWithDSA(*symbol, ompFlag); 6708 if (dataSharingAttributeFlags.test(ompFlag)) { 6709 CheckMultipleAppearances(*name, *symbol, ompFlag); 6710 } 6711 } 6712 } else if (const auto *designatorName{ 6713 resolver_.ResolveDesignator(designator)}; 6714 designatorName->symbol) { 6715 // Array sections to be changed to substrings as needed 6716 if (AnalyzeExpr(context_, designator)) { 6717 if (std::holds_alternative<parser::Substring>(designator.u)) { 6718 context_.Say(designator.source, 6719 "Substrings are not allowed on OpenMP " 6720 "directives or clauses"_err_en_US); 6721 } 6722 } 6723 // other checks, more TBD 6724 if (const auto *details{designatorName->symbol 6725 ->detailsIf<ObjectEntityDetails>()}) { 6726 if (details->IsArray()) { 6727 // TODO: check Array Sections 6728 } else if (designatorName->symbol->owner().IsDerivedType()) { 6729 // TODO: check Structure Component 6730 } 6731 } 6732 } 6733 }, 6734 [&](const parser::Name &name) { // common block 6735 if (auto *symbol{ResolveOmpCommonBlockName(&name)}) { 6736 CheckMultipleAppearances( 6737 name, *symbol, Symbol::Flag::OmpCommonBlock); 6738 // 2.15.3 When a named common block appears in a list, it has the 6739 // same meaning as if every explicit member of the common block 6740 // appeared in the list 6741 for (auto &object : symbol->get<CommonBlockDetails>().objects()) { 6742 if (auto *resolvedObject{ 6743 ResolveOmp(*object, ompFlag, currScope())}) { 6744 AddToContextObjectWithDSA(*resolvedObject, ompFlag); 6745 } 6746 } 6747 } else { 6748 context_.Say(name.source, // 2.15.3 6749 "COMMON block must be declared in the same scoping unit " 6750 "in which the OpenMP directive or clause appears"_err_en_US); 6751 } 6752 }, 6753 }, 6754 ompObject.u); 6755 } 6756 6757 Symbol *OmpAttributeVisitor::ResolveOmp( 6758 const parser::Name &name, Symbol::Flag ompFlag, Scope &scope) { 6759 if (ompFlagsRequireNewSymbol.test(ompFlag)) { 6760 return DeclarePrivateAccessEntity(name, ompFlag, scope); 6761 } else { 6762 return DeclareOrMarkOtherAccessEntity(name, ompFlag); 6763 } 6764 } 6765 6766 Symbol *OmpAttributeVisitor::ResolveOmp( 6767 Symbol &symbol, Symbol::Flag ompFlag, Scope &scope) { 6768 if (ompFlagsRequireNewSymbol.test(ompFlag)) { 6769 return DeclarePrivateAccessEntity(symbol, ompFlag, scope); 6770 } else { 6771 return DeclareOrMarkOtherAccessEntity(symbol, ompFlag); 6772 } 6773 } 6774 6775 Symbol *OmpAttributeVisitor::DeclarePrivateAccessEntity( 6776 const parser::Name &name, Symbol::Flag ompFlag, Scope &scope) { 6777 if (!name.symbol) { 6778 return nullptr; // not resolved by Name Resolution step, do nothing 6779 } 6780 name.symbol = DeclarePrivateAccessEntity(*name.symbol, ompFlag, scope); 6781 return name.symbol; 6782 } 6783 6784 Symbol *OmpAttributeVisitor::DeclarePrivateAccessEntity( 6785 Symbol &object, Symbol::Flag ompFlag, Scope &scope) { 6786 if (object.owner() != currScope()) { 6787 auto &symbol{MakeAssocSymbol(object.name(), object, scope)}; 6788 symbol.set(ompFlag); 6789 return &symbol; 6790 } else { 6791 object.set(ompFlag); 6792 return &object; 6793 } 6794 } 6795 6796 Symbol *OmpAttributeVisitor::DeclareOrMarkOtherAccessEntity( 6797 const parser::Name &name, Symbol::Flag ompFlag) { 6798 Symbol *prev{currScope().FindSymbol(name.source)}; 6799 if (!name.symbol || !prev) { 6800 return nullptr; 6801 } else if (prev != name.symbol) { 6802 name.symbol = prev; 6803 } 6804 return DeclareOrMarkOtherAccessEntity(*prev, ompFlag); 6805 } 6806 6807 Symbol *OmpAttributeVisitor::DeclareOrMarkOtherAccessEntity( 6808 Symbol &object, Symbol::Flag ompFlag) { 6809 if (ompFlagsRequireMark.test(ompFlag)) { 6810 object.set(ompFlag); 6811 } 6812 return &object; 6813 } 6814 6815 static bool WithMultipleAppearancesException( 6816 const Symbol &symbol, Symbol::Flag ompFlag) { 6817 return (ompFlag == Symbol::Flag::OmpFirstPrivate && 6818 symbol.test(Symbol::Flag::OmpLastPrivate)) || 6819 (ompFlag == Symbol::Flag::OmpLastPrivate && 6820 symbol.test(Symbol::Flag::OmpFirstPrivate)); 6821 } 6822 6823 void OmpAttributeVisitor::CheckMultipleAppearances( 6824 const parser::Name &name, const Symbol &symbol, Symbol::Flag ompFlag) { 6825 const auto *target{&symbol}; 6826 if (ompFlagsRequireNewSymbol.test(ompFlag)) { 6827 if (const auto *details{symbol.detailsIf<HostAssocDetails>()}) { 6828 target = &details->symbol(); 6829 } 6830 } 6831 if (HasDataSharingAttributeObject(*target) && 6832 !WithMultipleAppearancesException(symbol, ompFlag)) { 6833 context_.Say(name.source, 6834 "'%s' appears in more than one data-sharing clause " 6835 "on the same OpenMP directive"_err_en_US, 6836 name.ToString()); 6837 } else { 6838 AddDataSharingAttributeObject(*target); 6839 } 6840 } 6841 6842 // Perform checks and completions that need to happen after all of 6843 // the specification parts but before any of the execution parts. 6844 void ResolveNamesVisitor::FinishSpecificationParts(const ProgramTree &node) { 6845 if (!node.scope()) { 6846 return; // error occurred creating scope 6847 } 6848 SetScope(*node.scope()); 6849 // The initializers of pointers, pointer components, and non-deferred 6850 // type-bound procedure bindings have not yet been traversed. 6851 // We do that now, when any (formerly) forward references that appear 6852 // in those initializers will resolve to the right symbols. 6853 DeferredCheckVisitor{*this}.Walk(node.spec()); 6854 DeferredCheckVisitor{*this}.Walk(node.exec()); // for BLOCK 6855 for (Scope &childScope : currScope().children()) { 6856 if (childScope.IsDerivedType() && !childScope.symbol()) { 6857 FinishDerivedTypeInstantiation(childScope); 6858 } 6859 } 6860 for (const auto &child : node.children()) { 6861 FinishSpecificationParts(child); 6862 } 6863 } 6864 6865 // Fold object pointer initializer designators with the actual 6866 // type parameter values of a particular instantiation. 6867 void ResolveNamesVisitor::FinishDerivedTypeInstantiation(Scope &scope) { 6868 CHECK(scope.IsDerivedType() && !scope.symbol()); 6869 if (DerivedTypeSpec * spec{scope.derivedTypeSpec()}) { 6870 spec->Instantiate(currScope(), context()); 6871 const Symbol &origTypeSymbol{spec->typeSymbol()}; 6872 if (const Scope * origTypeScope{origTypeSymbol.scope()}) { 6873 CHECK(origTypeScope->IsDerivedType() && 6874 origTypeScope->symbol() == &origTypeSymbol); 6875 auto &foldingContext{GetFoldingContext()}; 6876 auto restorer{foldingContext.WithPDTInstance(*spec)}; 6877 for (auto &pair : scope) { 6878 Symbol &comp{*pair.second}; 6879 const Symbol &origComp{DEREF(FindInScope(*origTypeScope, comp.name()))}; 6880 if (IsPointer(comp)) { 6881 if (auto *details{comp.detailsIf<ObjectEntityDetails>()}) { 6882 auto origDetails{origComp.get<ObjectEntityDetails>()}; 6883 if (const MaybeExpr & init{origDetails.init()}) { 6884 SomeExpr newInit{*init}; 6885 MaybeExpr folded{ 6886 evaluate::Fold(foldingContext, std::move(newInit))}; 6887 details->set_init(std::move(folded)); 6888 } 6889 } 6890 } 6891 } 6892 } 6893 } 6894 } 6895 6896 // Resolve names in the execution part of this node and its children 6897 void ResolveNamesVisitor::ResolveExecutionParts(const ProgramTree &node) { 6898 if (!node.scope()) { 6899 return; // error occurred creating scope 6900 } 6901 SetScope(*node.scope()); 6902 if (const auto *exec{node.exec()}) { 6903 Walk(*exec); 6904 } 6905 PopScope(); // converts unclassified entities into objects 6906 for (const auto &child : node.children()) { 6907 ResolveExecutionParts(child); 6908 } 6909 } 6910 6911 void ResolveNamesVisitor::ResolveOmpParts(const parser::ProgramUnit &node) { 6912 OmpAttributeVisitor{context(), *this}.Walk(node); 6913 if (!context().AnyFatalError()) { 6914 // The data-sharing attribute of the loop iteration variable for a 6915 // sequential loop (2.15.1.1) can only be determined when visiting 6916 // the corresponding DoConstruct, a second walk is to adjust the 6917 // symbols for all the data-refs of that loop iteration variable 6918 // prior to the DoConstruct. 6919 OmpAttributeVisitor{context(), *this}.Walk(node); 6920 } 6921 } 6922 6923 void ResolveNamesVisitor::Post(const parser::Program &) { 6924 // ensure that all temps were deallocated 6925 CHECK(!attrs_); 6926 CHECK(!GetDeclTypeSpec()); 6927 } 6928 6929 // A singleton instance of the scope -> IMPLICIT rules mapping is 6930 // shared by all instances of ResolveNamesVisitor and accessed by this 6931 // pointer when the visitors (other than the top-level original) are 6932 // constructed. 6933 static ImplicitRulesMap *sharedImplicitRulesMap{nullptr}; 6934 6935 bool ResolveNames(SemanticsContext &context, const parser::Program &program) { 6936 ImplicitRulesMap implicitRulesMap; 6937 auto restorer{common::ScopedSet(sharedImplicitRulesMap, &implicitRulesMap)}; 6938 ResolveNamesVisitor{context, implicitRulesMap}.Walk(program); 6939 return !context.AnyFatalError(); 6940 } 6941 6942 // Processes a module (but not internal) function when it is referenced 6943 // in a specification expression in a sibling procedure. 6944 void ResolveSpecificationParts( 6945 SemanticsContext &context, const Symbol &subprogram) { 6946 auto originalLocation{context.location()}; 6947 ResolveNamesVisitor visitor{context, DEREF(sharedImplicitRulesMap)}; 6948 ProgramTree &node{subprogram.get<SubprogramNameDetails>().node()}; 6949 const Scope &moduleScope{subprogram.owner()}; 6950 visitor.SetScope(const_cast<Scope &>(moduleScope)); 6951 visitor.ResolveSpecificationParts(node); 6952 context.set_location(std::move(originalLocation)); 6953 } 6954 } // namespace Fortran::semantics 6955