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