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