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