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