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