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