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