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