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