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