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