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