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