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