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