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