1 //===-- lib/Semantics/check-declarations.cpp ------------------------------===//
2 //
3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4 // See https://llvm.org/LICENSE.txt for license information.
5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6 //
7 //===----------------------------------------------------------------------===//
8 
9 // Static declaration checking
10 
11 #include "check-declarations.h"
12 #include "pointer-assignment.h"
13 #include "flang/Evaluate/check-expression.h"
14 #include "flang/Evaluate/fold.h"
15 #include "flang/Evaluate/tools.h"
16 #include "flang/Semantics/scope.h"
17 #include "flang/Semantics/semantics.h"
18 #include "flang/Semantics/symbol.h"
19 #include "flang/Semantics/tools.h"
20 #include "flang/Semantics/type.h"
21 #include <algorithm>
22 #include <map>
23 #include <string>
24 
25 namespace Fortran::semantics {
26 
27 namespace characteristics = evaluate::characteristics;
28 using characteristics::DummyArgument;
29 using characteristics::DummyDataObject;
30 using characteristics::DummyProcedure;
31 using characteristics::FunctionResult;
32 using characteristics::Procedure;
33 
34 class CheckHelper {
35 public:
36   explicit CheckHelper(SemanticsContext &c) : context_{c} {}
37   CheckHelper(SemanticsContext &c, const Scope &s) : context_{c}, scope_{&s} {}
38 
39   SemanticsContext &context() { return context_; }
40   void Check() { Check(context_.globalScope()); }
41   void Check(const ParamValue &, bool canBeAssumed);
42   void Check(const Bound &bound) { CheckSpecExpr(bound.GetExplicit()); }
43   void Check(const ShapeSpec &spec) {
44     Check(spec.lbound());
45     Check(spec.ubound());
46   }
47   void Check(const ArraySpec &);
48   void Check(const DeclTypeSpec &, bool canHaveAssumedTypeParameters);
49   void Check(const Symbol &);
50   void Check(const Scope &);
51   const Procedure *Characterize(const Symbol &);
52 
53 private:
54   template <typename A> void CheckSpecExpr(const A &x) {
55     evaluate::CheckSpecificationExpr(x, DEREF(scope_), foldingContext_);
56   }
57   void CheckValue(const Symbol &, const DerivedTypeSpec *);
58   void CheckVolatile(const Symbol &, const DerivedTypeSpec *);
59   void CheckPointer(const Symbol &);
60   void CheckPassArg(
61       const Symbol &proc, const Symbol *interface, const WithPassArg &);
62   void CheckProcBinding(const Symbol &, const ProcBindingDetails &);
63   void CheckObjectEntity(const Symbol &, const ObjectEntityDetails &);
64   void CheckPointerInitialization(const Symbol &);
65   void CheckArraySpec(const Symbol &, const ArraySpec &);
66   void CheckProcEntity(const Symbol &, const ProcEntityDetails &);
67   void CheckSubprogram(const Symbol &, const SubprogramDetails &);
68   void CheckAssumedTypeEntity(const Symbol &, const ObjectEntityDetails &);
69   void CheckDerivedType(const Symbol &, const DerivedTypeDetails &);
70   bool CheckFinal(
71       const Symbol &subroutine, SourceName, const Symbol &derivedType);
72   bool CheckDistinguishableFinals(const Symbol &f1, SourceName f1name,
73       const Symbol &f2, SourceName f2name, const Symbol &derivedType);
74   void CheckGeneric(const Symbol &, const GenericDetails &);
75   void CheckHostAssoc(const Symbol &, const HostAssocDetails &);
76   bool CheckDefinedOperator(
77       SourceName, GenericKind, const Symbol &, const Procedure &);
78   std::optional<parser::MessageFixedText> CheckNumberOfArgs(
79       const GenericKind &, std::size_t);
80   bool CheckDefinedOperatorArg(
81       const SourceName &, const Symbol &, const Procedure &, std::size_t);
82   bool CheckDefinedAssignment(const Symbol &, const Procedure &);
83   bool CheckDefinedAssignmentArg(const Symbol &, const DummyArgument &, int);
84   void CheckSpecificsAreDistinguishable(const Symbol &, const GenericDetails &);
85   void CheckEquivalenceSet(const EquivalenceSet &);
86   void CheckBlockData(const Scope &);
87   void CheckGenericOps(const Scope &);
88   bool CheckConflicting(const Symbol &, Attr, Attr);
89   void WarnMissingFinal(const Symbol &);
90   bool InPure() const {
91     return innermostSymbol_ && IsPureProcedure(*innermostSymbol_);
92   }
93   bool InFunction() const {
94     return innermostSymbol_ && IsFunction(*innermostSymbol_);
95   }
96   template <typename... A>
97   void SayWithDeclaration(const Symbol &symbol, A &&...x) {
98     if (parser::Message * msg{messages_.Say(std::forward<A>(x)...)}) {
99       if (messages_.at().begin() != symbol.name().begin()) {
100         evaluate::AttachDeclaration(*msg, symbol);
101       }
102     }
103   }
104   bool IsResultOkToDiffer(const FunctionResult &);
105   void CheckBindCName(const Symbol &);
106 
107   SemanticsContext &context_;
108   evaluate::FoldingContext &foldingContext_{context_.foldingContext()};
109   parser::ContextualMessages &messages_{foldingContext_.messages()};
110   const Scope *scope_{nullptr};
111   bool scopeIsUninstantiatedPDT_{false};
112   // This symbol is the one attached to the innermost enclosing scope
113   // that has a symbol.
114   const Symbol *innermostSymbol_{nullptr};
115   // Cache of calls to Procedure::Characterize(Symbol)
116   std::map<SymbolRef, std::optional<Procedure>, SymbolAddressCompare>
117       characterizeCache_;
118   // Collection of symbols with BIND(C) names
119   std::map<std::string, SymbolRef> bindC_;
120 };
121 
122 class DistinguishabilityHelper {
123 public:
124   DistinguishabilityHelper(SemanticsContext &context) : context_{context} {}
125   void Add(const Symbol &, GenericKind, const Symbol &, const Procedure &);
126   void Check(const Scope &);
127 
128 private:
129   void SayNotDistinguishable(const Scope &, const SourceName &, GenericKind,
130       const Symbol &, const Symbol &);
131   void AttachDeclaration(parser::Message &, const Scope &, const Symbol &);
132 
133   SemanticsContext &context_;
134   struct ProcedureInfo {
135     GenericKind kind;
136     const Symbol &symbol;
137     const Procedure &procedure;
138   };
139   std::map<SourceName, std::vector<ProcedureInfo>> nameToInfo_;
140 };
141 
142 void CheckHelper::Check(const ParamValue &value, bool canBeAssumed) {
143   if (value.isAssumed()) {
144     if (!canBeAssumed) { // C795, C721, C726
145       messages_.Say(
146           "An assumed (*) type parameter may be used only for a (non-statement"
147           " function) dummy argument, associate name, named constant, or"
148           " external function result"_err_en_US);
149     }
150   } else {
151     CheckSpecExpr(value.GetExplicit());
152   }
153 }
154 
155 void CheckHelper::Check(const ArraySpec &shape) {
156   for (const auto &spec : shape) {
157     Check(spec);
158   }
159 }
160 
161 void CheckHelper::Check(
162     const DeclTypeSpec &type, bool canHaveAssumedTypeParameters) {
163   if (type.category() == DeclTypeSpec::Character) {
164     Check(type.characterTypeSpec().length(), canHaveAssumedTypeParameters);
165   } else if (const DerivedTypeSpec * derived{type.AsDerived()}) {
166     for (auto &parm : derived->parameters()) {
167       Check(parm.second, canHaveAssumedTypeParameters);
168     }
169   }
170 }
171 
172 void CheckHelper::Check(const Symbol &symbol) {
173   if (context_.HasError(symbol)) {
174     return;
175   }
176   auto restorer{messages_.SetLocation(symbol.name())};
177   context_.set_location(symbol.name());
178   const DeclTypeSpec *type{symbol.GetType()};
179   const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
180   bool isDone{false};
181   std::visit(
182       common::visitors{
183           [&](const UseDetails &x) { isDone = true; },
184           [&](const HostAssocDetails &x) {
185             CheckHostAssoc(symbol, x);
186             isDone = true;
187           },
188           [&](const ProcBindingDetails &x) {
189             CheckProcBinding(symbol, x);
190             isDone = true;
191           },
192           [&](const ObjectEntityDetails &x) { CheckObjectEntity(symbol, x); },
193           [&](const ProcEntityDetails &x) { CheckProcEntity(symbol, x); },
194           [&](const SubprogramDetails &x) { CheckSubprogram(symbol, x); },
195           [&](const DerivedTypeDetails &x) { CheckDerivedType(symbol, x); },
196           [&](const GenericDetails &x) { CheckGeneric(symbol, x); },
197           [](const auto &) {},
198       },
199       symbol.details());
200   if (symbol.attrs().test(Attr::VOLATILE)) {
201     CheckVolatile(symbol, derived);
202   }
203   CheckBindCName(symbol);
204   if (isDone) {
205     return; // following checks do not apply
206   }
207   if (IsPointer(symbol)) {
208     CheckPointer(symbol);
209   }
210   if (InPure()) {
211     if (IsSaved(symbol)) {
212       messages_.Say(
213           "A pure subprogram may not have a variable with the SAVE attribute"_err_en_US);
214     }
215     if (symbol.attrs().test(Attr::VOLATILE)) {
216       messages_.Say(
217           "A pure subprogram may not have a variable with the VOLATILE attribute"_err_en_US);
218     }
219     if (IsProcedure(symbol) && !IsPureProcedure(symbol) && IsDummy(symbol)) {
220       messages_.Say(
221           "A dummy procedure of a pure subprogram must be pure"_err_en_US);
222     }
223     if (!IsDummy(symbol) && !IsFunctionResult(symbol)) {
224       if (IsPolymorphicAllocatable(symbol)) {
225         SayWithDeclaration(symbol,
226             "Deallocation of polymorphic object '%s' is not permitted in a pure subprogram"_err_en_US,
227             symbol.name());
228       } else if (derived) {
229         if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) {
230           SayWithDeclaration(*bad,
231               "Deallocation of polymorphic object '%s%s' is not permitted in a pure subprogram"_err_en_US,
232               symbol.name(), bad.BuildResultDesignatorName());
233         }
234       }
235     }
236   }
237   if (type) { // Section 7.2, paragraph 7
238     bool canHaveAssumedParameter{IsNamedConstant(symbol) ||
239         (IsAssumedLengthCharacter(symbol) && // C722
240             IsExternal(symbol)) ||
241         symbol.test(Symbol::Flag::ParentComp)};
242     if (!IsStmtFunctionDummy(symbol)) { // C726
243       if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
244         canHaveAssumedParameter |= object->isDummy() ||
245             (object->isFuncResult() &&
246                 type->category() == DeclTypeSpec::Character) ||
247             IsStmtFunctionResult(symbol); // Avoids multiple messages
248       } else {
249         canHaveAssumedParameter |= symbol.has<AssocEntityDetails>();
250       }
251     }
252     Check(*type, canHaveAssumedParameter);
253     if (InPure() && InFunction() && IsFunctionResult(symbol)) {
254       if (derived && HasImpureFinal(*derived)) { // C1584
255         messages_.Say(
256             "Result of pure function may not have an impure FINAL subroutine"_err_en_US);
257       }
258       if (type->IsPolymorphic() && IsAllocatable(symbol)) { // C1585
259         messages_.Say(
260             "Result of pure function may not be both polymorphic and ALLOCATABLE"_err_en_US);
261       }
262       if (derived) {
263         if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) {
264           SayWithDeclaration(*bad,
265               "Result of pure function may not have polymorphic ALLOCATABLE ultimate component '%s'"_err_en_US,
266               bad.BuildResultDesignatorName());
267         }
268       }
269     }
270   }
271   if (IsAssumedLengthCharacter(symbol) && IsExternal(symbol)) { // C723
272     if (symbol.attrs().test(Attr::RECURSIVE)) {
273       messages_.Say(
274           "An assumed-length CHARACTER(*) function cannot be RECURSIVE"_err_en_US);
275     }
276     if (symbol.Rank() > 0) {
277       messages_.Say(
278           "An assumed-length CHARACTER(*) function cannot return an array"_err_en_US);
279     }
280     if (symbol.attrs().test(Attr::PURE)) {
281       messages_.Say(
282           "An assumed-length CHARACTER(*) function cannot be PURE"_err_en_US);
283     }
284     if (symbol.attrs().test(Attr::ELEMENTAL)) {
285       messages_.Say(
286           "An assumed-length CHARACTER(*) function cannot be ELEMENTAL"_err_en_US);
287     }
288     if (const Symbol * result{FindFunctionResult(symbol)}) {
289       if (IsPointer(*result)) {
290         messages_.Say(
291             "An assumed-length CHARACTER(*) function cannot return a POINTER"_err_en_US);
292       }
293     }
294   }
295   if (symbol.attrs().test(Attr::VALUE)) {
296     CheckValue(symbol, derived);
297   }
298   if (symbol.attrs().test(Attr::CONTIGUOUS) && IsPointer(symbol) &&
299       symbol.Rank() == 0) { // C830
300     messages_.Say("CONTIGUOUS POINTER must be an array"_err_en_US);
301   }
302   if (IsDummy(symbol)) {
303     if (IsNamedConstant(symbol)) {
304       messages_.Say(
305           "A dummy argument may not also be a named constant"_err_en_US);
306     }
307     if (IsSaved(symbol)) {
308       messages_.Say(
309           "A dummy argument may not have the SAVE attribute"_err_en_US);
310     }
311   } else if (IsFunctionResult(symbol)) {
312     if (IsSaved(symbol)) {
313       messages_.Say(
314           "A function result may not have the SAVE attribute"_err_en_US);
315     }
316   }
317   if (symbol.owner().IsDerivedType() &&
318       (symbol.attrs().test(Attr::CONTIGUOUS) &&
319           !(IsPointer(symbol) && symbol.Rank() > 0))) { // C752
320     messages_.Say(
321         "A CONTIGUOUS component must be an array with the POINTER attribute"_err_en_US);
322   }
323   if (symbol.owner().IsModule() && IsAutomatic(symbol)) {
324     messages_.Say(
325         "Automatic data object '%s' may not appear in the specification part"
326         " of a module"_err_en_US,
327         symbol.name());
328   }
329 }
330 
331 void CheckHelper::CheckValue(
332     const Symbol &symbol, const DerivedTypeSpec *derived) { // C863 - C865
333   if (!IsDummy(symbol)) {
334     messages_.Say(
335         "VALUE attribute may apply only to a dummy argument"_err_en_US);
336   }
337   if (IsProcedure(symbol)) {
338     messages_.Say(
339         "VALUE attribute may apply only to a dummy data object"_err_en_US);
340   }
341   if (IsAssumedSizeArray(symbol)) {
342     messages_.Say(
343         "VALUE attribute may not apply to an assumed-size array"_err_en_US);
344   }
345   if (IsCoarray(symbol)) {
346     messages_.Say("VALUE attribute may not apply to a coarray"_err_en_US);
347   }
348   if (IsAllocatable(symbol)) {
349     messages_.Say("VALUE attribute may not apply to an ALLOCATABLE"_err_en_US);
350   } else if (IsPointer(symbol)) {
351     messages_.Say("VALUE attribute may not apply to a POINTER"_err_en_US);
352   }
353   if (IsIntentInOut(symbol)) {
354     messages_.Say(
355         "VALUE attribute may not apply to an INTENT(IN OUT) argument"_err_en_US);
356   } else if (IsIntentOut(symbol)) {
357     messages_.Say(
358         "VALUE attribute may not apply to an INTENT(OUT) argument"_err_en_US);
359   }
360   if (symbol.attrs().test(Attr::VOLATILE)) {
361     messages_.Say("VALUE attribute may not apply to a VOLATILE"_err_en_US);
362   }
363   if (innermostSymbol_ && IsBindCProcedure(*innermostSymbol_) &&
364       IsOptional(symbol)) {
365     messages_.Say(
366         "VALUE attribute may not apply to an OPTIONAL in a BIND(C) procedure"_err_en_US);
367   }
368   if (derived) {
369     if (FindCoarrayUltimateComponent(*derived)) {
370       messages_.Say(
371           "VALUE attribute may not apply to a type with a coarray ultimate component"_err_en_US);
372     }
373   }
374 }
375 
376 void CheckHelper::CheckAssumedTypeEntity( // C709
377     const Symbol &symbol, const ObjectEntityDetails &details) {
378   if (const DeclTypeSpec * type{symbol.GetType()};
379       type && type->category() == DeclTypeSpec::TypeStar) {
380     if (!IsDummy(symbol)) {
381       messages_.Say(
382           "Assumed-type entity '%s' must be a dummy argument"_err_en_US,
383           symbol.name());
384     } else {
385       if (symbol.attrs().test(Attr::ALLOCATABLE)) {
386         messages_.Say("Assumed-type argument '%s' cannot have the ALLOCATABLE"
387                       " attribute"_err_en_US,
388             symbol.name());
389       }
390       if (symbol.attrs().test(Attr::POINTER)) {
391         messages_.Say("Assumed-type argument '%s' cannot have the POINTER"
392                       " attribute"_err_en_US,
393             symbol.name());
394       }
395       if (symbol.attrs().test(Attr::VALUE)) {
396         messages_.Say("Assumed-type argument '%s' cannot have the VALUE"
397                       " attribute"_err_en_US,
398             symbol.name());
399       }
400       if (symbol.attrs().test(Attr::INTENT_OUT)) {
401         messages_.Say(
402             "Assumed-type argument '%s' cannot be INTENT(OUT)"_err_en_US,
403             symbol.name());
404       }
405       if (IsCoarray(symbol)) {
406         messages_.Say(
407             "Assumed-type argument '%s' cannot be a coarray"_err_en_US,
408             symbol.name());
409       }
410       if (details.IsArray() && details.shape().IsExplicitShape()) {
411         messages_.Say(
412             "Assumed-type array argument 'arg8' must be assumed shape,"
413             " assumed size, or assumed rank"_err_en_US,
414             symbol.name());
415       }
416     }
417   }
418 }
419 
420 void CheckHelper::CheckObjectEntity(
421     const Symbol &symbol, const ObjectEntityDetails &details) {
422   CheckArraySpec(symbol, details.shape());
423   Check(details.shape());
424   Check(details.coshape());
425   CheckAssumedTypeEntity(symbol, details);
426   WarnMissingFinal(symbol);
427   if (!details.coshape().empty()) {
428     bool isDeferredShape{details.coshape().IsDeferredShape()};
429     if (IsAllocatable(symbol)) {
430       if (!isDeferredShape) { // C827
431         messages_.Say("'%s' is an ALLOCATABLE coarray and must have a deferred"
432                       " coshape"_err_en_US,
433             symbol.name());
434       }
435     } else if (symbol.owner().IsDerivedType()) { // C746
436       std::string deferredMsg{
437           isDeferredShape ? "" : " and have a deferred coshape"};
438       messages_.Say("Component '%s' is a coarray and must have the ALLOCATABLE"
439                     " attribute%s"_err_en_US,
440           symbol.name(), deferredMsg);
441     } else {
442       if (!details.coshape().IsAssumedSize()) { // C828
443         messages_.Say(
444             "Component '%s' is a non-ALLOCATABLE coarray and must have"
445             " an explicit coshape"_err_en_US,
446             symbol.name());
447       }
448     }
449   }
450   if (details.isDummy()) {
451     if (symbol.attrs().test(Attr::INTENT_OUT)) {
452       if (FindUltimateComponent(symbol, [](const Symbol &x) {
453             return IsCoarray(x) && IsAllocatable(x);
454           })) { // C846
455         messages_.Say(
456             "An INTENT(OUT) dummy argument may not be, or contain, an ALLOCATABLE coarray"_err_en_US);
457       }
458       if (IsOrContainsEventOrLockComponent(symbol)) { // C847
459         messages_.Say(
460             "An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE"_err_en_US);
461       }
462     }
463     if (InPure() && !IsStmtFunction(DEREF(innermostSymbol_)) &&
464         !IsPointer(symbol) && !IsIntentIn(symbol) &&
465         !symbol.attrs().test(Attr::VALUE)) {
466       if (InFunction()) { // C1583
467         messages_.Say(
468             "non-POINTER dummy argument of pure function must be INTENT(IN) or VALUE"_err_en_US);
469       } else if (IsIntentOut(symbol)) {
470         if (const DeclTypeSpec * type{details.type()}) {
471           if (type && type->IsPolymorphic()) { // C1588
472             messages_.Say(
473                 "An INTENT(OUT) dummy argument of a pure subroutine may not be polymorphic"_err_en_US);
474           } else if (const DerivedTypeSpec * derived{type->AsDerived()}) {
475             if (FindUltimateComponent(*derived, [](const Symbol &x) {
476                   const DeclTypeSpec *type{x.GetType()};
477                   return type && type->IsPolymorphic();
478                 })) { // C1588
479               messages_.Say(
480                   "An INTENT(OUT) dummy argument of a pure subroutine may not have a polymorphic ultimate component"_err_en_US);
481             }
482             if (HasImpureFinal(*derived)) { // C1587
483               messages_.Say(
484                   "An INTENT(OUT) dummy argument of a pure subroutine may not have an impure FINAL subroutine"_err_en_US);
485             }
486           }
487         }
488       } else if (!IsIntentInOut(symbol)) { // C1586
489         messages_.Say(
490             "non-POINTER dummy argument of pure subroutine must have INTENT() or VALUE attribute"_err_en_US);
491       }
492     }
493   } else if (symbol.attrs().test(Attr::INTENT_IN) ||
494       symbol.attrs().test(Attr::INTENT_OUT) ||
495       symbol.attrs().test(Attr::INTENT_INOUT)) {
496     messages_.Say("INTENT attributes may apply only to a dummy "
497                   "argument"_err_en_US); // C843
498   } else if (IsOptional(symbol)) {
499     messages_.Say("OPTIONAL attribute may apply only to a dummy "
500                   "argument"_err_en_US); // C849
501   }
502   if (IsStaticallyInitialized(symbol, true /* ignore DATA inits */)) { // C808
503     CheckPointerInitialization(symbol);
504     if (IsAutomatic(symbol)) {
505       messages_.Say(
506           "An automatic variable or component must not be initialized"_err_en_US);
507     } else if (IsDummy(symbol)) {
508       messages_.Say("A dummy argument must not be initialized"_err_en_US);
509     } else if (IsFunctionResult(symbol)) {
510       messages_.Say("A function result must not be initialized"_err_en_US);
511     } else if (IsInBlankCommon(symbol)) {
512       messages_.Say(
513           "A variable in blank COMMON should not be initialized"_en_US);
514     }
515   }
516   if (symbol.owner().kind() == Scope::Kind::BlockData) {
517     if (IsAllocatable(symbol)) {
518       messages_.Say(
519           "An ALLOCATABLE variable may not appear in a BLOCK DATA subprogram"_err_en_US);
520     } else if (IsInitialized(symbol) && !FindCommonBlockContaining(symbol)) {
521       messages_.Say(
522           "An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US);
523     }
524   }
525   if (const DeclTypeSpec * type{details.type()}) { // C708
526     if (type->IsPolymorphic() &&
527         !(type->IsAssumedType() || IsAllocatableOrPointer(symbol) ||
528             IsDummy(symbol))) {
529       messages_.Say("CLASS entity '%s' must be a dummy argument or have "
530                     "ALLOCATABLE or POINTER attribute"_err_en_US,
531           symbol.name());
532     }
533   }
534 }
535 
536 void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
537   if (IsPointer(symbol) && !context_.HasError(symbol) &&
538       !scopeIsUninstantiatedPDT_) {
539     if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
540       if (object->init()) { // C764, C765; C808
541         if (auto designator{evaluate::AsGenericExpr(symbol)}) {
542           auto restorer{messages_.SetLocation(symbol.name())};
543           context_.set_location(symbol.name());
544           CheckInitialTarget(foldingContext_, *designator, *object->init());
545         }
546       }
547     } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
548       if (proc->init() && *proc->init()) {
549         // C1519 - must be nonelemental external or module procedure,
550         // or an unrestricted specific intrinsic function.
551         const Symbol &ultimate{(*proc->init())->GetUltimate()};
552         if (ultimate.attrs().test(Attr::INTRINSIC)) {
553         } else if (!ultimate.attrs().test(Attr::EXTERNAL) &&
554             ultimate.owner().kind() != Scope::Kind::Module) {
555           context_.Say("Procedure pointer '%s' initializer '%s' is neither "
556                        "an external nor a module procedure"_err_en_US,
557               symbol.name(), ultimate.name());
558         } else if (ultimate.attrs().test(Attr::ELEMENTAL)) {
559           context_.Say("Procedure pointer '%s' cannot be initialized with the "
560                        "elemental procedure '%s"_err_en_US,
561               symbol.name(), ultimate.name());
562         } else {
563           // TODO: Check the "shalls" in the 15.4.3.6 paragraphs 7-10.
564         }
565       }
566     }
567   }
568 }
569 
570 // The six different kinds of array-specs:
571 //   array-spec     -> explicit-shape-list | deferred-shape-list
572 //                     | assumed-shape-list | implied-shape-list
573 //                     | assumed-size | assumed-rank
574 //   explicit-shape -> [ lb : ] ub
575 //   deferred-shape -> :
576 //   assumed-shape  -> [ lb ] :
577 //   implied-shape  -> [ lb : ] *
578 //   assumed-size   -> [ explicit-shape-list , ] [ lb : ] *
579 //   assumed-rank   -> ..
580 // Note:
581 // - deferred-shape is also an assumed-shape
582 // - A single "*" or "lb:*" might be assumed-size or implied-shape-list
583 void CheckHelper::CheckArraySpec(
584     const Symbol &symbol, const ArraySpec &arraySpec) {
585   if (arraySpec.Rank() == 0) {
586     return;
587   }
588   bool isExplicit{arraySpec.IsExplicitShape()};
589   bool isDeferred{arraySpec.IsDeferredShape()};
590   bool isImplied{arraySpec.IsImpliedShape()};
591   bool isAssumedShape{arraySpec.IsAssumedShape()};
592   bool isAssumedSize{arraySpec.IsAssumedSize()};
593   bool isAssumedRank{arraySpec.IsAssumedRank()};
594   std::optional<parser::MessageFixedText> msg;
595   if (symbol.test(Symbol::Flag::CrayPointee) && !isExplicit && !isAssumedSize) {
596     msg = "Cray pointee '%s' must have must have explicit shape or"
597           " assumed size"_err_en_US;
598   } else if (IsAllocatableOrPointer(symbol) && !isDeferred && !isAssumedRank) {
599     if (symbol.owner().IsDerivedType()) { // C745
600       if (IsAllocatable(symbol)) {
601         msg = "Allocatable array component '%s' must have"
602               " deferred shape"_err_en_US;
603       } else {
604         msg = "Array pointer component '%s' must have deferred shape"_err_en_US;
605       }
606     } else {
607       if (IsAllocatable(symbol)) { // C832
608         msg = "Allocatable array '%s' must have deferred shape or"
609               " assumed rank"_err_en_US;
610       } else {
611         msg = "Array pointer '%s' must have deferred shape or"
612               " assumed rank"_err_en_US;
613       }
614     }
615   } else if (IsDummy(symbol)) {
616     if (isImplied && !isAssumedSize) { // C836
617       msg = "Dummy array argument '%s' may not have implied shape"_err_en_US;
618     }
619   } else if (isAssumedShape && !isDeferred) {
620     msg = "Assumed-shape array '%s' must be a dummy argument"_err_en_US;
621   } else if (isAssumedSize && !isImplied) { // C833
622     msg = "Assumed-size array '%s' must be a dummy argument"_err_en_US;
623   } else if (isAssumedRank) { // C837
624     msg = "Assumed-rank array '%s' must be a dummy argument"_err_en_US;
625   } else if (isImplied) {
626     if (!IsNamedConstant(symbol)) { // C835, C836
627       msg = "Implied-shape array '%s' must be a named constant or a "
628             "dummy argument"_err_en_US;
629     }
630   } else if (IsNamedConstant(symbol)) {
631     if (!isExplicit && !isImplied) {
632       msg = "Named constant '%s' array must have constant or"
633             " implied shape"_err_en_US;
634     }
635   } else if (!IsAllocatableOrPointer(symbol) && !isExplicit) {
636     if (symbol.owner().IsDerivedType()) { // C749
637       msg = "Component array '%s' without ALLOCATABLE or POINTER attribute must"
638             " have explicit shape"_err_en_US;
639     } else { // C816
640       msg = "Array '%s' without ALLOCATABLE or POINTER attribute must have"
641             " explicit shape"_err_en_US;
642     }
643   }
644   if (msg) {
645     context_.Say(std::move(*msg), symbol.name());
646   }
647 }
648 
649 void CheckHelper::CheckProcEntity(
650     const Symbol &symbol, const ProcEntityDetails &details) {
651   if (details.isDummy()) {
652     if (!symbol.attrs().test(Attr::POINTER) && // C843
653         (symbol.attrs().test(Attr::INTENT_IN) ||
654             symbol.attrs().test(Attr::INTENT_OUT) ||
655             symbol.attrs().test(Attr::INTENT_INOUT))) {
656       messages_.Say("A dummy procedure without the POINTER attribute"
657                     " may not have an INTENT attribute"_err_en_US);
658     }
659 
660     const Symbol *interface{details.interface().symbol()};
661     if (!symbol.attrs().test(Attr::INTRINSIC) &&
662         (symbol.attrs().test(Attr::ELEMENTAL) ||
663             (interface && !interface->attrs().test(Attr::INTRINSIC) &&
664                 interface->attrs().test(Attr::ELEMENTAL)))) {
665       // There's no explicit constraint or "shall" that we can find in the
666       // standard for this check, but it seems to be implied in multiple
667       // sites, and ELEMENTAL non-intrinsic actual arguments *are*
668       // explicitly forbidden.  But we allow "PROCEDURE(SIN)::dummy"
669       // because it is explicitly legal to *pass* the specific intrinsic
670       // function SIN as an actual argument.
671       messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
672     }
673   } else if (symbol.attrs().test(Attr::INTENT_IN) ||
674       symbol.attrs().test(Attr::INTENT_OUT) ||
675       symbol.attrs().test(Attr::INTENT_INOUT)) {
676     messages_.Say("INTENT attributes may apply only to a dummy "
677                   "argument"_err_en_US); // C843
678   } else if (IsOptional(symbol)) {
679     messages_.Say("OPTIONAL attribute may apply only to a dummy "
680                   "argument"_err_en_US); // C849
681   } else if (symbol.owner().IsDerivedType()) {
682     if (!symbol.attrs().test(Attr::POINTER)) { // C756
683       const auto &name{symbol.name()};
684       messages_.Say(name,
685           "Procedure component '%s' must have POINTER attribute"_err_en_US,
686           name);
687     }
688     CheckPassArg(symbol, details.interface().symbol(), details);
689   }
690   if (symbol.attrs().test(Attr::POINTER)) {
691     CheckPointerInitialization(symbol);
692     if (const Symbol * interface{details.interface().symbol()}) {
693       if (interface->attrs().test(Attr::ELEMENTAL) &&
694           !interface->attrs().test(Attr::INTRINSIC)) {
695         messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US,
696             symbol.name()); // C1517
697       }
698     }
699   } else if (symbol.attrs().test(Attr::SAVE)) {
700     messages_.Say(
701         "Procedure '%s' with SAVE attribute must also have POINTER attribute"_err_en_US,
702         symbol.name());
703   }
704 }
705 
706 // When a module subprogram has the MODULE prefix the following must match
707 // with the corresponding separate module procedure interface body:
708 // - C1549: characteristics and dummy argument names
709 // - C1550: binding label
710 // - C1551: NON_RECURSIVE prefix
711 class SubprogramMatchHelper {
712 public:
713   explicit SubprogramMatchHelper(CheckHelper &checkHelper)
714       : checkHelper{checkHelper} {}
715 
716   void Check(const Symbol &, const Symbol &);
717 
718 private:
719   SemanticsContext &context() { return checkHelper.context(); }
720   void CheckDummyArg(const Symbol &, const Symbol &, const DummyArgument &,
721       const DummyArgument &);
722   void CheckDummyDataObject(const Symbol &, const Symbol &,
723       const DummyDataObject &, const DummyDataObject &);
724   void CheckDummyProcedure(const Symbol &, const Symbol &,
725       const DummyProcedure &, const DummyProcedure &);
726   bool CheckSameIntent(
727       const Symbol &, const Symbol &, common::Intent, common::Intent);
728   template <typename... A>
729   void Say(
730       const Symbol &, const Symbol &, parser::MessageFixedText &&, A &&...);
731   template <typename ATTRS>
732   bool CheckSameAttrs(const Symbol &, const Symbol &, ATTRS, ATTRS);
733   bool ShapesAreCompatible(const DummyDataObject &, const DummyDataObject &);
734   evaluate::Shape FoldShape(const evaluate::Shape &);
735   std::string AsFortran(DummyDataObject::Attr attr) {
736     return parser::ToUpperCaseLetters(DummyDataObject::EnumToString(attr));
737   }
738   std::string AsFortran(DummyProcedure::Attr attr) {
739     return parser::ToUpperCaseLetters(DummyProcedure::EnumToString(attr));
740   }
741 
742   CheckHelper &checkHelper;
743 };
744 
745 // 15.6.2.6 para 3 - can the result of an ENTRY differ from its function?
746 bool CheckHelper::IsResultOkToDiffer(const FunctionResult &result) {
747   if (result.attrs.test(FunctionResult::Attr::Allocatable) ||
748       result.attrs.test(FunctionResult::Attr::Pointer)) {
749     return false;
750   }
751   const auto *typeAndShape{result.GetTypeAndShape()};
752   if (!typeAndShape || typeAndShape->Rank() != 0) {
753     return false;
754   }
755   auto category{typeAndShape->type().category()};
756   if (category == TypeCategory::Character ||
757       category == TypeCategory::Derived) {
758     return false;
759   }
760   int kind{typeAndShape->type().kind()};
761   return kind == context_.GetDefaultKind(category) ||
762       (category == TypeCategory::Real &&
763           kind == context_.doublePrecisionKind());
764 }
765 
766 void CheckHelper::CheckSubprogram(
767     const Symbol &symbol, const SubprogramDetails &details) {
768   if (const Symbol * iface{FindSeparateModuleSubprogramInterface(&symbol)}) {
769     SubprogramMatchHelper{*this}.Check(symbol, *iface);
770   }
771   if (const Scope * entryScope{details.entryScope()}) {
772     // ENTRY 15.6.2.6, esp. C1571
773     std::optional<parser::MessageFixedText> error;
774     const Symbol *subprogram{entryScope->symbol()};
775     const SubprogramDetails *subprogramDetails{nullptr};
776     if (subprogram) {
777       subprogramDetails = subprogram->detailsIf<SubprogramDetails>();
778     }
779     if (entryScope->kind() != Scope::Kind::Subprogram) {
780       error = "ENTRY may appear only in a subroutine or function"_err_en_US;
781     } else if (!(entryScope->parent().IsGlobal() ||
782                    entryScope->parent().IsModule() ||
783                    entryScope->parent().IsSubmodule())) {
784       error = "ENTRY may not appear in an internal subprogram"_err_en_US;
785     } else if (FindSeparateModuleSubprogramInterface(subprogram)) {
786       error = "ENTRY may not appear in a separate module procedure"_err_en_US;
787     } else if (subprogramDetails && details.isFunction() &&
788         subprogramDetails->isFunction()) {
789       auto result{FunctionResult::Characterize(
790           details.result(), context_.foldingContext())};
791       auto subpResult{FunctionResult::Characterize(
792           subprogramDetails->result(), context_.foldingContext())};
793       if (result && subpResult && *result != *subpResult &&
794           (!IsResultOkToDiffer(*result) || !IsResultOkToDiffer(*subpResult))) {
795         error =
796             "Result of ENTRY is not compatible with result of containing function"_err_en_US;
797       }
798     }
799     if (error) {
800       if (auto *msg{messages_.Say(symbol.name(), *error)}) {
801         if (subprogram) {
802           msg->Attach(subprogram->name(), "Containing subprogram"_en_US);
803         }
804       }
805     }
806   }
807 }
808 
809 void CheckHelper::CheckDerivedType(
810     const Symbol &derivedType, const DerivedTypeDetails &details) {
811   const Scope *scope{derivedType.scope()};
812   if (!scope) {
813     CHECK(details.isForwardReferenced());
814     return;
815   }
816   CHECK(scope->symbol() == &derivedType);
817   CHECK(scope->IsDerivedType());
818   if (derivedType.attrs().test(Attr::ABSTRACT) && // C734
819       (derivedType.attrs().test(Attr::BIND_C) || details.sequence())) {
820     messages_.Say("An ABSTRACT derived type must be extensible"_err_en_US);
821   }
822   if (const DeclTypeSpec * parent{FindParentTypeSpec(derivedType)}) {
823     const DerivedTypeSpec *parentDerived{parent->AsDerived()};
824     if (!IsExtensibleType(parentDerived)) { // C705
825       messages_.Say("The parent type is not extensible"_err_en_US);
826     }
827     if (!derivedType.attrs().test(Attr::ABSTRACT) && parentDerived &&
828         parentDerived->typeSymbol().attrs().test(Attr::ABSTRACT)) {
829       ScopeComponentIterator components{*parentDerived};
830       for (const Symbol &component : components) {
831         if (component.attrs().test(Attr::DEFERRED)) {
832           if (scope->FindComponent(component.name()) == &component) {
833             SayWithDeclaration(component,
834                 "Non-ABSTRACT extension of ABSTRACT derived type '%s' lacks a binding for DEFERRED procedure '%s'"_err_en_US,
835                 parentDerived->typeSymbol().name(), component.name());
836           }
837         }
838       }
839     }
840     DerivedTypeSpec derived{derivedType.name(), derivedType};
841     derived.set_scope(*scope);
842     if (FindCoarrayUltimateComponent(derived) && // C736
843         !(parentDerived && FindCoarrayUltimateComponent(*parentDerived))) {
844       messages_.Say(
845           "Type '%s' has a coarray ultimate component so the type at the base "
846           "of its type extension chain ('%s') must be a type that has a "
847           "coarray ultimate component"_err_en_US,
848           derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name());
849     }
850     if (FindEventOrLockPotentialComponent(derived) && // C737
851         !(FindEventOrLockPotentialComponent(*parentDerived) ||
852             IsEventTypeOrLockType(parentDerived))) {
853       messages_.Say(
854           "Type '%s' has an EVENT_TYPE or LOCK_TYPE component, so the type "
855           "at the base of its type extension chain ('%s') must either have an "
856           "EVENT_TYPE or LOCK_TYPE component, or be EVENT_TYPE or "
857           "LOCK_TYPE"_err_en_US,
858           derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name());
859     }
860   }
861   if (HasIntrinsicTypeName(derivedType)) { // C729
862     messages_.Say("A derived type name cannot be the name of an intrinsic"
863                   " type"_err_en_US);
864   }
865   std::map<SourceName, SymbolRef> previous;
866   for (const auto &pair : details.finals()) {
867     SourceName source{pair.first};
868     const Symbol &ref{*pair.second};
869     if (CheckFinal(ref, source, derivedType) &&
870         std::all_of(previous.begin(), previous.end(),
871             [&](std::pair<SourceName, SymbolRef> prev) {
872               return CheckDistinguishableFinals(
873                   ref, source, *prev.second, prev.first, derivedType);
874             })) {
875       previous.emplace(source, ref);
876     }
877   }
878 }
879 
880 // C786
881 bool CheckHelper::CheckFinal(
882     const Symbol &subroutine, SourceName finalName, const Symbol &derivedType) {
883   if (!IsModuleProcedure(subroutine)) {
884     SayWithDeclaration(subroutine, finalName,
885         "FINAL subroutine '%s' of derived type '%s' must be a module procedure"_err_en_US,
886         subroutine.name(), derivedType.name());
887     return false;
888   }
889   const Procedure *proc{Characterize(subroutine)};
890   if (!proc) {
891     return false; // error recovery
892   }
893   if (!proc->IsSubroutine()) {
894     SayWithDeclaration(subroutine, finalName,
895         "FINAL subroutine '%s' of derived type '%s' must be a subroutine"_err_en_US,
896         subroutine.name(), derivedType.name());
897     return false;
898   }
899   if (proc->dummyArguments.size() != 1) {
900     SayWithDeclaration(subroutine, finalName,
901         "FINAL subroutine '%s' of derived type '%s' must have a single dummy argument"_err_en_US,
902         subroutine.name(), derivedType.name());
903     return false;
904   }
905   const auto &arg{proc->dummyArguments[0]};
906   const Symbol *errSym{&subroutine};
907   if (const auto *details{subroutine.detailsIf<SubprogramDetails>()}) {
908     if (!details->dummyArgs().empty()) {
909       if (const Symbol * argSym{details->dummyArgs()[0]}) {
910         errSym = argSym;
911       }
912     }
913   }
914   const auto *ddo{std::get_if<DummyDataObject>(&arg.u)};
915   if (!ddo) {
916     SayWithDeclaration(subroutine, finalName,
917         "FINAL subroutine '%s' of derived type '%s' must have a single dummy argument that is a data object"_err_en_US,
918         subroutine.name(), derivedType.name());
919     return false;
920   }
921   bool ok{true};
922   if (arg.IsOptional()) {
923     SayWithDeclaration(*errSym, finalName,
924         "FINAL subroutine '%s' of derived type '%s' must not have an OPTIONAL dummy argument"_err_en_US,
925         subroutine.name(), derivedType.name());
926     ok = false;
927   }
928   if (ddo->attrs.test(DummyDataObject::Attr::Allocatable)) {
929     SayWithDeclaration(*errSym, finalName,
930         "FINAL subroutine '%s' of derived type '%s' must not have an ALLOCATABLE dummy argument"_err_en_US,
931         subroutine.name(), derivedType.name());
932     ok = false;
933   }
934   if (ddo->attrs.test(DummyDataObject::Attr::Pointer)) {
935     SayWithDeclaration(*errSym, finalName,
936         "FINAL subroutine '%s' of derived type '%s' must not have a POINTER dummy argument"_err_en_US,
937         subroutine.name(), derivedType.name());
938     ok = false;
939   }
940   if (ddo->intent == common::Intent::Out) {
941     SayWithDeclaration(*errSym, finalName,
942         "FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with INTENT(OUT)"_err_en_US,
943         subroutine.name(), derivedType.name());
944     ok = false;
945   }
946   if (ddo->attrs.test(DummyDataObject::Attr::Value)) {
947     SayWithDeclaration(*errSym, finalName,
948         "FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with the VALUE attribute"_err_en_US,
949         subroutine.name(), derivedType.name());
950     ok = false;
951   }
952   if (ddo->type.corank() > 0) {
953     SayWithDeclaration(*errSym, finalName,
954         "FINAL subroutine '%s' of derived type '%s' must not have a coarray dummy argument"_err_en_US,
955         subroutine.name(), derivedType.name());
956     ok = false;
957   }
958   if (ddo->type.type().IsPolymorphic()) {
959     SayWithDeclaration(*errSym, finalName,
960         "FINAL subroutine '%s' of derived type '%s' must not have a polymorphic dummy argument"_err_en_US,
961         subroutine.name(), derivedType.name());
962     ok = false;
963   } else if (ddo->type.type().category() != TypeCategory::Derived ||
964       &ddo->type.type().GetDerivedTypeSpec().typeSymbol() != &derivedType) {
965     SayWithDeclaration(*errSym, finalName,
966         "FINAL subroutine '%s' of derived type '%s' must have a TYPE(%s) dummy argument"_err_en_US,
967         subroutine.name(), derivedType.name(), derivedType.name());
968     ok = false;
969   } else { // check that all LEN type parameters are assumed
970     for (auto ref : OrderParameterDeclarations(derivedType)) {
971       if (IsLenTypeParameter(*ref)) {
972         const auto *value{
973             ddo->type.type().GetDerivedTypeSpec().FindParameter(ref->name())};
974         if (!value || !value->isAssumed()) {
975           SayWithDeclaration(*errSym, finalName,
976               "FINAL subroutine '%s' of derived type '%s' must have a dummy argument with an assumed LEN type parameter '%s=*'"_err_en_US,
977               subroutine.name(), derivedType.name(), ref->name());
978           ok = false;
979         }
980       }
981     }
982   }
983   return ok;
984 }
985 
986 bool CheckHelper::CheckDistinguishableFinals(const Symbol &f1,
987     SourceName f1Name, const Symbol &f2, SourceName f2Name,
988     const Symbol &derivedType) {
989   const Procedure *p1{Characterize(f1)};
990   const Procedure *p2{Characterize(f2)};
991   if (p1 && p2) {
992     if (characteristics::Distinguishable(*p1, *p2)) {
993       return true;
994     }
995     if (auto *msg{messages_.Say(f1Name,
996             "FINAL subroutines '%s' and '%s' of derived type '%s' cannot be distinguished by rank or KIND type parameter value"_err_en_US,
997             f1Name, f2Name, derivedType.name())}) {
998       msg->Attach(f2Name, "FINAL declaration of '%s'"_en_US, f2.name())
999           .Attach(f1.name(), "Definition of '%s'"_en_US, f1Name)
1000           .Attach(f2.name(), "Definition of '%s'"_en_US, f2Name);
1001     }
1002   }
1003   return false;
1004 }
1005 
1006 void CheckHelper::CheckHostAssoc(
1007     const Symbol &symbol, const HostAssocDetails &details) {
1008   const Symbol &hostSymbol{details.symbol()};
1009   if (hostSymbol.test(Symbol::Flag::ImplicitOrError)) {
1010     if (details.implicitOrSpecExprError) {
1011       messages_.Say("Implicitly typed local entity '%s' not allowed in"
1012                     " specification expression"_err_en_US,
1013           symbol.name());
1014     } else if (details.implicitOrExplicitTypeError) {
1015       messages_.Say(
1016           "No explicit type declared for '%s'"_err_en_US, symbol.name());
1017     }
1018   }
1019 }
1020 
1021 void CheckHelper::CheckGeneric(
1022     const Symbol &symbol, const GenericDetails &details) {
1023   CheckSpecificsAreDistinguishable(symbol, details);
1024 }
1025 
1026 // Check that the specifics of this generic are distinguishable from each other
1027 void CheckHelper::CheckSpecificsAreDistinguishable(
1028     const Symbol &generic, const GenericDetails &details) {
1029   GenericKind kind{details.kind()};
1030   const SymbolVector &specifics{details.specificProcs()};
1031   std::size_t count{specifics.size()};
1032   if (count < 2 || !kind.IsName()) {
1033     return;
1034   }
1035   DistinguishabilityHelper helper{context_};
1036   for (const Symbol &specific : specifics) {
1037     if (const Procedure * procedure{Characterize(specific)}) {
1038       helper.Add(generic, kind, specific, *procedure);
1039     }
1040   }
1041   helper.Check(generic.owner());
1042 }
1043 
1044 static bool ConflictsWithIntrinsicAssignment(const Procedure &proc) {
1045   auto lhs{std::get<DummyDataObject>(proc.dummyArguments[0].u).type};
1046   auto rhs{std::get<DummyDataObject>(proc.dummyArguments[1].u).type};
1047   return Tristate::No ==
1048       IsDefinedAssignment(lhs.type(), lhs.Rank(), rhs.type(), rhs.Rank());
1049 }
1050 
1051 static bool ConflictsWithIntrinsicOperator(
1052     const GenericKind &kind, const Procedure &proc) {
1053   if (!kind.IsIntrinsicOperator()) {
1054     return false;
1055   }
1056   auto arg0{std::get<DummyDataObject>(proc.dummyArguments[0].u).type};
1057   auto type0{arg0.type()};
1058   if (proc.dummyArguments.size() == 1) { // unary
1059     return std::visit(
1060         common::visitors{
1061             [&](common::NumericOperator) { return IsIntrinsicNumeric(type0); },
1062             [&](common::LogicalOperator) { return IsIntrinsicLogical(type0); },
1063             [](const auto &) -> bool { DIE("bad generic kind"); },
1064         },
1065         kind.u);
1066   } else { // binary
1067     int rank0{arg0.Rank()};
1068     auto arg1{std::get<DummyDataObject>(proc.dummyArguments[1].u).type};
1069     auto type1{arg1.type()};
1070     int rank1{arg1.Rank()};
1071     return std::visit(
1072         common::visitors{
1073             [&](common::NumericOperator) {
1074               return IsIntrinsicNumeric(type0, rank0, type1, rank1);
1075             },
1076             [&](common::LogicalOperator) {
1077               return IsIntrinsicLogical(type0, rank0, type1, rank1);
1078             },
1079             [&](common::RelationalOperator opr) {
1080               return IsIntrinsicRelational(opr, type0, rank0, type1, rank1);
1081             },
1082             [&](GenericKind::OtherKind x) {
1083               CHECK(x == GenericKind::OtherKind::Concat);
1084               return IsIntrinsicConcat(type0, rank0, type1, rank1);
1085             },
1086             [](const auto &) -> bool { DIE("bad generic kind"); },
1087         },
1088         kind.u);
1089   }
1090 }
1091 
1092 // Check if this procedure can be used for defined operators (see 15.4.3.4.2).
1093 bool CheckHelper::CheckDefinedOperator(SourceName opName, GenericKind kind,
1094     const Symbol &specific, const Procedure &proc) {
1095   if (context_.HasError(specific)) {
1096     return false;
1097   }
1098   std::optional<parser::MessageFixedText> msg;
1099   if (specific.attrs().test(Attr::NOPASS)) { // C774
1100     msg = "%s procedure '%s' may not have NOPASS attribute"_err_en_US;
1101   } else if (!proc.functionResult.has_value()) {
1102     msg = "%s procedure '%s' must be a function"_err_en_US;
1103   } else if (proc.functionResult->IsAssumedLengthCharacter()) {
1104     msg = "%s function '%s' may not have assumed-length CHARACTER(*)"
1105           " result"_err_en_US;
1106   } else if (auto m{CheckNumberOfArgs(kind, proc.dummyArguments.size())}) {
1107     msg = std::move(m);
1108   } else if (!CheckDefinedOperatorArg(opName, specific, proc, 0) |
1109       !CheckDefinedOperatorArg(opName, specific, proc, 1)) {
1110     return false; // error was reported
1111   } else if (ConflictsWithIntrinsicOperator(kind, proc)) {
1112     msg = "%s function '%s' conflicts with intrinsic operator"_err_en_US;
1113   } else {
1114     return true; // OK
1115   }
1116   SayWithDeclaration(
1117       specific, std::move(*msg), MakeOpName(opName), specific.name());
1118   context_.SetError(specific);
1119   return false;
1120 }
1121 
1122 // If the number of arguments is wrong for this intrinsic operator, return
1123 // false and return the error message in msg.
1124 std::optional<parser::MessageFixedText> CheckHelper::CheckNumberOfArgs(
1125     const GenericKind &kind, std::size_t nargs) {
1126   if (!kind.IsIntrinsicOperator()) {
1127     return std::nullopt;
1128   }
1129   std::size_t min{2}, max{2}; // allowed number of args; default is binary
1130   std::visit(common::visitors{
1131                  [&](const common::NumericOperator &x) {
1132                    if (x == common::NumericOperator::Add ||
1133                        x == common::NumericOperator::Subtract) {
1134                      min = 1; // + and - are unary or binary
1135                    }
1136                  },
1137                  [&](const common::LogicalOperator &x) {
1138                    if (x == common::LogicalOperator::Not) {
1139                      min = 1; // .NOT. is unary
1140                      max = 1;
1141                    }
1142                  },
1143                  [](const common::RelationalOperator &) {
1144                    // all are binary
1145                  },
1146                  [](const GenericKind::OtherKind &x) {
1147                    CHECK(x == GenericKind::OtherKind::Concat);
1148                  },
1149                  [](const auto &) { DIE("expected intrinsic operator"); },
1150              },
1151       kind.u);
1152   if (nargs >= min && nargs <= max) {
1153     return std::nullopt;
1154   } else if (max == 1) {
1155     return "%s function '%s' must have one dummy argument"_err_en_US;
1156   } else if (min == 2) {
1157     return "%s function '%s' must have two dummy arguments"_err_en_US;
1158   } else {
1159     return "%s function '%s' must have one or two dummy arguments"_err_en_US;
1160   }
1161 }
1162 
1163 bool CheckHelper::CheckDefinedOperatorArg(const SourceName &opName,
1164     const Symbol &symbol, const Procedure &proc, std::size_t pos) {
1165   if (pos >= proc.dummyArguments.size()) {
1166     return true;
1167   }
1168   auto &arg{proc.dummyArguments.at(pos)};
1169   std::optional<parser::MessageFixedText> msg;
1170   if (arg.IsOptional()) {
1171     msg = "In %s function '%s', dummy argument '%s' may not be"
1172           " OPTIONAL"_err_en_US;
1173   } else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)};
1174              dataObject == nullptr) {
1175     msg = "In %s function '%s', dummy argument '%s' must be a"
1176           " data object"_err_en_US;
1177   } else if (dataObject->intent != common::Intent::In &&
1178       !dataObject->attrs.test(DummyDataObject::Attr::Value)) {
1179     msg = "In %s function '%s', dummy argument '%s' must have INTENT(IN)"
1180           " or VALUE attribute"_err_en_US;
1181   }
1182   if (msg) {
1183     SayWithDeclaration(symbol, std::move(*msg),
1184         parser::ToUpperCaseLetters(opName.ToString()), symbol.name(), arg.name);
1185     return false;
1186   }
1187   return true;
1188 }
1189 
1190 // Check if this procedure can be used for defined assignment (see 15.4.3.4.3).
1191 bool CheckHelper::CheckDefinedAssignment(
1192     const Symbol &specific, const Procedure &proc) {
1193   if (context_.HasError(specific)) {
1194     return false;
1195   }
1196   std::optional<parser::MessageFixedText> msg;
1197   if (specific.attrs().test(Attr::NOPASS)) { // C774
1198     msg = "Defined assignment procedure '%s' may not have"
1199           " NOPASS attribute"_err_en_US;
1200   } else if (!proc.IsSubroutine()) {
1201     msg = "Defined assignment procedure '%s' must be a subroutine"_err_en_US;
1202   } else if (proc.dummyArguments.size() != 2) {
1203     msg = "Defined assignment subroutine '%s' must have"
1204           " two dummy arguments"_err_en_US;
1205   } else if (!CheckDefinedAssignmentArg(specific, proc.dummyArguments[0], 0) |
1206       !CheckDefinedAssignmentArg(specific, proc.dummyArguments[1], 1)) {
1207     return false; // error was reported
1208   } else if (ConflictsWithIntrinsicAssignment(proc)) {
1209     msg = "Defined assignment subroutine '%s' conflicts with"
1210           " intrinsic assignment"_err_en_US;
1211   } else {
1212     return true; // OK
1213   }
1214   SayWithDeclaration(specific, std::move(msg.value()), specific.name());
1215   context_.SetError(specific);
1216   return false;
1217 }
1218 
1219 bool CheckHelper::CheckDefinedAssignmentArg(
1220     const Symbol &symbol, const DummyArgument &arg, int pos) {
1221   std::optional<parser::MessageFixedText> msg;
1222   if (arg.IsOptional()) {
1223     msg = "In defined assignment subroutine '%s', dummy argument '%s'"
1224           " may not be OPTIONAL"_err_en_US;
1225   } else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)}) {
1226     if (pos == 0) {
1227       if (dataObject->intent != common::Intent::Out &&
1228           dataObject->intent != common::Intent::InOut) {
1229         msg = "In defined assignment subroutine '%s', first dummy argument '%s'"
1230               " must have INTENT(OUT) or INTENT(INOUT)"_err_en_US;
1231       }
1232     } else if (pos == 1) {
1233       if (dataObject->intent != common::Intent::In &&
1234           !dataObject->attrs.test(DummyDataObject::Attr::Value)) {
1235         msg =
1236             "In defined assignment subroutine '%s', second dummy"
1237             " argument '%s' must have INTENT(IN) or VALUE attribute"_err_en_US;
1238       }
1239     } else {
1240       DIE("pos must be 0 or 1");
1241     }
1242   } else {
1243     msg = "In defined assignment subroutine '%s', dummy argument '%s'"
1244           " must be a data object"_err_en_US;
1245   }
1246   if (msg) {
1247     SayWithDeclaration(symbol, std::move(*msg), symbol.name(), arg.name);
1248     context_.SetError(symbol);
1249     return false;
1250   }
1251   return true;
1252 }
1253 
1254 // Report a conflicting attribute error if symbol has both of these attributes
1255 bool CheckHelper::CheckConflicting(const Symbol &symbol, Attr a1, Attr a2) {
1256   if (symbol.attrs().test(a1) && symbol.attrs().test(a2)) {
1257     messages_.Say("'%s' may not have both the %s and %s attributes"_err_en_US,
1258         symbol.name(), EnumToString(a1), EnumToString(a2));
1259     return true;
1260   } else {
1261     return false;
1262   }
1263 }
1264 
1265 void CheckHelper::WarnMissingFinal(const Symbol &symbol) {
1266   const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
1267   if (!object || IsPointer(symbol)) {
1268     return;
1269   }
1270   const DeclTypeSpec *type{object->type()};
1271   const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
1272   const Symbol *derivedSym{derived ? &derived->typeSymbol() : nullptr};
1273   int rank{object->shape().Rank()};
1274   const Symbol *initialDerivedSym{derivedSym};
1275   while (const auto *derivedDetails{
1276       derivedSym ? derivedSym->detailsIf<DerivedTypeDetails>() : nullptr}) {
1277     if (!derivedDetails->finals().empty() &&
1278         !derivedDetails->GetFinalForRank(rank)) {
1279       if (auto *msg{derivedSym == initialDerivedSym
1280                   ? messages_.Say(symbol.name(),
1281                         "'%s' of derived type '%s' does not have a FINAL subroutine for its rank (%d)"_en_US,
1282                         symbol.name(), derivedSym->name(), rank)
1283                   : messages_.Say(symbol.name(),
1284                         "'%s' of derived type '%s' extended from '%s' does not have a FINAL subroutine for its rank (%d)"_en_US,
1285                         symbol.name(), initialDerivedSym->name(),
1286                         derivedSym->name(), rank)}) {
1287         msg->Attach(derivedSym->name(),
1288             "Declaration of derived type '%s'"_en_US, derivedSym->name());
1289       }
1290       return;
1291     }
1292     derived = derivedSym->GetParentTypeSpec();
1293     derivedSym = derived ? &derived->typeSymbol() : nullptr;
1294   }
1295 }
1296 
1297 const Procedure *CheckHelper::Characterize(const Symbol &symbol) {
1298   auto it{characterizeCache_.find(symbol)};
1299   if (it == characterizeCache_.end()) {
1300     auto pair{characterizeCache_.emplace(SymbolRef{symbol},
1301         Procedure::Characterize(symbol, context_.foldingContext()))};
1302     it = pair.first;
1303   }
1304   return common::GetPtrFromOptional(it->second);
1305 }
1306 
1307 void CheckHelper::CheckVolatile(const Symbol &symbol,
1308     const DerivedTypeSpec *derived) { // C866 - C868
1309   if (IsIntentIn(symbol)) {
1310     messages_.Say(
1311         "VOLATILE attribute may not apply to an INTENT(IN) argument"_err_en_US);
1312   }
1313   if (IsProcedure(symbol)) {
1314     messages_.Say("VOLATILE attribute may apply only to a variable"_err_en_US);
1315   }
1316   if (symbol.has<UseDetails>() || symbol.has<HostAssocDetails>()) {
1317     const Symbol &ultimate{symbol.GetUltimate()};
1318     if (IsCoarray(ultimate)) {
1319       messages_.Say(
1320           "VOLATILE attribute may not apply to a coarray accessed by USE or host association"_err_en_US);
1321     }
1322     if (derived) {
1323       if (FindCoarrayUltimateComponent(*derived)) {
1324         messages_.Say(
1325             "VOLATILE attribute may not apply to a type with a coarray ultimate component accessed by USE or host association"_err_en_US);
1326       }
1327     }
1328   }
1329 }
1330 
1331 void CheckHelper::CheckPointer(const Symbol &symbol) { // C852
1332   CheckConflicting(symbol, Attr::POINTER, Attr::TARGET);
1333   CheckConflicting(symbol, Attr::POINTER, Attr::ALLOCATABLE); // C751
1334   CheckConflicting(symbol, Attr::POINTER, Attr::INTRINSIC);
1335   // Prohibit constant pointers.  The standard does not explicitly prohibit
1336   // them, but the PARAMETER attribute requires a entity-decl to have an
1337   // initialization that is a constant-expr, and the only form of
1338   // initialization that allows a constant-expr is the one that's not a "=>"
1339   // pointer initialization.  See C811, C807, and section 8.5.13.
1340   CheckConflicting(symbol, Attr::POINTER, Attr::PARAMETER);
1341   if (symbol.Corank() > 0) {
1342     messages_.Say(
1343         "'%s' may not have the POINTER attribute because it is a coarray"_err_en_US,
1344         symbol.name());
1345   }
1346 }
1347 
1348 // C760 constraints on the passed-object dummy argument
1349 // C757 constraints on procedure pointer components
1350 void CheckHelper::CheckPassArg(
1351     const Symbol &proc, const Symbol *interface, const WithPassArg &details) {
1352   if (proc.attrs().test(Attr::NOPASS)) {
1353     return;
1354   }
1355   const auto &name{proc.name()};
1356   if (!interface) {
1357     messages_.Say(name,
1358         "Procedure component '%s' must have NOPASS attribute or explicit interface"_err_en_US,
1359         name);
1360     return;
1361   }
1362   const auto *subprogram{interface->detailsIf<SubprogramDetails>()};
1363   if (!subprogram) {
1364     messages_.Say(name,
1365         "Procedure component '%s' has invalid interface '%s'"_err_en_US, name,
1366         interface->name());
1367     return;
1368   }
1369   std::optional<SourceName> passName{details.passName()};
1370   const auto &dummyArgs{subprogram->dummyArgs()};
1371   if (!passName) {
1372     if (dummyArgs.empty()) {
1373       messages_.Say(name,
1374           proc.has<ProcEntityDetails>()
1375               ? "Procedure component '%s' with no dummy arguments"
1376                 " must have NOPASS attribute"_err_en_US
1377               : "Procedure binding '%s' with no dummy arguments"
1378                 " must have NOPASS attribute"_err_en_US,
1379           name);
1380       context_.SetError(*interface);
1381       return;
1382     }
1383     Symbol *argSym{dummyArgs[0]};
1384     if (!argSym) {
1385       messages_.Say(interface->name(),
1386           "Cannot use an alternate return as the passed-object dummy "
1387           "argument"_err_en_US);
1388       return;
1389     }
1390     passName = dummyArgs[0]->name();
1391   }
1392   std::optional<int> passArgIndex{};
1393   for (std::size_t i{0}; i < dummyArgs.size(); ++i) {
1394     if (dummyArgs[i] && dummyArgs[i]->name() == *passName) {
1395       passArgIndex = i;
1396       break;
1397     }
1398   }
1399   if (!passArgIndex) { // C758
1400     messages_.Say(*passName,
1401         "'%s' is not a dummy argument of procedure interface '%s'"_err_en_US,
1402         *passName, interface->name());
1403     return;
1404   }
1405   const Symbol &passArg{*dummyArgs[*passArgIndex]};
1406   std::optional<parser::MessageFixedText> msg;
1407   if (!passArg.has<ObjectEntityDetails>()) {
1408     msg = "Passed-object dummy argument '%s' of procedure '%s'"
1409           " must be a data object"_err_en_US;
1410   } else if (passArg.attrs().test(Attr::POINTER)) {
1411     msg = "Passed-object dummy argument '%s' of procedure '%s'"
1412           " may not have the POINTER attribute"_err_en_US;
1413   } else if (passArg.attrs().test(Attr::ALLOCATABLE)) {
1414     msg = "Passed-object dummy argument '%s' of procedure '%s'"
1415           " may not have the ALLOCATABLE attribute"_err_en_US;
1416   } else if (passArg.attrs().test(Attr::VALUE)) {
1417     msg = "Passed-object dummy argument '%s' of procedure '%s'"
1418           " may not have the VALUE attribute"_err_en_US;
1419   } else if (passArg.Rank() > 0) {
1420     msg = "Passed-object dummy argument '%s' of procedure '%s'"
1421           " must be scalar"_err_en_US;
1422   }
1423   if (msg) {
1424     messages_.Say(name, std::move(*msg), passName.value(), name);
1425     return;
1426   }
1427   const DeclTypeSpec *type{passArg.GetType()};
1428   if (!type) {
1429     return; // an error already occurred
1430   }
1431   const Symbol &typeSymbol{*proc.owner().GetSymbol()};
1432   const DerivedTypeSpec *derived{type->AsDerived()};
1433   if (!derived || derived->typeSymbol() != typeSymbol) {
1434     messages_.Say(name,
1435         "Passed-object dummy argument '%s' of procedure '%s'"
1436         " must be of type '%s' but is '%s'"_err_en_US,
1437         passName.value(), name, typeSymbol.name(), type->AsFortran());
1438     return;
1439   }
1440   if (IsExtensibleType(derived) != type->IsPolymorphic()) {
1441     messages_.Say(name,
1442         type->IsPolymorphic()
1443             ? "Passed-object dummy argument '%s' of procedure '%s'"
1444               " may not be polymorphic because '%s' is not extensible"_err_en_US
1445             : "Passed-object dummy argument '%s' of procedure '%s'"
1446               " must be polymorphic because '%s' is extensible"_err_en_US,
1447         passName.value(), name, typeSymbol.name());
1448     return;
1449   }
1450   for (const auto &[paramName, paramValue] : derived->parameters()) {
1451     if (paramValue.isLen() && !paramValue.isAssumed()) {
1452       messages_.Say(name,
1453           "Passed-object dummy argument '%s' of procedure '%s'"
1454           " has non-assumed length parameter '%s'"_err_en_US,
1455           passName.value(), name, paramName);
1456     }
1457   }
1458 }
1459 
1460 void CheckHelper::CheckProcBinding(
1461     const Symbol &symbol, const ProcBindingDetails &binding) {
1462   const Scope &dtScope{symbol.owner()};
1463   CHECK(dtScope.kind() == Scope::Kind::DerivedType);
1464   if (const Symbol * dtSymbol{dtScope.symbol()}) {
1465     if (symbol.attrs().test(Attr::DEFERRED)) {
1466       if (!dtSymbol->attrs().test(Attr::ABSTRACT)) { // C733
1467         SayWithDeclaration(*dtSymbol,
1468             "Procedure bound to non-ABSTRACT derived type '%s' may not be DEFERRED"_err_en_US,
1469             dtSymbol->name());
1470       }
1471       if (symbol.attrs().test(Attr::NON_OVERRIDABLE)) {
1472         messages_.Say(
1473             "Type-bound procedure '%s' may not be both DEFERRED and NON_OVERRIDABLE"_err_en_US,
1474             symbol.name());
1475       }
1476     }
1477   }
1478   if (const Symbol * overridden{FindOverriddenBinding(symbol)}) {
1479     if (overridden->attrs().test(Attr::NON_OVERRIDABLE)) {
1480       SayWithDeclaration(*overridden,
1481           "Override of NON_OVERRIDABLE '%s' is not permitted"_err_en_US,
1482           symbol.name());
1483     }
1484     if (const auto *overriddenBinding{
1485             overridden->detailsIf<ProcBindingDetails>()}) {
1486       if (!IsPureProcedure(symbol) && IsPureProcedure(*overridden)) {
1487         SayWithDeclaration(*overridden,
1488             "An overridden pure type-bound procedure binding must also be pure"_err_en_US);
1489         return;
1490       }
1491       if (!binding.symbol().attrs().test(Attr::ELEMENTAL) &&
1492           overriddenBinding->symbol().attrs().test(Attr::ELEMENTAL)) {
1493         SayWithDeclaration(*overridden,
1494             "A type-bound procedure and its override must both, or neither, be ELEMENTAL"_err_en_US);
1495         return;
1496       }
1497       bool isNopass{symbol.attrs().test(Attr::NOPASS)};
1498       if (isNopass != overridden->attrs().test(Attr::NOPASS)) {
1499         SayWithDeclaration(*overridden,
1500             isNopass
1501                 ? "A NOPASS type-bound procedure may not override a passed-argument procedure"_err_en_US
1502                 : "A passed-argument type-bound procedure may not override a NOPASS procedure"_err_en_US);
1503       } else {
1504         const auto *bindingChars{Characterize(binding.symbol())};
1505         const auto *overriddenChars{Characterize(overriddenBinding->symbol())};
1506         if (bindingChars && overriddenChars) {
1507           if (isNopass) {
1508             if (!bindingChars->CanOverride(*overriddenChars, std::nullopt)) {
1509               SayWithDeclaration(*overridden,
1510                   "A type-bound procedure and its override must have compatible interfaces"_err_en_US);
1511             }
1512           } else if (!context_.HasError(binding.symbol())) {
1513             int passIndex{bindingChars->FindPassIndex(binding.passName())};
1514             int overriddenPassIndex{
1515                 overriddenChars->FindPassIndex(overriddenBinding->passName())};
1516             if (passIndex != overriddenPassIndex) {
1517               SayWithDeclaration(*overridden,
1518                   "A type-bound procedure and its override must use the same PASS argument"_err_en_US);
1519             } else if (!bindingChars->CanOverride(
1520                            *overriddenChars, passIndex)) {
1521               SayWithDeclaration(*overridden,
1522                   "A type-bound procedure and its override must have compatible interfaces apart from their passed argument"_err_en_US);
1523             }
1524           }
1525         }
1526       }
1527       if (symbol.attrs().test(Attr::PRIVATE) &&
1528           overridden->attrs().test(Attr::PUBLIC)) {
1529         SayWithDeclaration(*overridden,
1530             "A PRIVATE procedure may not override a PUBLIC procedure"_err_en_US);
1531       }
1532     } else {
1533       SayWithDeclaration(*overridden,
1534           "A type-bound procedure binding may not have the same name as a parent component"_err_en_US);
1535     }
1536   }
1537   CheckPassArg(symbol, &binding.symbol(), binding);
1538 }
1539 
1540 void CheckHelper::Check(const Scope &scope) {
1541   scope_ = &scope;
1542   common::Restorer<const Symbol *> restorer{innermostSymbol_, innermostSymbol_};
1543   if (const Symbol * symbol{scope.symbol()}) {
1544     innermostSymbol_ = symbol;
1545   }
1546   if (scope.IsParameterizedDerivedTypeInstantiation()) {
1547     auto restorer{common::ScopedSet(scopeIsUninstantiatedPDT_, false)};
1548     auto restorer2{context_.foldingContext().messages().SetContext(
1549         scope.instantiationContext().get())};
1550     for (const auto &pair : scope) {
1551       CheckPointerInitialization(*pair.second);
1552     }
1553   } else {
1554     auto restorer{common::ScopedSet(
1555         scopeIsUninstantiatedPDT_, scope.IsParameterizedDerivedType())};
1556     for (const auto &set : scope.equivalenceSets()) {
1557       CheckEquivalenceSet(set);
1558     }
1559     for (const auto &pair : scope) {
1560       Check(*pair.second);
1561     }
1562     for (const Scope &child : scope.children()) {
1563       Check(child);
1564     }
1565     if (scope.kind() == Scope::Kind::BlockData) {
1566       CheckBlockData(scope);
1567     }
1568     CheckGenericOps(scope);
1569   }
1570 }
1571 
1572 void CheckHelper::CheckEquivalenceSet(const EquivalenceSet &set) {
1573   auto iter{
1574       std::find_if(set.begin(), set.end(), [](const EquivalenceObject &object) {
1575         return FindCommonBlockContaining(object.symbol) != nullptr;
1576       })};
1577   if (iter != set.end()) {
1578     const Symbol &commonBlock{DEREF(FindCommonBlockContaining(iter->symbol))};
1579     for (auto &object : set) {
1580       if (&object != &*iter) {
1581         if (auto *details{object.symbol.detailsIf<ObjectEntityDetails>()}) {
1582           if (details->commonBlock()) {
1583             if (details->commonBlock() != &commonBlock) { // 8.10.3 paragraph 1
1584               if (auto *msg{messages_.Say(object.symbol.name(),
1585                       "Two objects in the same EQUIVALENCE set may not be members of distinct COMMON blocks"_err_en_US)}) {
1586                 msg->Attach(iter->symbol.name(),
1587                        "Other object in EQUIVALENCE set"_en_US)
1588                     .Attach(details->commonBlock()->name(),
1589                         "COMMON block containing '%s'"_en_US,
1590                         object.symbol.name())
1591                     .Attach(commonBlock.name(),
1592                         "COMMON block containing '%s'"_en_US,
1593                         iter->symbol.name());
1594               }
1595             }
1596           } else {
1597             // Mark all symbols in the equivalence set with the same COMMON
1598             // block to prevent spurious error messages about initialization
1599             // in BLOCK DATA outside COMMON
1600             details->set_commonBlock(commonBlock);
1601           }
1602         }
1603       }
1604     }
1605   }
1606   // TODO: Move C8106 (&al.) checks here from resolve-names-utils.cpp
1607 }
1608 
1609 void CheckHelper::CheckBlockData(const Scope &scope) {
1610   // BLOCK DATA subprograms should contain only named common blocks.
1611   // C1415 presents a list of statements that shouldn't appear in
1612   // BLOCK DATA, but so long as the subprogram contains no executable
1613   // code and allocates no storage outside named COMMON, we're happy
1614   // (e.g., an ENUM is strictly not allowed).
1615   for (const auto &pair : scope) {
1616     const Symbol &symbol{*pair.second};
1617     if (!(symbol.has<CommonBlockDetails>() || symbol.has<UseDetails>() ||
1618             symbol.has<UseErrorDetails>() || symbol.has<DerivedTypeDetails>() ||
1619             symbol.has<SubprogramDetails>() ||
1620             symbol.has<ObjectEntityDetails>() ||
1621             (symbol.has<ProcEntityDetails>() &&
1622                 !symbol.attrs().test(Attr::POINTER)))) {
1623       messages_.Say(symbol.name(),
1624           "'%s' may not appear in a BLOCK DATA subprogram"_err_en_US,
1625           symbol.name());
1626     }
1627   }
1628 }
1629 
1630 // Check distinguishability of generic assignment and operators.
1631 // For these, generics and generic bindings must be considered together.
1632 void CheckHelper::CheckGenericOps(const Scope &scope) {
1633   DistinguishabilityHelper helper{context_};
1634   auto addSpecifics{[&](const Symbol &generic) {
1635     const auto *details{generic.GetUltimate().detailsIf<GenericDetails>()};
1636     if (!details) {
1637       return;
1638     }
1639     GenericKind kind{details->kind()};
1640     if (!kind.IsAssignment() && !kind.IsOperator()) {
1641       return;
1642     }
1643     const SymbolVector &specifics{details->specificProcs()};
1644     const std::vector<SourceName> &bindingNames{details->bindingNames()};
1645     for (std::size_t i{0}; i < specifics.size(); ++i) {
1646       const Symbol &specific{*specifics[i]};
1647       if (const Procedure * proc{Characterize(specific)}) {
1648         auto restorer{messages_.SetLocation(bindingNames[i])};
1649         if (kind.IsAssignment()) {
1650           if (!CheckDefinedAssignment(specific, *proc)) {
1651             continue;
1652           }
1653         } else {
1654           if (!CheckDefinedOperator(generic.name(), kind, specific, *proc)) {
1655             continue;
1656           }
1657         }
1658         helper.Add(generic, kind, specific, *proc);
1659       }
1660     }
1661   }};
1662   for (const auto &pair : scope) {
1663     const Symbol &symbol{*pair.second};
1664     addSpecifics(symbol);
1665     const Symbol &ultimate{symbol.GetUltimate()};
1666     if (ultimate.has<DerivedTypeDetails>()) {
1667       if (const Scope * typeScope{ultimate.scope()}) {
1668         for (const auto &pair2 : *typeScope) {
1669           addSpecifics(*pair2.second);
1670         }
1671       }
1672     }
1673   }
1674   helper.Check(scope);
1675 }
1676 
1677 static const std::string *DefinesBindCName(const Symbol &symbol) {
1678   const auto *subp{symbol.detailsIf<SubprogramDetails>()};
1679   if ((subp && !subp->isInterface()) || symbol.has<ObjectEntityDetails>()) {
1680     // Symbol defines data or entry point
1681     return symbol.GetBindName();
1682   } else {
1683     return nullptr;
1684   }
1685 }
1686 
1687 // Check that BIND(C) names are distinct
1688 void CheckHelper::CheckBindCName(const Symbol &symbol) {
1689   if (const std::string * name{DefinesBindCName(symbol)}) {
1690     auto pair{bindC_.emplace(*name, symbol)};
1691     if (!pair.second) {
1692       const Symbol &other{*pair.first->second};
1693       if (DefinesBindCName(other) && !context_.HasError(other)) {
1694         if (auto *msg{messages_.Say(
1695                 "Two symbols have the same BIND(C) name '%s'"_err_en_US,
1696                 *name)}) {
1697           msg->Attach(other.name(), "Conflicting symbol"_en_US);
1698         }
1699         context_.SetError(symbol);
1700         context_.SetError(other);
1701       }
1702     }
1703   }
1704 }
1705 
1706 void SubprogramMatchHelper::Check(
1707     const Symbol &symbol1, const Symbol &symbol2) {
1708   const auto details1{symbol1.get<SubprogramDetails>()};
1709   const auto details2{symbol2.get<SubprogramDetails>()};
1710   if (details1.isFunction() != details2.isFunction()) {
1711     Say(symbol1, symbol2,
1712         details1.isFunction()
1713             ? "Module function '%s' was declared as a subroutine in the"
1714               " corresponding interface body"_err_en_US
1715             : "Module subroutine '%s' was declared as a function in the"
1716               " corresponding interface body"_err_en_US);
1717     return;
1718   }
1719   const auto &args1{details1.dummyArgs()};
1720   const auto &args2{details2.dummyArgs()};
1721   int nargs1{static_cast<int>(args1.size())};
1722   int nargs2{static_cast<int>(args2.size())};
1723   if (nargs1 != nargs2) {
1724     Say(symbol1, symbol2,
1725         "Module subprogram '%s' has %d args but the corresponding interface"
1726         " body has %d"_err_en_US,
1727         nargs1, nargs2);
1728     return;
1729   }
1730   bool nonRecursive1{symbol1.attrs().test(Attr::NON_RECURSIVE)};
1731   if (nonRecursive1 != symbol2.attrs().test(Attr::NON_RECURSIVE)) { // C1551
1732     Say(symbol1, symbol2,
1733         nonRecursive1
1734             ? "Module subprogram '%s' has NON_RECURSIVE prefix but"
1735               " the corresponding interface body does not"_err_en_US
1736             : "Module subprogram '%s' does not have NON_RECURSIVE prefix but "
1737               "the corresponding interface body does"_err_en_US);
1738   }
1739   const std::string *bindName1{details1.bindName()};
1740   const std::string *bindName2{details2.bindName()};
1741   if (!bindName1 && !bindName2) {
1742     // OK - neither has a binding label
1743   } else if (!bindName1) {
1744     Say(symbol1, symbol2,
1745         "Module subprogram '%s' does not have a binding label but the"
1746         " corresponding interface body does"_err_en_US);
1747   } else if (!bindName2) {
1748     Say(symbol1, symbol2,
1749         "Module subprogram '%s' has a binding label but the"
1750         " corresponding interface body does not"_err_en_US);
1751   } else if (*bindName1 != *bindName2) {
1752     Say(symbol1, symbol2,
1753         "Module subprogram '%s' has binding label '%s' but the corresponding"
1754         " interface body has '%s'"_err_en_US,
1755         *details1.bindName(), *details2.bindName());
1756   }
1757   const Procedure *proc1{checkHelper.Characterize(symbol1)};
1758   const Procedure *proc2{checkHelper.Characterize(symbol2)};
1759   if (!proc1 || !proc2) {
1760     return;
1761   }
1762   if (proc1->functionResult && proc2->functionResult &&
1763       *proc1->functionResult != *proc2->functionResult) {
1764     Say(symbol1, symbol2,
1765         "Return type of function '%s' does not match return type of"
1766         " the corresponding interface body"_err_en_US);
1767   }
1768   for (int i{0}; i < nargs1; ++i) {
1769     const Symbol *arg1{args1[i]};
1770     const Symbol *arg2{args2[i]};
1771     if (arg1 && !arg2) {
1772       Say(symbol1, symbol2,
1773           "Dummy argument %2$d of '%1$s' is not an alternate return indicator"
1774           " but the corresponding argument in the interface body is"_err_en_US,
1775           i + 1);
1776     } else if (!arg1 && arg2) {
1777       Say(symbol1, symbol2,
1778           "Dummy argument %2$d of '%1$s' is an alternate return indicator but"
1779           " the corresponding argument in the interface body is not"_err_en_US,
1780           i + 1);
1781     } else if (arg1 && arg2) {
1782       SourceName name1{arg1->name()};
1783       SourceName name2{arg2->name()};
1784       if (name1 != name2) {
1785         Say(*arg1, *arg2,
1786             "Dummy argument name '%s' does not match corresponding name '%s'"
1787             " in interface body"_err_en_US,
1788             name2);
1789       } else {
1790         CheckDummyArg(
1791             *arg1, *arg2, proc1->dummyArguments[i], proc2->dummyArguments[i]);
1792       }
1793     }
1794   }
1795 }
1796 
1797 void SubprogramMatchHelper::CheckDummyArg(const Symbol &symbol1,
1798     const Symbol &symbol2, const DummyArgument &arg1,
1799     const DummyArgument &arg2) {
1800   std::visit(common::visitors{
1801                  [&](const DummyDataObject &obj1, const DummyDataObject &obj2) {
1802                    CheckDummyDataObject(symbol1, symbol2, obj1, obj2);
1803                  },
1804                  [&](const DummyProcedure &proc1, const DummyProcedure &proc2) {
1805                    CheckDummyProcedure(symbol1, symbol2, proc1, proc2);
1806                  },
1807                  [&](const DummyDataObject &, const auto &) {
1808                    Say(symbol1, symbol2,
1809                        "Dummy argument '%s' is a data object; the corresponding"
1810                        " argument in the interface body is not"_err_en_US);
1811                  },
1812                  [&](const DummyProcedure &, const auto &) {
1813                    Say(symbol1, symbol2,
1814                        "Dummy argument '%s' is a procedure; the corresponding"
1815                        " argument in the interface body is not"_err_en_US);
1816                  },
1817                  [&](const auto &, const auto &) {
1818                    llvm_unreachable("Dummy arguments are not data objects or"
1819                                     "procedures");
1820                  },
1821              },
1822       arg1.u, arg2.u);
1823 }
1824 
1825 void SubprogramMatchHelper::CheckDummyDataObject(const Symbol &symbol1,
1826     const Symbol &symbol2, const DummyDataObject &obj1,
1827     const DummyDataObject &obj2) {
1828   if (!CheckSameIntent(symbol1, symbol2, obj1.intent, obj2.intent)) {
1829   } else if (!CheckSameAttrs(symbol1, symbol2, obj1.attrs, obj2.attrs)) {
1830   } else if (obj1.type.type() != obj2.type.type()) {
1831     Say(symbol1, symbol2,
1832         "Dummy argument '%s' has type %s; the corresponding argument in the"
1833         " interface body has type %s"_err_en_US,
1834         obj1.type.type().AsFortran(), obj2.type.type().AsFortran());
1835   } else if (!ShapesAreCompatible(obj1, obj2)) {
1836     Say(symbol1, symbol2,
1837         "The shape of dummy argument '%s' does not match the shape of the"
1838         " corresponding argument in the interface body"_err_en_US);
1839   }
1840   // TODO: coshape
1841 }
1842 
1843 void SubprogramMatchHelper::CheckDummyProcedure(const Symbol &symbol1,
1844     const Symbol &symbol2, const DummyProcedure &proc1,
1845     const DummyProcedure &proc2) {
1846   if (!CheckSameIntent(symbol1, symbol2, proc1.intent, proc2.intent)) {
1847   } else if (!CheckSameAttrs(symbol1, symbol2, proc1.attrs, proc2.attrs)) {
1848   } else if (proc1 != proc2) {
1849     Say(symbol1, symbol2,
1850         "Dummy procedure '%s' does not match the corresponding argument in"
1851         " the interface body"_err_en_US);
1852   }
1853 }
1854 
1855 bool SubprogramMatchHelper::CheckSameIntent(const Symbol &symbol1,
1856     const Symbol &symbol2, common::Intent intent1, common::Intent intent2) {
1857   if (intent1 == intent2) {
1858     return true;
1859   } else {
1860     Say(symbol1, symbol2,
1861         "The intent of dummy argument '%s' does not match the intent"
1862         " of the corresponding argument in the interface body"_err_en_US);
1863     return false;
1864   }
1865 }
1866 
1867 // Report an error referring to first symbol with declaration of second symbol
1868 template <typename... A>
1869 void SubprogramMatchHelper::Say(const Symbol &symbol1, const Symbol &symbol2,
1870     parser::MessageFixedText &&text, A &&...args) {
1871   auto &message{context().Say(symbol1.name(), std::move(text), symbol1.name(),
1872       std::forward<A>(args)...)};
1873   evaluate::AttachDeclaration(message, symbol2);
1874 }
1875 
1876 template <typename ATTRS>
1877 bool SubprogramMatchHelper::CheckSameAttrs(
1878     const Symbol &symbol1, const Symbol &symbol2, ATTRS attrs1, ATTRS attrs2) {
1879   if (attrs1 == attrs2) {
1880     return true;
1881   }
1882   attrs1.IterateOverMembers([&](auto attr) {
1883     if (!attrs2.test(attr)) {
1884       Say(symbol1, symbol2,
1885           "Dummy argument '%s' has the %s attribute; the corresponding"
1886           " argument in the interface body does not"_err_en_US,
1887           AsFortran(attr));
1888     }
1889   });
1890   attrs2.IterateOverMembers([&](auto attr) {
1891     if (!attrs1.test(attr)) {
1892       Say(symbol1, symbol2,
1893           "Dummy argument '%s' does not have the %s attribute; the"
1894           " corresponding argument in the interface body does"_err_en_US,
1895           AsFortran(attr));
1896     }
1897   });
1898   return false;
1899 }
1900 
1901 bool SubprogramMatchHelper::ShapesAreCompatible(
1902     const DummyDataObject &obj1, const DummyDataObject &obj2) {
1903   return characteristics::ShapesAreCompatible(
1904       FoldShape(obj1.type.shape()), FoldShape(obj2.type.shape()));
1905 }
1906 
1907 evaluate::Shape SubprogramMatchHelper::FoldShape(const evaluate::Shape &shape) {
1908   evaluate::Shape result;
1909   for (const auto &extent : shape) {
1910     result.emplace_back(
1911         evaluate::Fold(context().foldingContext(), common::Clone(extent)));
1912   }
1913   return result;
1914 }
1915 
1916 void DistinguishabilityHelper::Add(const Symbol &generic, GenericKind kind,
1917     const Symbol &specific, const Procedure &procedure) {
1918   if (!context_.HasError(specific)) {
1919     nameToInfo_[generic.name()].emplace_back(
1920         ProcedureInfo{kind, specific, procedure});
1921   }
1922 }
1923 
1924 void DistinguishabilityHelper::Check(const Scope &scope) {
1925   for (const auto &[name, info] : nameToInfo_) {
1926     auto count{info.size()};
1927     for (std::size_t i1{0}; i1 < count - 1; ++i1) {
1928       const auto &[kind1, symbol1, proc1] = info[i1];
1929       for (std::size_t i2{i1 + 1}; i2 < count; ++i2) {
1930         const auto &[kind2, symbol2, proc2] = info[i2];
1931         auto distinguishable{kind1.IsName()
1932                 ? evaluate::characteristics::Distinguishable
1933                 : evaluate::characteristics::DistinguishableOpOrAssign};
1934         if (!distinguishable(proc1, proc2)) {
1935           SayNotDistinguishable(
1936               GetTopLevelUnitContaining(scope), name, kind1, symbol1, symbol2);
1937         }
1938       }
1939     }
1940   }
1941 }
1942 
1943 void DistinguishabilityHelper::SayNotDistinguishable(const Scope &scope,
1944     const SourceName &name, GenericKind kind, const Symbol &proc1,
1945     const Symbol &proc2) {
1946   std::string name1{proc1.name().ToString()};
1947   std::string name2{proc2.name().ToString()};
1948   if (kind.IsOperator() || kind.IsAssignment()) {
1949     // proc1 and proc2 may come from different scopes so qualify their names
1950     if (proc1.owner().IsDerivedType()) {
1951       name1 = proc1.owner().GetName()->ToString() + '%' + name1;
1952     }
1953     if (proc2.owner().IsDerivedType()) {
1954       name2 = proc2.owner().GetName()->ToString() + '%' + name2;
1955     }
1956   }
1957   parser::Message *msg;
1958   if (scope.sourceRange().Contains(name)) {
1959     msg = &context_.Say(name,
1960         "Generic '%s' may not have specific procedures '%s' and"
1961         " '%s' as their interfaces are not distinguishable"_err_en_US,
1962         MakeOpName(name), name1, name2);
1963   } else {
1964     msg = &context_.Say(*GetTopLevelUnitContaining(proc1).GetName(),
1965         "USE-associated generic '%s' may not have specific procedures '%s' and"
1966         " '%s' as their interfaces are not distinguishable"_err_en_US,
1967         MakeOpName(name), name1, name2);
1968   }
1969   AttachDeclaration(*msg, scope, proc1);
1970   AttachDeclaration(*msg, scope, proc2);
1971 }
1972 
1973 // `evaluate::AttachDeclaration` doesn't handle the generic case where `proc`
1974 // comes from a different module but is not necessarily use-associated.
1975 void DistinguishabilityHelper::AttachDeclaration(
1976     parser::Message &msg, const Scope &scope, const Symbol &proc) {
1977   const Scope &unit{GetTopLevelUnitContaining(proc)};
1978   if (unit == scope) {
1979     evaluate::AttachDeclaration(msg, proc);
1980   } else {
1981     msg.Attach(unit.GetName().value(),
1982         "'%s' is USE-associated from module '%s'"_en_US, proc.name(),
1983         unit.GetName().value());
1984   }
1985 }
1986 
1987 void CheckDeclarations(SemanticsContext &context) {
1988   CheckHelper{context}.Check();
1989 }
1990 } // namespace Fortran::semantics
1991