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