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