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