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