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