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