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 "definable.h"
13#include "pointer-assignment.h"
14#include "flang/Evaluate/check-expression.h"
15#include "flang/Evaluate/fold.h"
16#include "flang/Evaluate/tools.h"
17#include "flang/Parser/characters.h"
18#include "flang/Semantics/scope.h"
19#include "flang/Semantics/semantics.h"
20#include "flang/Semantics/symbol.h"
21#include "flang/Semantics/tools.h"
22#include "flang/Semantics/type.h"
23#include <algorithm>
24#include <map>
25#include <string>
26
27namespace Fortran::semantics {
28
29namespace characteristics = evaluate::characteristics;
30using characteristics::DummyArgument;
31using characteristics::DummyDataObject;
32using characteristics::DummyProcedure;
33using characteristics::FunctionResult;
34using characteristics::Procedure;
35
36class DistinguishabilityHelper;
37
38class CheckHelper {
39public:
40 explicit CheckHelper(SemanticsContext &c) : context_{c} {}
41
42 SemanticsContext &context() { return context_; }
43 void Check() { Check(context_.globalScope()); }
44 void Check(const ParamValue &, bool canBeAssumed);
45 void Check(const Bound &bound) {
46 CheckSpecExpr(bound.GetExplicit(), /*forElementalFunctionResult=*/false);
47 }
48 void Check(const ShapeSpec &spec) {
49 Check(spec.lbound());
50 Check(spec.ubound());
51 }
52 void Check(const ArraySpec &);
53 void Check(const DeclTypeSpec &, bool canHaveAssumedTypeParameters);
54 void Check(const Symbol &);
55 void CheckCommonBlock(const Symbol &);
56 void Check(const Scope &);
57 const Procedure *Characterize(const Symbol &);
58
59private:
60 template <typename A>
61 void CheckSpecExpr(const A &x, bool forElementalFunctionResult) {
62 evaluate::CheckSpecificationExpr(
63 x, DEREF(scope_), foldingContext_, forElementalFunctionResult);
64 }
65 void CheckValue(const Symbol &, const DerivedTypeSpec *);
66 void CheckVolatile(const Symbol &, const DerivedTypeSpec *);
67 void CheckContiguous(const Symbol &);
68 void CheckPointer(const Symbol &);
69 void CheckPassArg(
70 const Symbol &proc, const Symbol *interface, const WithPassArg &);
71 void CheckProcBinding(const Symbol &, const ProcBindingDetails &);
72 void CheckObjectEntity(const Symbol &, const ObjectEntityDetails &);
73 void CheckPointerInitialization(const Symbol &);
74 void CheckArraySpec(const Symbol &, const ArraySpec &);
75 void CheckProcEntity(const Symbol &, const ProcEntityDetails &);
76 void CheckSubprogram(const Symbol &, const SubprogramDetails &);
77 void CheckExternal(const Symbol &);
78 void CheckAssumedTypeEntity(const Symbol &, const ObjectEntityDetails &);
79 void CheckDerivedType(const Symbol &, const DerivedTypeDetails &);
80 bool CheckFinal(
81 const Symbol &subroutine, SourceName, const Symbol &derivedType);
82 bool CheckDistinguishableFinals(const Symbol &f1, SourceName f1name,
83 const Symbol &f2, SourceName f2name, const Symbol &derivedType);
84 void CheckGeneric(const Symbol &, const GenericDetails &);
85 void CheckHostAssoc(const Symbol &, const HostAssocDetails &);
86 bool CheckDefinedOperator(
87 SourceName, GenericKind, const Symbol &, const Procedure &);
88 std::optional<parser::MessageFixedText> CheckNumberOfArgs(
89 const GenericKind &, std::size_t);
90 bool CheckDefinedOperatorArg(
91 const SourceName &, const Symbol &, const Procedure &, std::size_t);
92 bool CheckDefinedAssignment(const Symbol &, const Procedure &);
93 bool CheckDefinedAssignmentArg(const Symbol &, const DummyArgument &, int);
94 void CollectSpecifics(
95 DistinguishabilityHelper &, const Symbol &, const GenericDetails &);
96 void CheckSpecifics(const Symbol &, const GenericDetails &);
97 void CheckEquivalenceSet(const EquivalenceSet &);
98 void CheckEquivalenceObject(const EquivalenceObject &);
99 void CheckBlockData(const Scope &);
100 void CheckGenericOps(const Scope &);
101 bool CheckConflicting(const Symbol &, Attr, Attr);
102 void WarnMissingFinal(const Symbol &);
103 void CheckSymbolType(const Symbol &); // C702
104 bool InPure() const {
105 return innermostSymbol_ && IsPureProcedure(*innermostSymbol_);
106 }
107 bool InElemental() const {
108 return innermostSymbol_ && IsElementalProcedure(*innermostSymbol_);
109 }
110 bool InFunction() const {
111 return innermostSymbol_ && IsFunction(*innermostSymbol_);
112 }
113 bool InInterface() const {
114 const SubprogramDetails *subp{innermostSymbol_
115 ? innermostSymbol_->detailsIf<SubprogramDetails>()
116 : nullptr};
117 return subp && subp->isInterface();
118 }
119 template <typename... A>
120 parser::Message *SayWithDeclaration(const Symbol &symbol, A &&...x) {
121 parser::Message *msg{messages_.Say(std::forward<A>(x)...)};
122 if (msg && messages_.at().begin() != symbol.name().begin()) {
123 evaluate::AttachDeclaration(*msg, symbol);
124 }
125 return msg;
126 }
127 bool InModuleFile() const {
128 return FindModuleFileContaining(context_.FindScope(messages_.at())) !=
129 nullptr;
130 }
131 template <typename FeatureOrUsageWarning, typename... A>
132 parser::Message *Warn(FeatureOrUsageWarning warning, A &&...x) {
133 if (!context_.ShouldWarn(warning) || InModuleFile()) {
134 return nullptr;
135 } else {
136 return messages_.Say(warning, std::forward<A>(x)...);
137 }
138 }
139 template <typename FeatureOrUsageWarning, typename... A>
140 parser::Message *Warn(
141 FeatureOrUsageWarning warning, parser::CharBlock source, A &&...x) {
142 if (!context_.ShouldWarn(warning) ||
143 FindModuleFileContaining(context_.FindScope(source))) {
144 return nullptr;
145 } else {
146 return messages_.Say(warning, source, std::forward<A>(x)...);
147 }
148 }
149 bool IsResultOkToDiffer(const FunctionResult &);
150 void CheckGlobalName(const Symbol &);
151 void CheckProcedureAssemblyName(const Symbol &symbol);
152 void CheckExplicitSave(const Symbol &);
153 parser::Messages WhyNotInteroperableDerivedType(const Symbol &);
154 parser::Messages WhyNotInteroperableObject(
155 const Symbol &, bool allowNonInteroperableType = false);
156 parser::Messages WhyNotInteroperableFunctionResult(const Symbol &);
157 parser::Messages WhyNotInteroperableProcedure(const Symbol &, bool isError);
158 void CheckBindC(const Symbol &);
159 // Check functions for defined I/O procedures
160 void CheckDefinedIoProc(
161 const Symbol &, const GenericDetails &, common::DefinedIo);
162 bool CheckDioDummyIsData(const Symbol &, const Symbol *, std::size_t);
163 void CheckDioDummyIsDerived(
164 const Symbol &, const Symbol &, common::DefinedIo ioKind, const Symbol &);
165 void CheckDioDummyIsDefaultInteger(const Symbol &, const Symbol &);
166 void CheckDioDummyIsScalar(const Symbol &, const Symbol &);
167 void CheckDioDummyAttrs(const Symbol &, const Symbol &, Attr);
168 void CheckDioDtvArg(const Symbol &proc, const Symbol &subp, const Symbol *arg,
169 common::DefinedIo, const Symbol &generic);
170 void CheckGenericVsIntrinsic(const Symbol &, const GenericDetails &);
171 void CheckDefaultIntegerArg(const Symbol &, const Symbol *, Attr);
172 void CheckDioAssumedLenCharacterArg(
173 const Symbol &, const Symbol *, std::size_t, Attr);
174 void CheckDioVlistArg(const Symbol &, const Symbol *, std::size_t);
175 void CheckDioArgCount(const Symbol &, common::DefinedIo ioKind, std::size_t);
176 struct TypeWithDefinedIo {
177 const DerivedTypeSpec &type;
178 common::DefinedIo ioKind;
179 const Symbol &proc;
180 const Symbol &generic;
181 };
182 void CheckAlreadySeenDefinedIo(const DerivedTypeSpec &, common::DefinedIo,
183 const Symbol &, const Symbol &generic);
184 void CheckModuleProcedureDef(const Symbol &);
185
186 SemanticsContext &context_;
187 evaluate::FoldingContext &foldingContext_{context_.foldingContext()};
188 parser::ContextualMessages &messages_{foldingContext_.messages()};
189 const Scope *scope_{nullptr};
190 bool scopeIsUninstantiatedPDT_{false};
191 // This symbol is the one attached to the innermost enclosing scope
192 // that has a symbol.
193 const Symbol *innermostSymbol_{nullptr};
194 // Cache of calls to Procedure::Characterize(Symbol)
195 std::map<SymbolRef, std::optional<Procedure>, SymbolAddressCompare>
196 characterizeCache_;
197 // Collection of module procedure symbols with non-BIND(C)
198 // global names, qualified by their module.
199 std::map<std::pair<SourceName, const Symbol *>, SymbolRef> moduleProcs_;
200 // Collection of symbols with global names, BIND(C) or otherwise
201 std::map<std::string, SymbolRef> globalNames_;
202 // Collection of external procedures without global definitions
203 std::map<std::string, SymbolRef> externalNames_;
204 // Collection of target dependent assembly names of external and BIND(C)
205 // procedures.
206 std::map<std::string, SymbolRef> procedureAssemblyNames_;
207 // Derived types that have been examined by WhyNotInteroperable_XXX
208 UnorderedSymbolSet examinedByWhyNotInteroperable_;
209};
210
211class DistinguishabilityHelper {
212public:
213 DistinguishabilityHelper(SemanticsContext &context) : context_{context} {}
214 void Add(const Symbol &, GenericKind, const Symbol &, const Procedure &);
215 void Check(const Scope &);
216
217private:
218 void SayNotDistinguishable(const Scope &, const SourceName &, GenericKind,
219 const Symbol &, const Symbol &, bool isHardConflict);
220 void AttachDeclaration(parser::Message &, const Scope &, const Symbol &);
221
222 SemanticsContext &context_;
223 struct ProcedureInfo {
224 GenericKind kind;
225 const Procedure &procedure;
226 };
227 std::map<SourceName, std::map<const Symbol *, ProcedureInfo>>
228 nameToSpecifics_;
229};
230
231void CheckHelper::Check(const ParamValue &value, bool canBeAssumed) {
232 if (value.isAssumed()) {
233 if (!canBeAssumed) { // C795, C721, C726
234 messages_.Say(
235 "An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, character named constant, or external function result"_err_en_US);
236 }
237 } else {
238 CheckSpecExpr(value.GetExplicit(), /*forElementalFunctionResult=*/false);
239 }
240}
241
242void CheckHelper::Check(const ArraySpec &shape) {
243 for (const auto &spec : shape) {
244 Check(spec);
245 }
246}
247
248void CheckHelper::Check(
249 const DeclTypeSpec &type, bool canHaveAssumedTypeParameters) {
250 if (type.category() == DeclTypeSpec::Character) {
251 Check(type.characterTypeSpec().length(), canHaveAssumedTypeParameters);
252 } else if (const DerivedTypeSpec *derived{type.AsDerived()}) {
253 for (auto &parm : derived->parameters()) {
254 Check(parm.second, canHaveAssumedTypeParameters);
255 }
256 }
257}
258
259static bool IsBlockData(const Scope &scope) {
260 return scope.kind() == Scope::Kind::BlockData;
261}
262
263static bool IsBlockData(const Symbol &symbol) {
264 return symbol.scope() && IsBlockData(*symbol.scope());
265}
266
267void CheckHelper::Check(const Symbol &symbol) {
268 if (symbol.has<UseErrorDetails>()) {
269 return;
270 }
271 if (symbol.name().size() > common::maxNameLen &&
272 &symbol == &symbol.GetUltimate()) {
273 Warn(common::LanguageFeature::LongNames, symbol.name(),
274 "%s has length %d, which is greater than the maximum name length %d"_port_en_US,
275 symbol.name(), symbol.name().size(), common::maxNameLen);
276 }
277 if (context_.HasError(symbol)) {
278 return;
279 }
280 auto restorer{messages_.SetLocation(symbol.name())};
281 context_.set_location(symbol.name());
282 const DeclTypeSpec *type{symbol.GetType()};
283 const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
284 bool isDone{false};
285 common::visit(
286 common::visitors{
287 [&](const UseDetails &x) { isDone = true; },
288 [&](const HostAssocDetails &x) {
289 CheckHostAssoc(symbol, x);
290 isDone = true;
291 },
292 [&](const ProcBindingDetails &x) {
293 CheckProcBinding(symbol, x);
294 isDone = true;
295 },
296 [&](const ObjectEntityDetails &x) { CheckObjectEntity(symbol, x); },
297 [&](const ProcEntityDetails &x) { CheckProcEntity(symbol, x); },
298 [&](const SubprogramDetails &x) { CheckSubprogram(symbol, x); },
299 [&](const DerivedTypeDetails &x) { CheckDerivedType(symbol, x); },
300 [&](const GenericDetails &x) { CheckGeneric(symbol, x); },
301 [](const auto &) {},
302 },
303 symbol.details());
304 if (symbol.attrs().test(Attr::VOLATILE)) {
305 CheckVolatile(symbol, derived);
306 }
307 if (symbol.attrs().test(Attr::BIND_C)) {
308 CheckBindC(symbol);
309 }
310 if (symbol.attrs().test(Attr::SAVE) &&
311 !symbol.implicitAttrs().test(Attr::SAVE)) {
312 CheckExplicitSave(symbol);
313 }
314 if (symbol.attrs().test(Attr::CONTIGUOUS)) {
315 CheckContiguous(symbol);
316 }
317 CheckGlobalName(symbol);
318 CheckProcedureAssemblyName(symbol);
319 if (symbol.attrs().test(Attr::ASYNCHRONOUS) &&
320 !evaluate::IsVariable(symbol)) {
321 messages_.Say(
322 "An entity may not have the ASYNCHRONOUS attribute unless it is a variable"_err_en_US);
323 }
324 if (symbol.attrs().HasAny({Attr::INTENT_IN, Attr::INTENT_INOUT,
325 Attr::INTENT_OUT, Attr::OPTIONAL, Attr::VALUE}) &&
326 !IsDummy(symbol)) {
327 if (context_.IsEnabled(
328 common::LanguageFeature::IgnoreIrrelevantAttributes)) {
329 context_.Warn(common::LanguageFeature::IgnoreIrrelevantAttributes,
330 "Only a dummy argument should have an INTENT, VALUE, or OPTIONAL attribute"_warn_en_US);
331 } else {
332 messages_.Say(
333 "Only a dummy argument may have an INTENT, VALUE, or OPTIONAL attribute"_err_en_US);
334 }
335 } else if (symbol.attrs().test(Attr::VALUE)) {
336 CheckValue(symbol, derived);
337 }
338
339 if (isDone) {
340 return; // following checks do not apply
341 }
342
343 if (symbol.attrs().test(Attr::PROTECTED)) {
344 if (symbol.owner().kind() != Scope::Kind::Module) { // C854
345 messages_.Say(
346 "A PROTECTED entity must be in the specification part of a module"_err_en_US);
347 }
348 if (!evaluate::IsVariable(symbol) && !IsProcedurePointer(symbol)) { // C855
349 messages_.Say(
350 "A PROTECTED entity must be a variable or pointer"_err_en_US);
351 }
352 if (FindCommonBlockContaining(symbol)) { // C856
353 messages_.Say(
354 "A PROTECTED entity may not be in a common block"_err_en_US);
355 }
356 }
357 if (IsPointer(symbol)) {
358 CheckPointer(symbol);
359 }
360 if (InPure()) {
361 if (InInterface()) {
362 // Declarations in interface definitions "have no effect" if they
363 // are not pertinent to the characteristics of the procedure.
364 // Restrictions on entities in pure procedure interfaces don't need
365 // enforcement.
366 } else if (symbol.has<AssocEntityDetails>() ||
367 FindCommonBlockContaining(symbol)) {
368 // can look like they have SAVE but are fine in PURE
369 } else if (IsSaved(symbol)) {
370 if (IsInitialized(symbol)) {
371 messages_.Say(
372 "A pure subprogram may not initialize a variable"_err_en_US);
373 } else {
374 messages_.Say(
375 "A pure subprogram may not have a variable with the SAVE attribute"_err_en_US);
376 }
377 }
378 if (symbol.attrs().test(Attr::VOLATILE) &&
379 (IsDummy(symbol) || !InInterface())) {
380 messages_.Say(
381 "A pure subprogram may not have a variable with the VOLATILE attribute"_err_en_US);
382 }
383 if (innermostSymbol_ && innermostSymbol_->name() == "__builtin_c_funloc") {
384 // The intrinsic procedure C_FUNLOC() gets a pass on this check.
385 } else if (IsProcedure(symbol) && !IsPureProcedure(symbol) &&
386 IsDummy(symbol)) {
387 messages_.Say(
388 "A dummy procedure of a pure subprogram must be pure"_err_en_US);
389 }
390 }
391 const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
392 if (type) { // Section 7.2, paragraph 7; C795
393 bool isChar{type->category() == DeclTypeSpec::Character};
394 bool canHaveAssumedParameter{(isChar && IsNamedConstant(symbol)) ||
395 (IsAssumedLengthCharacter(symbol) && // C722
396 (IsExternal(symbol) ||
397 ClassifyProcedure(symbol) ==
398 ProcedureDefinitionClass::Dummy)) ||
399 symbol.test(Symbol::Flag::ParentComp)};
400 if (!IsStmtFunctionDummy(symbol)) { // C726
401 if (object) {
402 canHaveAssumedParameter |= object->isDummy() ||
403 (isChar && object->isFuncResult()) ||
404 IsStmtFunctionResult(symbol); // Avoids multiple messages
405 } else {
406 canHaveAssumedParameter |= symbol.has<AssocEntityDetails>();
407 }
408 }
409 if (IsProcedurePointer(symbol) && symbol.HasExplicitInterface()) {
410 // Don't check function result types here
411 } else {
412 Check(*type, canHaveAssumedParameter);
413 }
414 if (InFunction() && IsFunctionResult(symbol)) {
415 if (InPure()) {
416 if (type->IsPolymorphic() && IsAllocatable(symbol)) { // C1585
417 messages_.Say(
418 "Result of pure function may not be both polymorphic and ALLOCATABLE"_err_en_US);
419 }
420 if (derived) {
421 // These cases would be caught be the general validation of local
422 // variables in a pure context, but these messages are more specific.
423 if (HasImpureFinal(symbol)) { // C1584
424 messages_.Say(
425 "Result of pure function may not have an impure FINAL subroutine"_err_en_US);
426 }
427 if (auto bad{
428 FindPolymorphicAllocatablePotentialComponent(*derived)}) {
429 SayWithDeclaration(*bad,
430 "Result of pure function may not have polymorphic ALLOCATABLE potential component '%s'"_err_en_US,
431 bad.BuildResultDesignatorName());
432 }
433 }
434 }
435 if (InElemental() && isChar) { // F'2023 C15121
436 CheckSpecExpr(type->characterTypeSpec().length().GetExplicit(),
437 /*forElementalFunctionResult=*/true);
438 // TODO: check PDT LEN parameters
439 }
440 }
441 }
442 if (IsAssumedLengthCharacter(symbol) && IsFunction(symbol)) { // C723
443 if (symbol.attrs().test(Attr::RECURSIVE)) {
444 messages_.Say(
445 "An assumed-length CHARACTER(*) function cannot be RECURSIVE"_err_en_US);
446 }
447 if (symbol.Rank() > 0) {
448 messages_.Say(
449 "An assumed-length CHARACTER(*) function cannot return an array"_err_en_US);
450 }
451 if (!IsStmtFunction(symbol)) {
452 if (IsElementalProcedure(symbol)) {
453 messages_.Say(
454 "An assumed-length CHARACTER(*) function cannot be ELEMENTAL"_err_en_US);
455 } else if (IsPureProcedure(symbol)) {
456 messages_.Say(
457 "An assumed-length CHARACTER(*) function cannot be PURE"_err_en_US);
458 }
459 }
460 if (const Symbol *result{FindFunctionResult(symbol)}) {
461 if (IsPointer(*result)) {
462 messages_.Say(
463 "An assumed-length CHARACTER(*) function cannot return a POINTER"_err_en_US);
464 }
465 }
466 if (IsProcedurePointer(symbol) && IsDummy(symbol)) {
467 Warn(common::UsageWarning::Portability,
468 "A dummy procedure pointer should not have assumed-length CHARACTER(*) result type"_port_en_US);
469 // The non-dummy case is a hard error that's caught elsewhere.
470 }
471 }
472 if (IsDummy(symbol)) {
473 if (IsNamedConstant(symbol)) {
474 messages_.Say(
475 "A dummy argument may not also be a named constant"_err_en_US);
476 }
477 } else if (IsFunctionResult(symbol)) {
478 if (IsNamedConstant(symbol)) {
479 messages_.Say(
480 "A function result may not also be a named constant"_err_en_US);
481 }
482 }
483 if (IsAutomatic(symbol)) {
484 if (const Symbol * common{FindCommonBlockContaining(symbol)}) {
485 messages_.Say(
486 "Automatic data object '%s' may not appear in COMMON block /%s/"_err_en_US,
487 symbol.name(), common->name());
488 } else if (symbol.owner().IsModule()) {
489 messages_.Say(
490 "Automatic data object '%s' may not appear in a module"_err_en_US,
491 symbol.name());
492 } else if (IsBlockData(symbol.owner())) {
493 messages_.Say(
494 "Automatic data object '%s' may not appear in a BLOCK DATA subprogram"_err_en_US,
495 symbol.name());
496 } else if (symbol.owner().kind() == Scope::Kind::MainProgram) {
497 if (context_.IsEnabled(common::LanguageFeature::AutomaticInMainProgram)) {
498 Warn(common::LanguageFeature::AutomaticInMainProgram,
499 "Automatic data object '%s' should not appear in the specification part of a main program"_port_en_US,
500 symbol.name());
501 } else {
502 messages_.Say(
503 "Automatic data object '%s' may not appear in the specification part of a main program"_err_en_US,
504 symbol.name());
505 }
506 }
507 }
508 if (IsProcedure(symbol)) {
509 if (IsAllocatable(symbol)) {
510 messages_.Say(
511 "Procedure '%s' may not be ALLOCATABLE"_err_en_US, symbol.name());
512 }
513 if (!symbol.HasExplicitInterface() && symbol.Rank() > 0) {
514 messages_.Say(
515 "Procedure '%s' may not be an array without an explicit interface"_err_en_US,
516 symbol.name());
517 }
518 }
519}
520
521void CheckHelper::CheckCommonBlock(const Symbol &symbol) {
522 CheckGlobalName(symbol);
523 if (symbol.attrs().test(Attr::BIND_C)) {
524 CheckBindC(symbol);
525 }
526 for (MutableSymbolRef ref : symbol.get<CommonBlockDetails>().objects()) {
527 if (ref->test(Symbol::Flag::CrayPointee)) {
528 messages_.Say(ref->name(),
529 "Cray pointee '%s' may not be a member of a COMMON block"_err_en_US,
530 ref->name());
531 }
532 }
533}
534
535// C859, C860
536void CheckHelper::CheckExplicitSave(const Symbol &symbol) {
537 const Symbol &ultimate{symbol.GetUltimate()};
538 if (ultimate.test(Symbol::Flag::InDataStmt)) {
539 // checked elsewhere
540 } else if (symbol.has<UseDetails>()) {
541 messages_.Say(
542 "The USE-associated name '%s' may not have an explicit SAVE attribute"_err_en_US,
543 symbol.name());
544 } else if (IsDummy(ultimate)) {
545 messages_.Say(
546 "The dummy argument '%s' may not have an explicit SAVE attribute"_err_en_US,
547 symbol.name());
548 } else if (IsFunctionResult(ultimate)) {
549 messages_.Say(
550 "The function result variable '%s' may not have an explicit SAVE attribute"_err_en_US,
551 symbol.name());
552 } else if (const Symbol * common{FindCommonBlockContaining(ultimate)}) {
553 messages_.Say(
554 "The entity '%s' in COMMON block /%s/ may not have an explicit SAVE attribute"_err_en_US,
555 symbol.name(), common->name());
556 } else if (IsAutomatic(ultimate)) {
557 messages_.Say(
558 "The automatic object '%s' may not have an explicit SAVE attribute"_err_en_US,
559 symbol.name());
560 } else if (!evaluate::IsVariable(ultimate) && !IsProcedurePointer(ultimate)) {
561 messages_.Say(
562 "The entity '%s' with an explicit SAVE attribute must be a variable, procedure pointer, or COMMON block"_err_en_US,
563 symbol.name());
564 }
565}
566
567void CheckHelper::CheckValue(
568 const Symbol &symbol, const DerivedTypeSpec *derived) { // C863 - C865
569 if (IsProcedure(symbol)) {
570 messages_.Say(
571 "VALUE attribute may apply only to a dummy data object"_err_en_US);
572 return; // don't pile on
573 }
574 if (IsAssumedSizeArray(symbol)) {
575 messages_.Say(
576 "VALUE attribute may not apply to an assumed-size array"_err_en_US);
577 }
578 if (evaluate::IsCoarray(symbol)) {
579 messages_.Say("VALUE attribute may not apply to a coarray"_err_en_US);
580 }
581 if (IsAllocatable(symbol)) {
582 messages_.Say("VALUE attribute may not apply to an ALLOCATABLE"_err_en_US);
583 } else if (IsPointer(symbol)) {
584 messages_.Say("VALUE attribute may not apply to a POINTER"_err_en_US);
585 }
586 if (IsIntentInOut(symbol)) {
587 messages_.Say(
588 "VALUE attribute may not apply to an INTENT(IN OUT) argument"_err_en_US);
589 } else if (IsIntentOut(symbol)) {
590 messages_.Say(
591 "VALUE attribute may not apply to an INTENT(OUT) argument"_err_en_US);
592 }
593 if (symbol.attrs().test(Attr::VOLATILE)) {
594 messages_.Say("VALUE attribute may not apply to a VOLATILE"_err_en_US);
595 }
596 if (innermostSymbol_ && IsBindCProcedure(*innermostSymbol_)) {
597 if (IsOptional(symbol)) {
598 messages_.Say(
599 "VALUE attribute may not apply to an OPTIONAL in a BIND(C) procedure"_err_en_US);
600 }
601 if (symbol.Rank() > 0) {
602 messages_.Say(
603 "VALUE attribute may not apply to an array in a BIND(C) procedure"_err_en_US);
604 }
605 }
606 if (derived) {
607 if (FindCoarrayUltimateComponent(*derived)) {
608 messages_.Say(
609 "VALUE attribute may not apply to a type with a coarray ultimate component"_err_en_US);
610 }
611 }
612 if (evaluate::IsAssumedRank(symbol)) {
613 messages_.Say(
614 "VALUE attribute may not apply to an assumed-rank array"_err_en_US);
615 }
616 if (IsAssumedLengthCharacter(symbol)) {
617 // F'2008 feature not widely implemented
618 Warn(common::UsageWarning::Portability,
619 "VALUE attribute on assumed-length CHARACTER may not be portable"_port_en_US);
620 }
621}
622
623void CheckHelper::CheckAssumedTypeEntity( // C709
624 const Symbol &symbol, const ObjectEntityDetails &details) {
625 if (const DeclTypeSpec *type{symbol.GetType()};
626 type && type->category() == DeclTypeSpec::TypeStar) {
627 if (!IsDummy(symbol)) {
628 messages_.Say(
629 "Assumed-type entity '%s' must be a dummy argument"_err_en_US,
630 symbol.name());
631 } else {
632 if (symbol.attrs().test(Attr::ALLOCATABLE)) {
633 messages_.Say("Assumed-type argument '%s' cannot have the ALLOCATABLE"
634 " attribute"_err_en_US,
635 symbol.name());
636 }
637 if (symbol.attrs().test(Attr::POINTER)) {
638 messages_.Say("Assumed-type argument '%s' cannot have the POINTER"
639 " attribute"_err_en_US,
640 symbol.name());
641 }
642 if (symbol.attrs().test(Attr::VALUE)) {
643 messages_.Say("Assumed-type argument '%s' cannot have the VALUE"
644 " attribute"_err_en_US,
645 symbol.name());
646 }
647 if (symbol.attrs().test(Attr::INTENT_OUT)) {
648 messages_.Say(
649 "Assumed-type argument '%s' cannot be INTENT(OUT)"_err_en_US,
650 symbol.name());
651 }
652 if (evaluate::IsCoarray(symbol)) {
653 messages_.Say(
654 "Assumed-type argument '%s' cannot be a coarray"_err_en_US,
655 symbol.name());
656 }
657 if (details.IsArray() && details.shape().IsExplicitShape()) {
658 messages_.Say("Assumed-type array argument '%s' must be assumed shape,"
659 " assumed size, or assumed rank"_err_en_US,
660 symbol.name());
661 }
662 }
663 }
664}
665
666void CheckHelper::CheckObjectEntity(
667 const Symbol &symbol, const ObjectEntityDetails &details) {
668 CheckSymbolType(symbol);
669 CheckArraySpec(symbol, details.shape());
670 CheckConflicting(symbol, Attr::ALLOCATABLE, Attr::PARAMETER);
671 CheckConflicting(symbol, Attr::ASYNCHRONOUS, Attr::PARAMETER);
672 CheckConflicting(symbol, Attr::SAVE, Attr::PARAMETER);
673 CheckConflicting(symbol, Attr::TARGET, Attr::PARAMETER);
674 CheckConflicting(symbol, Attr::VOLATILE, Attr::PARAMETER);
675 Check(details.shape());
676 Check(details.coshape());
677 if (details.shape().Rank() > common::maxRank) {
678 messages_.Say(
679 "'%s' has rank %d, which is greater than the maximum supported rank %d"_err_en_US,
680 symbol.name(), details.shape().Rank(), common::maxRank);
681 } else if (details.shape().Rank() + details.coshape().Rank() >
682 common::maxRank) {
683 messages_.Say(
684 "'%s' has rank %d and corank %d, whose sum is greater than the maximum supported rank %d"_err_en_US,
685 symbol.name(), details.shape().Rank(), details.coshape().Rank(),
686 common::maxRank);
687 }
688 CheckAssumedTypeEntity(symbol, details);
689 WarnMissingFinal(symbol);
690 const DeclTypeSpec *type{details.type()};
691 const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
692 bool isComponent{symbol.owner().IsDerivedType()};
693 const Symbol *commonBlock{FindCommonBlockContaining(symbol)};
694 bool isLocalVariable{!commonBlock && !isComponent && !details.isDummy() &&
695 symbol.owner().kind() != Scope::Kind::OtherConstruct};
696 if (int corank{evaluate::GetCorank(symbol)}; corank > 0) { // it's a coarray
697 bool isDeferredCoshape{details.coshape().CanBeDeferredShape()};
698 if (IsAllocatable(symbol)) {
699 if (!isDeferredCoshape) { // C827
700 messages_.Say("'%s' is an ALLOCATABLE coarray and must have a deferred"
701 " coshape"_err_en_US,
702 symbol.name());
703 }
704 } else if (isComponent) { // C746
705 std::string deferredMsg{
706 isDeferredCoshape ? "" : " and have a deferred coshape"};
707 messages_.Say("Component '%s' is a coarray and must have the ALLOCATABLE"
708 " attribute%s"_err_en_US,
709 symbol.name(), deferredMsg);
710 } else {
711 if (!details.coshape().CanBeAssumedSize()) { // C828
712 messages_.Say(
713 "'%s' is a non-ALLOCATABLE coarray and must have an explicit coshape"_err_en_US,
714 symbol.name());
715 }
716 }
717 if (IsBadCoarrayType(derived)) { // C747 & C824
718 messages_.Say(
719 "Coarray '%s' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR"_err_en_US,
720 symbol.name());
721 }
722 if (evaluate::IsAssumedRank(symbol)) {
723 messages_.Say("Coarray '%s' may not be an assumed-rank array"_err_en_US,
724 symbol.name());
725 }
726 if (IsNamedConstant(symbol)) {
727 messages_.Say(
728 "Coarray '%s' may not be a named constant"_err_en_US, symbol.name());
729 }
730 if (IsFunctionResult(symbol)) {
731 messages_.Say("Function result may not be a coarray"_err_en_US);
732 } else if (commonBlock) {
733 messages_.Say("Coarray '%s' may not be in COMMON block '/%s/'"_err_en_US,
734 symbol.name(), commonBlock->name());
735 } else if (isLocalVariable && !IsAllocatableOrPointer(symbol) &&
736 !IsSaved(symbol)) {
737 messages_.Say(
738 "Local coarray must have the SAVE or ALLOCATABLE attribute"_err_en_US);
739 }
740 for (int j{0}; j < corank; ++j) {
741 if (auto lcbv{evaluate::ToInt64(evaluate::Fold(
742 context().foldingContext(), evaluate::GetLCOBOUND(symbol, j)))}) {
743 if (auto ucbv{
744 evaluate::ToInt64(evaluate::Fold(context().foldingContext(),
745 evaluate::GetUCOBOUND(symbol, j)))}) {
746 if (ucbv < lcbv) {
747 messages_.Say(
748 "Cobounds %jd:%jd of codimension %d produce an empty coarray"_err_en_US,
749 std::intmax_t{*lcbv}, std::intmax_t{*ucbv}, j + 1);
750 }
751 }
752 }
753 }
754 } else { // not a coarray
755 if (!isComponent && !IsPointer(symbol) && derived) {
756 if (IsEventTypeOrLockType(derived)) {
757 messages_.Say(
758 "Variable '%s' with EVENT_TYPE or LOCK_TYPE must be a coarray"_err_en_US,
759 symbol.name());
760 } else if (auto component{FindEventOrLockPotentialComponent(
761 *derived, /*ignoreCoarrays=*/true)}) {
762 messages_.Say(
763 "Variable '%s' with EVENT_TYPE or LOCK_TYPE potential component '%s' must be a coarray"_err_en_US,
764 symbol.name(), component.BuildResultDesignatorName());
765 }
766 }
767 }
768 if (details.isDummy()) {
769 if (IsIntentOut(symbol)) {
770 // Some of these errors would also be caught by the general check
771 // for definability of automatically deallocated local variables,
772 // but these messages are more specific.
773 if (FindUltimateComponent(symbol, [](const Symbol &x) {
774 return evaluate::IsCoarray(x) && IsAllocatable(x);
775 })) { // C846
776 messages_.Say(
777 "An INTENT(OUT) dummy argument may not be, or contain, an ALLOCATABLE coarray"_err_en_US);
778 }
779 if (IsOrContainsEventOrLockComponent(symbol)) { // C847
780 messages_.Say(
781 "An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE"_err_en_US);
782 }
783 if (IsAssumedSizeArray(symbol)) { // C834
784 if (type && type->IsPolymorphic()) {
785 messages_.Say(
786 "An INTENT(OUT) assumed-size dummy argument array may not be polymorphic"_err_en_US);
787 }
788 if (derived) {
789 if (derived->HasDefaultInitialization()) {
790 messages_.Say(
791 "An INTENT(OUT) assumed-size dummy argument array may not have a derived type with any default component initialization"_err_en_US);
792 }
793 if (IsFinalizable(*derived)) {
794 messages_.Say(
795 "An INTENT(OUT) assumed-size dummy argument array may not be finalizable"_err_en_US);
796 }
797 }
798 }
799 }
800 if (InPure() && !IsStmtFunction(DEREF(innermostSymbol_)) &&
801 !IsPointer(symbol) && !IsIntentIn(symbol) &&
802 !symbol.attrs().test(Attr::VALUE)) {
803 const char *what{InFunction() ? "function" : "subroutine"};
804 bool ok{true};
805 if (IsIntentOut(symbol)) {
806 if (type && type->IsPolymorphic()) { // C1588
807 messages_.Say(
808 "An INTENT(OUT) dummy argument of a pure %s may not be polymorphic"_err_en_US,
809 what);
810 ok = false;
811 } else if (derived) {
812 if (FindUltimateComponent(*derived, [](const Symbol &x) {
813 const DeclTypeSpec *type{x.GetType()};
814 return type && type->IsPolymorphic();
815 })) { // C1588
816 messages_.Say(
817 "An INTENT(OUT) dummy argument of a pure %s may not have a polymorphic ultimate component"_err_en_US,
818 what);
819 ok = false;
820 }
821 if (HasImpureFinal(symbol)) { // C1587
822 messages_.Say(
823 "An INTENT(OUT) dummy argument of a pure %s may not have an impure FINAL subroutine"_err_en_US,
824 what);
825 ok = false;
826 }
827 }
828 } else if (!IsIntentInOut(symbol)) { // C1586
829 messages_.Say(
830 "non-POINTER dummy argument of pure %s must have INTENT() or VALUE attribute"_err_en_US,
831 what);
832 ok = false;
833 }
834 if (ok && InFunction() && !InModuleFile() && !InElemental()) {
835 if (context_.IsEnabled(common::LanguageFeature::RelaxedPureDummy)) {
836 Warn(common::LanguageFeature::RelaxedPureDummy,
837 "non-POINTER dummy argument of pure function should be INTENT(IN) or VALUE"_warn_en_US);
838 } else {
839 messages_.Say(
840 "non-POINTER dummy argument of pure function must be INTENT(IN) or VALUE"_err_en_US);
841 }
842 }
843 }
844 if (auto ignoreTKR{GetIgnoreTKR(symbol)}; !ignoreTKR.empty()) {
845 const Symbol *ownerSymbol{symbol.owner().symbol()};
846 bool inModuleProc{ownerSymbol && IsModuleProcedure(*ownerSymbol)};
847 bool inExplicitExternalInterface{
848 InInterface() && !IsSeparateModuleProcedureInterface(ownerSymbol)};
849 if (!InInterface() && !inModuleProc) {
850 messages_.Say(
851 "!DIR$ IGNORE_TKR may apply only in an interface or a module procedure"_err_en_US);
852 }
853 if (ownerSymbol && ownerSymbol->attrs().test(Attr::ELEMENTAL) &&
854 details.ignoreTKR().test(common::IgnoreTKR::Rank)) {
855 messages_.Say(
856 "!DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure"_err_en_US);
857 }
858 if (IsPassedViaDescriptor(symbol)) {
859 if (IsAllocatableOrObjectPointer(&symbol)) {
860 if (inExplicitExternalInterface) {
861 Warn(common::UsageWarning::IgnoreTKRUsage,
862 "!DIR$ IGNORE_TKR should not apply to an allocatable or pointer"_warn_en_US);
863 } else {
864 messages_.Say(
865 "!DIR$ IGNORE_TKR may not apply to an allocatable or pointer"_err_en_US);
866 }
867 } else if (ignoreTKR.test(common::IgnoreTKR::Rank)) {
868 if (ignoreTKR.count() == 1 && evaluate::IsAssumedRank(symbol)) {
869 Warn(common::UsageWarning::IgnoreTKRUsage,
870 "!DIR$ IGNORE_TKR(R) is not meaningful for an assumed-rank array"_warn_en_US);
871 } else if (inExplicitExternalInterface) {
872 Warn(common::UsageWarning::IgnoreTKRUsage,
873 "!DIR$ IGNORE_TKR(R) should not apply to a dummy argument passed via descriptor"_warn_en_US);
874 } else {
875 messages_.Say(
876 "!DIR$ IGNORE_TKR(R) may not apply to a dummy argument passed via descriptor"_err_en_US);
877 }
878 }
879 }
880 }
881 } else if (!details.ignoreTKR().empty()) {
882 messages_.Say(
883 "!DIR$ IGNORE_TKR directive may apply only to a dummy data argument"_err_en_US);
884 }
885 if (InElemental()) {
886 if (details.isDummy()) { // C15100
887 if (details.shape().Rank() > 0) {
888 messages_.Say(
889 "A dummy argument of an ELEMENTAL procedure must be scalar"_err_en_US);
890 }
891 if (IsAllocatable(symbol)) {
892 messages_.Say(
893 "A dummy argument of an ELEMENTAL procedure may not be ALLOCATABLE"_err_en_US);
894 }
895 if (evaluate::IsCoarray(symbol)) {
896 messages_.Say(
897 "A dummy argument of an ELEMENTAL procedure may not be a coarray"_err_en_US);
898 }
899 if (IsPointer(symbol)) {
900 messages_.Say(
901 "A dummy argument of an ELEMENTAL procedure may not be a POINTER"_err_en_US);
902 }
903 if (!symbol.attrs().HasAny(Attrs{Attr::VALUE, Attr::INTENT_IN,
904 Attr::INTENT_INOUT, Attr::INTENT_OUT})) { // F'2023 C15120
905 messages_.Say(
906 "A dummy argument of an ELEMENTAL procedure must have an INTENT() or VALUE attribute"_err_en_US);
907 }
908 } else if (IsFunctionResult(symbol)) { // C15101
909 if (details.shape().Rank() > 0) {
910 messages_.Say(
911 "The result of an ELEMENTAL function must be scalar"_err_en_US);
912 }
913 if (IsAllocatable(symbol)) {
914 messages_.Say(
915 "The result of an ELEMENTAL function may not be ALLOCATABLE"_err_en_US);
916 }
917 if (IsPointer(symbol)) {
918 messages_.Say(
919 "The result of an ELEMENTAL function may not be a POINTER"_err_en_US);
920 }
921 }
922 }
923 if (HasDeclarationInitializer(symbol)) { // C808; ignore DATA initialization
924 CheckPointerInitialization(symbol);
925 if (IsAutomatic(symbol)) {
926 messages_.Say(
927 "An automatic variable or component must not be initialized"_err_en_US);
928 } else if (IsDummy(symbol)) {
929 messages_.Say("A dummy argument must not be initialized"_err_en_US);
930 } else if (IsFunctionResult(symbol)) {
931 messages_.Say("A function result must not be initialized"_err_en_US);
932 } else if (IsInBlankCommon(symbol)) {
933 Warn(common::LanguageFeature::InitBlankCommon,
934 "A variable in blank COMMON should not be initialized"_port_en_US);
935 }
936 }
937 if (symbol.owner().kind() == Scope::Kind::BlockData) {
938 if (IsAllocatable(symbol)) {
939 messages_.Say(
940 "An ALLOCATABLE variable may not appear in a BLOCK DATA subprogram"_err_en_US);
941 } else if (IsInitialized(symbol) && !FindCommonBlockContaining(symbol)) {
942 messages_.Say(
943 "An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US);
944 }
945 }
946 if (derived && InPure() && !InInterface() &&
947 IsAutomaticallyDestroyed(symbol) &&
948 !IsIntentOut(symbol) /*has better messages*/ &&
949 !IsFunctionResult(symbol) /*ditto*/) {
950 // Check automatically deallocated local variables for possible
951 // problems with finalization in PURE.
952 if (auto whyNot{WhyNotDefinable(symbol.name(), symbol.owner(),
953 {DefinabilityFlag::PotentialDeallocation}, symbol)}) {
954 if (auto *msg{messages_.Say(
955 "'%s' may not be a local variable in a pure subprogram"_err_en_US,
956 symbol.name())}) {
957 msg->Attach(std::move(whyNot->set_severity(parser::Severity::Because)));
958 }
959 }
960 }
961 if (symbol.attrs().test(Attr::EXTERNAL)) {
962 SayWithDeclaration(symbol,
963 "'%s' is a data object and may not be EXTERNAL"_err_en_US,
964 symbol.name());
965 }
966 if (symbol.test(Symbol::Flag::CrayPointee)) {
967 // NB, IsSaved was too smart here.
968 if (details.init()) {
969 messages_.Say(
970 "Cray pointee '%s' may not be initialized"_err_en_US, symbol.name());
971 }
972 if (symbol.attrs().test(Attr::SAVE)) {
973 messages_.Say(
974 "Cray pointee '%s' may not have the SAVE attribute"_err_en_US,
975 symbol.name());
976 }
977 }
978 if (derived) {
979 bool isUnsavedLocal{
980 isLocalVariable && !IsAllocatable(symbol) && !IsSaved(symbol)};
981 if (IsFunctionResult(symbol) || IsPointer(symbol) ||
982 evaluate::IsCoarray(symbol) || isUnsavedLocal) {
983 if (auto badPotential{FindCoarrayPotentialComponent(*derived)}) {
984 if (IsFunctionResult(symbol)) { // F'2023 C825
985 SayWithDeclaration(*badPotential,
986 "Function result '%s' may not have a coarray potential component '%s'"_err_en_US,
987 symbol.name(), badPotential.BuildResultDesignatorName());
988 } else if (IsPointer(symbol)) { // F'2023 C825
989 SayWithDeclaration(*badPotential,
990 "Pointer '%s' may not have a coarray potential component '%s'"_err_en_US,
991 symbol.name(), badPotential.BuildResultDesignatorName());
992 } else if (evaluate::IsCoarray(symbol)) { // F'2023 C825
993 SayWithDeclaration(*badPotential,
994 "Coarray '%s' may not have a coarray potential component '%s'"_err_en_US,
995 symbol.name(), badPotential.BuildResultDesignatorName());
996 } else if (isUnsavedLocal) { // F'2023 C826
997 SayWithDeclaration(*badPotential,
998 "Local variable '%s' without the SAVE or ALLOCATABLE attribute may not have a coarray potential subobject component '%s'"_err_en_US,
999 symbol.name(), badPotential.BuildResultDesignatorName());
1000 } else {
1001 DIE("caught unexpected bad coarray potential component");
1002 }
1003 }
1004 } else if (isComponent && (IsAllocatable(symbol) || symbol.Rank() > 0)) {
1005 if (auto badUltimate{FindCoarrayUltimateComponent(*derived)}) {
1006 // TODO: still an error in F'2023?
1007 SayWithDeclaration(*badUltimate,
1008 "Allocatable or array component '%s' may not have a coarray ultimate component '%s'"_err_en_US,
1009 symbol.name(), badUltimate.BuildResultDesignatorName());
1010 }
1011 }
1012 }
1013
1014 // Check CUDA attributes and special circumstances of being in device
1015 // subprograms
1016 const Scope &progUnit{GetProgramUnitContaining(symbol)};
1017 const auto *subpDetails{!isComponent && progUnit.symbol()
1018 ? progUnit.symbol()->detailsIf<SubprogramDetails>()
1019 : nullptr};
1020 bool inDeviceSubprogram{IsCUDADeviceContext(&symbol.owner())};
1021 if (inDeviceSubprogram) {
1022 if (IsSaved(symbol)) {
1023 Warn(common::UsageWarning::CUDAUsage,
1024 "'%s' should not have the SAVE attribute or initialization in a device subprogram"_warn_en_US,
1025 symbol.name());
1026 }
1027 if (IsPointer(symbol)) {
1028 Warn(common::UsageWarning::CUDAUsage,
1029 "Pointer '%s' may not be associated in a device subprogram"_warn_en_US,
1030 symbol.name());
1031 }
1032 if (details.isDummy() &&
1033 details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=
1034 common::CUDADataAttr::Device &&
1035 details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=
1036 common::CUDADataAttr::Managed &&
1037 details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=
1038 common::CUDADataAttr::Shared) {
1039 Warn(common::UsageWarning::CUDAUsage,
1040 "Dummy argument '%s' may not have ATTRIBUTES(%s) in a device subprogram"_warn_en_US,
1041 symbol.name(),
1042 parser::ToUpperCaseLetters(
1043 common::EnumToString(*details.cudaDataAttr())));
1044 }
1045 }
1046 if (details.cudaDataAttr()) {
1047 if (auto dyType{evaluate::DynamicType::From(symbol)}) {
1048 if (dyType->category() != TypeCategory::Derived) {
1049 if (!IsCUDAIntrinsicType(*dyType)) {
1050 messages_.Say(
1051 "'%s' has intrinsic type '%s' that is not available on the device"_err_en_US,
1052 symbol.name(), dyType->AsFortran());
1053 }
1054 }
1055 }
1056 auto attr{*details.cudaDataAttr()};
1057 switch (attr) {
1058 case common::CUDADataAttr::Constant:
1059 if (subpDetails && !inDeviceSubprogram) {
1060 messages_.Say(
1061 "Object '%s' with ATTRIBUTES(CONSTANT) may not be declared in a host subprogram"_err_en_US,
1062 symbol.name());
1063 } else if (IsAllocatableOrPointer(symbol) ||
1064 symbol.attrs().test(Attr::TARGET)) {
1065 messages_.Say(
1066 "Object '%s' with ATTRIBUTES(CONSTANT) may not be allocatable, pointer, or target"_err_en_US,
1067 symbol.name());
1068 } else if (auto shape{evaluate::GetShape(foldingContext_, symbol)};
1069 !shape ||
1070 !evaluate::AsConstantExtents(foldingContext_, *shape)) {
1071 messages_.Say(
1072 "Object '%s' with ATTRIBUTES(CONSTANT) must have constant array bounds"_err_en_US,
1073 symbol.name());
1074 }
1075 break;
1076 case common::CUDADataAttr::Device:
1077 if (isComponent && !IsAllocatable(symbol) && !IsPointer(symbol)) {
1078 messages_.Say(
1079 "Component '%s' with ATTRIBUTES(DEVICE) must also be allocatable or pointer"_err_en_US,
1080 symbol.name());
1081 }
1082 break;
1083 case common::CUDADataAttr::Managed:
1084 if (!IsAutomatic(symbol) && !IsAllocatable(symbol) &&
1085 !details.isDummy() && !evaluate::IsExplicitShape(symbol)) {
1086 messages_.Say(
1087 "Object '%s' with ATTRIBUTES(MANAGED) must also be allocatable, automatic, explicit shape, or a dummy argument"_err_en_US,
1088 symbol.name());
1089 }
1090 break;
1091 case common::CUDADataAttr::Pinned:
1092 if (inDeviceSubprogram) {
1093 Warn(common::UsageWarning::CUDAUsage,
1094 "Object '%s' with ATTRIBUTES(PINNED) may not be declared in a device subprogram"_warn_en_US,
1095 symbol.name());
1096 } else if (IsPointer(symbol)) {
1097 Warn(common::UsageWarning::CUDAUsage,
1098 "Object '%s' with ATTRIBUTES(PINNED) may not be a pointer"_warn_en_US,
1099 symbol.name());
1100 } else if (!IsAllocatable(symbol)) {
1101 Warn(common::UsageWarning::CUDAUsage,
1102 "Object '%s' with ATTRIBUTES(PINNED) should also be allocatable"_warn_en_US,
1103 symbol.name());
1104 }
1105 break;
1106 case common::CUDADataAttr::Shared:
1107 if (IsAllocatableOrPointer(symbol) || symbol.attrs().test(Attr::TARGET)) {
1108 messages_.Say(
1109 "Object '%s' with ATTRIBUTES(SHARED) may not be allocatable, pointer, or target"_err_en_US,
1110 symbol.name());
1111 } else if (!inDeviceSubprogram) {
1112 messages_.Say(
1113 "Object '%s' with ATTRIBUTES(SHARED) must be declared in a device subprogram"_err_en_US,
1114 symbol.name());
1115 }
1116 break;
1117 case common::CUDADataAttr::Unified:
1118 if (((!subpDetails &&
1119 symbol.owner().kind() != Scope::Kind::MainProgram) ||
1120 inDeviceSubprogram) &&
1121 !isComponent) {
1122 messages_.Say(
1123 "Object '%s' with ATTRIBUTES(UNIFIED) must be declared in a host subprogram"_err_en_US,
1124 symbol.name());
1125 }
1126 break;
1127 case common::CUDADataAttr::Texture:
1128 messages_.Say(
1129 "ATTRIBUTES(TEXTURE) is obsolete and no longer supported"_err_en_US);
1130 break;
1131 }
1132 if (attr != common::CUDADataAttr::Pinned) {
1133 if (details.commonBlock()) {
1134 messages_.Say(
1135 "Object '%s' with ATTRIBUTES(%s) may not be in COMMON"_err_en_US,
1136 symbol.name(),
1137 parser::ToUpperCaseLetters(common::EnumToString(attr)));
1138 } else if (FindEquivalenceSet(symbol)) {
1139 messages_.Say(
1140 "Object '%s' with ATTRIBUTES(%s) may not be in an equivalence group"_err_en_US,
1141 symbol.name(),
1142 parser::ToUpperCaseLetters(common::EnumToString(attr)));
1143 }
1144 }
1145 if (subpDetails /* not a module variable */ && IsSaved(symbol) &&
1146 !inDeviceSubprogram && !IsAllocatable(symbol) &&
1147 attr == common::CUDADataAttr::Device) {
1148 messages_.Say(
1149 "Saved object '%s' in host code may not have ATTRIBUTES(DEVICE) unless allocatable"_err_en_US,
1150 symbol.name(),
1151 parser::ToUpperCaseLetters(common::EnumToString(attr)));
1152 }
1153 if (isComponent) {
1154 if (attr == common::CUDADataAttr::Device) {
1155 const DeclTypeSpec *type{symbol.GetType()};
1156 if (const DerivedTypeSpec *
1157 derived{type ? type->AsDerived() : nullptr}) {
1158 DirectComponentIterator directs{*derived};
1159 if (auto iter{std::find_if(directs.begin(), directs.end(),
1160 [](const Symbol &) { return false; })}) {
1161 messages_.Say(
1162 "Derived type component '%s' may not have ATTRIBUTES(DEVICE) as it has a direct device component '%s'"_err_en_US,
1163 symbol.name(), iter.BuildResultDesignatorName());
1164 }
1165 }
1166 } else if (attr == common::CUDADataAttr::Constant ||
1167 attr == common::CUDADataAttr::Shared) {
1168 messages_.Say(
1169 "Derived type component '%s' may not have ATTRIBUTES(%s)"_err_en_US,
1170 symbol.name(),
1171 parser::ToUpperCaseLetters(common::EnumToString(attr)));
1172 }
1173 } else if (!subpDetails && symbol.owner().kind() != Scope::Kind::Module &&
1174 symbol.owner().kind() != Scope::Kind::MainProgram &&
1175 symbol.owner().kind() != Scope::Kind::BlockConstruct) {
1176 messages_.Say(
1177 "ATTRIBUTES(%s) may apply only to module, host subprogram, block, or device subprogram data"_err_en_US,
1178 parser::ToUpperCaseLetters(common::EnumToString(attr)));
1179 }
1180 }
1181
1182 if (derived && derived->IsVectorType()) {
1183 CHECK(type);
1184 std::string typeName{type->AsFortran()};
1185 if (IsAssumedShape(symbol)) {
1186 SayWithDeclaration(symbol,
1187 "Assumed-shape entity of %s type is not supported"_err_en_US,
1188 typeName);
1189 } else if (IsDeferredShape(symbol)) {
1190 SayWithDeclaration(symbol,
1191 "Deferred-shape entity of %s type is not supported"_err_en_US,
1192 typeName);
1193 } else if (evaluate::IsAssumedRank(symbol)) {
1194 SayWithDeclaration(symbol,
1195 "Assumed rank entity of %s type is not supported"_err_en_US,
1196 typeName);
1197 }
1198 }
1199}
1200
1201void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
1202 if (IsPointer(symbol) && !context_.HasError(symbol) &&
1203 !scopeIsUninstantiatedPDT_) {
1204 if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
1205 if (object->init()) { // C764, C765; C808
1206 if (auto designator{evaluate::AsGenericExpr(symbol)}) {
1207 auto restorer{messages_.SetLocation(symbol.name())};
1208 context_.set_location(symbol.name());
1209 CheckInitialDataPointerTarget(
1210 context_, *designator, *object->init(), DEREF(scope_));
1211 }
1212 }
1213 } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
1214 if (proc->init() && *proc->init()) {
1215 // C1519 - must be nonelemental external or module procedure,
1216 // or an unrestricted specific intrinsic function.
1217 const Symbol &local{DEREF(*proc->init())};
1218 const Symbol &ultimate{local.GetUltimate()};
1219 bool checkTarget{true};
1220 if (ultimate.attrs().test(Attr::INTRINSIC)) {
1221 if (auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
1222 ultimate.name().ToString())};
1223 !intrinsic || intrinsic->isRestrictedSpecific) { // C1030
1224 context_.Say(
1225 "Intrinsic procedure '%s' is not an unrestricted specific "
1226 "intrinsic permitted for use as the initializer for procedure "
1227 "pointer '%s'"_err_en_US,
1228 ultimate.name(), symbol.name());
1229 checkTarget = false;
1230 }
1231 } else if (!(ultimate.attrs().test(Attr::EXTERNAL) ||
1232 ultimate.owner().kind() == Scope::Kind::Module ||
1233 ultimate.owner().IsTopLevel()) ||
1234 IsDummy(ultimate) || IsPointer(ultimate)) {
1235 context_.Say(
1236 "Procedure pointer '%s' initializer '%s' is neither an external nor a module procedure"_err_en_US,
1237 symbol.name(), ultimate.name());
1238 checkTarget = false;
1239 } else if (IsElementalProcedure(ultimate)) {
1240 context_.Say("Procedure pointer '%s' cannot be initialized with the "
1241 "elemental procedure '%s'"_err_en_US,
1242 symbol.name(), ultimate.name());
1243 checkTarget = false;
1244 }
1245 if (checkTarget) {
1246 SomeExpr lhs{evaluate::ProcedureDesignator{symbol}};
1247 SomeExpr rhs{evaluate::ProcedureDesignator{**proc->init()}};
1248 CheckPointerAssignment(context_, lhs, rhs,
1249 GetProgramUnitOrBlockConstructContaining(symbol),
1250 /*isBoundsRemapping=*/false, /*isAssumedRank=*/false);
1251 }
1252 }
1253 }
1254 }
1255}
1256
1257// The six different kinds of array-specs:
1258// array-spec -> explicit-shape-list | deferred-shape-list
1259// | assumed-shape-list | implied-shape-list
1260// | assumed-size | assumed-rank
1261// explicit-shape -> [ lb : ] ub
1262// deferred-shape -> :
1263// assumed-shape -> [ lb ] :
1264// implied-shape -> [ lb : ] *
1265// assumed-size -> [ explicit-shape-list , ] [ lb : ] *
1266// assumed-rank -> ..
1267// Note:
1268// - deferred-shape is also an assumed-shape
1269// - A single "*" or "lb:*" might be assumed-size or implied-shape-list
1270void CheckHelper::CheckArraySpec(
1271 const Symbol &symbol, const ArraySpec &arraySpec) {
1272 if (arraySpec.Rank() == 0) {
1273 return;
1274 }
1275 bool isExplicit{arraySpec.IsExplicitShape()};
1276 bool canBeDeferred{arraySpec.CanBeDeferredShape()};
1277 bool canBeImplied{arraySpec.CanBeImpliedShape()};
1278 bool canBeAssumedShape{arraySpec.CanBeAssumedShape()};
1279 bool canBeAssumedSize{arraySpec.CanBeAssumedSize()};
1280 bool isAssumedRank{arraySpec.IsAssumedRank()};
1281 bool isCUDAShared{
1282 GetCUDADataAttr(&symbol).value_or(common::CUDADataAttr::Device) ==
1283 common::CUDADataAttr::Shared};
1284 bool isCrayPointee{symbol.test(Symbol::Flag::CrayPointee)};
1285 std::optional<parser::MessageFixedText> msg;
1286 if (isCrayPointee && !isExplicit && !canBeAssumedSize) {
1287 msg =
1288 "Cray pointee '%s' must have explicit shape or assumed size"_err_en_US;
1289 } else if (IsAllocatableOrPointer(symbol) && !canBeDeferred &&
1290 !isAssumedRank) {
1291 if (symbol.owner().IsDerivedType()) { // C745
1292 if (IsAllocatable(symbol)) {
1293 msg = "Allocatable array component '%s' must have"
1294 " deferred shape"_err_en_US;
1295 } else {
1296 msg = "Array pointer component '%s' must have deferred shape"_err_en_US;
1297 }
1298 } else {
1299 if (IsAllocatable(symbol)) { // C832
1300 msg = "Allocatable array '%s' must have deferred shape or"
1301 " assumed rank"_err_en_US;
1302 } else {
1303 msg = "Array pointer '%s' must have deferred shape or"
1304 " assumed rank"_err_en_US;
1305 }
1306 }
1307 } else if (IsDummy(symbol)) {
1308 if (canBeImplied && !canBeAssumedSize) { // C836
1309 msg = "Dummy array argument '%s' may not have implied shape"_err_en_US;
1310 }
1311 } else if (canBeAssumedShape && !canBeDeferred) {
1312 msg = "Assumed-shape array '%s' must be a dummy argument"_err_en_US;
1313 } else if (isAssumedRank) { // C837
1314 msg = "Assumed-rank array '%s' must be a dummy argument"_err_en_US;
1315 } else if (canBeAssumedSize && !canBeImplied && !isCUDAShared &&
1316 !isCrayPointee) { // C833
1317 msg = "Assumed-size array '%s' must be a dummy argument"_err_en_US;
1318 } else if (canBeImplied) {
1319 if (!IsNamedConstant(symbol) && !isCUDAShared &&
1320 !isCrayPointee) { // C835, C836
1321 msg = "Implied-shape array '%s' must be a named constant or a "
1322 "dummy argument"_err_en_US;
1323 }
1324 } else if (IsNamedConstant(symbol)) {
1325 if (!isExplicit && !canBeImplied) {
1326 msg = "Named constant '%s' array must have constant or"
1327 " implied shape"_err_en_US;
1328 }
1329 } else if (!isExplicit &&
1330 !(IsAllocatableOrPointer(symbol) || isCrayPointee)) {
1331 if (symbol.owner().IsDerivedType()) { // C749
1332 msg = "Component array '%s' without ALLOCATABLE or POINTER attribute must"
1333 " have explicit shape"_err_en_US;
1334 } else { // C816
1335 msg = "Array '%s' without ALLOCATABLE or POINTER attribute must have"
1336 " explicit shape"_err_en_US;
1337 }
1338 }
1339 if (msg) {
1340 context_.Say(std::move(*msg), symbol.name());
1341 }
1342}
1343
1344void CheckHelper::CheckProcEntity(
1345 const Symbol &symbol, const ProcEntityDetails &details) {
1346 CheckSymbolType(symbol);
1347 const Symbol *interface{details.procInterface()};
1348 if (details.isDummy()) {
1349 if (!symbol.attrs().test(Attr::POINTER) && // C843
1350 symbol.attrs().HasAny(
1351 {Attr::INTENT_IN, Attr::INTENT_OUT, Attr::INTENT_INOUT})) {
1352 messages_.Say("A dummy procedure without the POINTER attribute"
1353 " may not have an INTENT attribute"_err_en_US);
1354 }
1355 if (InElemental()) { // C15100
1356 messages_.Say(
1357 "An ELEMENTAL subprogram may not have a dummy procedure"_err_en_US);
1358 }
1359 if (interface && IsElementalProcedure(*interface)) {
1360 // There's no explicit constraint or "shall" that we can find in the
1361 // standard for this check, but it seems to be implied in multiple
1362 // sites, and ELEMENTAL non-intrinsic actual arguments *are*
1363 // explicitly forbidden. But we allow "PROCEDURE(SIN)::dummy"
1364 // because it is explicitly legal to *pass* the specific intrinsic
1365 // function SIN as an actual argument.
1366 if (interface->attrs().test(Attr::INTRINSIC)) {
1367 Warn(common::UsageWarning::Portability,
1368 "A dummy procedure should not have an ELEMENTAL intrinsic as its interface"_port_en_US);
1369 } else {
1370 messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
1371 }
1372 }
1373 } else if (IsPointer(symbol)) {
1374 CheckPointerInitialization(symbol);
1375 if (interface) {
1376 if (interface->attrs().test(Attr::INTRINSIC)) {
1377 auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
1378 interface->name().ToString())};
1379 if (!intrinsic || intrinsic->isRestrictedSpecific) { // C1515
1380 messages_.Say(
1381 "Intrinsic procedure '%s' is not an unrestricted specific "
1382 "intrinsic permitted for use as the definition of the interface "
1383 "to procedure pointer '%s'"_err_en_US,
1384 interface->name(), symbol.name());
1385 } else if (IsElementalProcedure(*interface)) {
1386 Warn(common::UsageWarning::Portability,
1387 "Procedure pointer '%s' should not have an ELEMENTAL intrinsic as its interface"_port_en_US,
1388 symbol.name()); // C1517
1389 }
1390 } else if (IsElementalProcedure(*interface)) {
1391 messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US,
1392 symbol.name()); // C1517
1393 }
1394 }
1395 if (symbol.owner().IsDerivedType()) {
1396 CheckPassArg(symbol, interface, details);
1397 }
1398 } else if (symbol.owner().IsDerivedType()) {
1399 const auto &name{symbol.name()};
1400 messages_.Say(name,
1401 "Procedure component '%s' must have POINTER attribute"_err_en_US, name);
1402 }
1403 CheckExternal(symbol);
1404}
1405
1406// When a module subprogram has the MODULE prefix the following must match
1407// with the corresponding separate module procedure interface body:
1408// - C1549: characteristics and dummy argument names
1409// - C1550: binding label
1410// - C1551: NON_RECURSIVE prefix
1411class SubprogramMatchHelper {
1412public:
1413 explicit SubprogramMatchHelper(CheckHelper &checkHelper)
1414 : checkHelper{checkHelper} {}
1415
1416 void Check(const Symbol &, const Symbol &);
1417
1418private:
1419 SemanticsContext &context() { return checkHelper.context(); }
1420 void CheckDummyArg(const Symbol &, const Symbol &, const DummyArgument &,
1421 const DummyArgument &);
1422 void CheckDummyDataObject(const Symbol &, const Symbol &,
1423 const DummyDataObject &, const DummyDataObject &);
1424 void CheckDummyProcedure(const Symbol &, const Symbol &,
1425 const DummyProcedure &, const DummyProcedure &);
1426 bool CheckSameIntent(
1427 const Symbol &, const Symbol &, common::Intent, common::Intent);
1428 template <typename... A>
1429 void Say(
1430 const Symbol &, const Symbol &, parser::MessageFixedText &&, A &&...);
1431 template <typename ATTRS>
1432 bool CheckSameAttrs(const Symbol &, const Symbol &, ATTRS, ATTRS);
1433 bool ShapesAreCompatible(const DummyDataObject &, const DummyDataObject &);
1434 evaluate::Shape FoldShape(const evaluate::Shape &);
1435 std::optional<evaluate::Shape> FoldShape(
1436 const std::optional<evaluate::Shape> &shape) {
1437 if (shape) {
1438 return FoldShape(*shape);
1439 }
1440 return std::nullopt;
1441 }
1442 std::string AsFortran(DummyDataObject::Attr attr) {
1443 return parser::ToUpperCaseLetters(DummyDataObject::EnumToString(attr));
1444 }
1445 std::string AsFortran(DummyProcedure::Attr attr) {
1446 return parser::ToUpperCaseLetters(DummyProcedure::EnumToString(attr));
1447 }
1448
1449 CheckHelper &checkHelper;
1450};
1451
1452// 15.6.2.6 para 3 - can the result of an ENTRY differ from its function?
1453bool CheckHelper::IsResultOkToDiffer(const FunctionResult &result) {
1454 if (result.attrs.test(FunctionResult::Attr::Allocatable) ||
1455 result.attrs.test(FunctionResult::Attr::Pointer)) {
1456 return false;
1457 }
1458 const auto *typeAndShape{result.GetTypeAndShape()};
1459 if (!typeAndShape || typeAndShape->Rank() != 0) {
1460 return false;
1461 }
1462 auto category{typeAndShape->type().category()};
1463 if (category == TypeCategory::Character ||
1464 category == TypeCategory::Derived) {
1465 return false;
1466 }
1467 int kind{typeAndShape->type().kind()};
1468 return kind == context_.GetDefaultKind(category) ||
1469 (category == TypeCategory::Real &&
1470 kind == context_.doublePrecisionKind());
1471}
1472
1473void CheckHelper::CheckSubprogram(
1474 const Symbol &symbol, const SubprogramDetails &details) {
1475 // Evaluate a procedure definition's characteristics to flush out
1476 // any errors that analysis might expose, in case this subprogram hasn't
1477 // had any calls in this compilation unit that would have validated them.
1478 if (!context_.HasError(symbol) && !details.isDummy() &&
1479 !details.isInterface() && !details.stmtFunction()) {
1480 if (!Procedure::Characterize(symbol, foldingContext_)) {
1481 context_.SetError(symbol);
1482 }
1483 }
1484 if (const Symbol *iface{FindSeparateModuleSubprogramInterface(&symbol)}) {
1485 SubprogramMatchHelper{*this}.Check(symbol, *iface);
1486 }
1487 if (const Scope *entryScope{details.entryScope()}) {
1488 // ENTRY F'2023 15.6.2.6
1489 std::optional<parser::MessageFixedText> error;
1490 const Symbol *subprogram{entryScope->symbol()};
1491 const SubprogramDetails *subprogramDetails{nullptr};
1492 if (subprogram) {
1493 subprogramDetails = subprogram->detailsIf<SubprogramDetails>();
1494 }
1495 if (!(entryScope->parent().IsGlobal() || entryScope->parent().IsModule() ||
1496 entryScope->parent().IsSubmodule())) {
1497 error = "ENTRY may not appear in an internal subprogram"_err_en_US;
1498 } else if (subprogramDetails && details.isFunction() &&
1499 subprogramDetails->isFunction() &&
1500 !context_.HasError(details.result()) &&
1501 !context_.HasError(subprogramDetails->result())) {
1502 auto result{FunctionResult::Characterize(
1503 details.result(), context_.foldingContext())};
1504 auto subpResult{FunctionResult::Characterize(
1505 subprogramDetails->result(), context_.foldingContext())};
1506 if (result && subpResult && *result != *subpResult &&
1507 (!IsResultOkToDiffer(*result) || !IsResultOkToDiffer(*subpResult))) {
1508 error =
1509 "Result of ENTRY is not compatible with result of containing function"_err_en_US;
1510 }
1511 }
1512 if (error) {
1513 if (auto *msg{messages_.Say(symbol.name(), *error)}) {
1514 if (subprogram) {
1515 msg->Attach(subprogram->name(), "Containing subprogram"_en_US);
1516 }
1517 }
1518 }
1519 }
1520 if (details.isFunction() &&
1521 details.result().name() != symbol.name()) { // F'2023 C1569 & C1583
1522 if (auto iter{symbol.owner().find(details.result().name())};
1523 iter != symbol.owner().end()) {
1524 const Symbol &resNameSym{*iter->second};
1525 if (const auto *resNameSubp{resNameSym.detailsIf<SubprogramDetails>()}) {
1526 if (const Scope * resNameEntryScope{resNameSubp->entryScope()}) {
1527 const Scope *myScope{
1528 details.entryScope() ? details.entryScope() : symbol.scope()};
1529 if (resNameEntryScope == myScope) {
1530 if (auto *msg{messages_.Say(symbol.name(),
1531 "Explicit RESULT('%s') of function '%s' cannot have the same name as a distinct ENTRY into the same scope"_err_en_US,
1532 details.result().name(), symbol.name())}) {
1533 msg->Attach(
1534 resNameSym.name(), "ENTRY with conflicting name"_en_US);
1535 }
1536 }
1537 }
1538 }
1539 }
1540 }
1541 if (const MaybeExpr & stmtFunction{details.stmtFunction()}) {
1542 if (auto msg{evaluate::CheckStatementFunction(
1543 symbol, *stmtFunction, context_.foldingContext())}) {
1544 SayWithDeclaration(symbol, std::move(*msg));
1545 } else if (IsPointer(symbol)) {
1546 SayWithDeclaration(symbol,
1547 "A statement function must not have the POINTER attribute"_err_en_US);
1548 } else if (details.result().flags().test(Symbol::Flag::Implicit)) {
1549 // 15.6.4 p2 weird requirement
1550 if (const Symbol *
1551 host{symbol.owner().parent().FindSymbol(symbol.name())}) {
1552 evaluate::AttachDeclaration(
1553 Warn(common::LanguageFeature::StatementFunctionExtensions,
1554 symbol.name(),
1555 "An implicitly typed statement function should not appear when the same symbol is available in its host scope"_port_en_US),
1556 *host);
1557 }
1558 }
1559 if (GetProgramUnitOrBlockConstructContaining(symbol).kind() ==
1560 Scope::Kind::BlockConstruct) { // C1107
1561 messages_.Say(symbol.name(),
1562 "A statement function definition may not appear in a BLOCK construct"_err_en_US);
1563 }
1564 }
1565 if (IsElementalProcedure(symbol)) {
1566 // See comment on the similar check in CheckProcEntity()
1567 if (details.isDummy()) {
1568 messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
1569 } else {
1570 for (const Symbol *dummy : details.dummyArgs()) {
1571 if (!dummy) { // C15100
1572 messages_.Say(
1573 "An ELEMENTAL subroutine may not have an alternate return dummy argument"_err_en_US);
1574 }
1575 }
1576 }
1577 }
1578 if (details.isInterface()) {
1579 if (!details.isDummy() && details.isFunction() &&
1580 IsAssumedLengthCharacter(details.result())) { // C721
1581 messages_.Say(details.result().name(),
1582 "A function interface may not declare an assumed-length CHARACTER(*) result"_err_en_US);
1583 }
1584 if (symbol.attrs().test(Attr::ABSTRACT) &&
1585 (symbol.name() == "integer" || symbol.name() == "unsigned" ||
1586 symbol.name() == "real" || symbol.name() == "complex" ||
1587 symbol.name() == "character" ||
1588 symbol.name() == "logical")) { // F'2023 C1503
1589 messages_.Say(
1590 "An ABSTRACT interface may not have the same name as an intrinsic type"_err_en_US);
1591 }
1592 }
1593 CheckExternal(symbol);
1594 CheckModuleProcedureDef(symbol);
1595 auto cudaAttrs{details.cudaSubprogramAttrs()};
1596 if (cudaAttrs &&
1597 (*cudaAttrs == common::CUDASubprogramAttrs::Global ||
1598 *cudaAttrs == common::CUDASubprogramAttrs::Grid_Global) &&
1599 details.isFunction()) {
1600 messages_.Say(symbol.name(),
1601 "A function may not have ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)"_err_en_US);
1602 }
1603 if (cudaAttrs &&
1604 (*cudaAttrs == common::CUDASubprogramAttrs::Global ||
1605 *cudaAttrs == common::CUDASubprogramAttrs::Grid_Global) &&
1606 symbol.attrs().HasAny({Attr::RECURSIVE, Attr::PURE, Attr::ELEMENTAL})) {
1607 messages_.Say(symbol.name(),
1608 "A kernel subprogram may not be RECURSIVE, PURE, or ELEMENTAL"_err_en_US);
1609 }
1610 if (cudaAttrs && *cudaAttrs != common::CUDASubprogramAttrs::Host) {
1611 // CUDA device subprogram checks
1612 if (ClassifyProcedure(symbol) == ProcedureDefinitionClass::Internal) {
1613 messages_.Say(symbol.name(),
1614 "A device subprogram may not be an internal subprogram"_err_en_US);
1615 }
1616 }
1617 if ((!details.cudaLaunchBounds().empty() ||
1618 !details.cudaClusterDims().empty()) &&
1619 !(cudaAttrs &&
1620 (*cudaAttrs == common::CUDASubprogramAttrs::Global ||
1621 *cudaAttrs == common::CUDASubprogramAttrs::Grid_Global))) {
1622 messages_.Say(symbol.name(),
1623 "A subroutine may not have LAUNCH_BOUNDS() or CLUSTER_DIMS() unless it has ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)"_err_en_US);
1624 }
1625 if (!IsStmtFunction(symbol)) {
1626 if (const Scope * outerDevice{FindCUDADeviceContext(&symbol.owner())};
1627 outerDevice && outerDevice->symbol()) {
1628 if (auto *msg{messages_.Say(symbol.name(),
1629 "'%s' may not be an internal procedure of CUDA device subprogram '%s'"_err_en_US,
1630 symbol.name(), outerDevice->symbol()->name())}) {
1631 msg->Attach(outerDevice->symbol()->name(),
1632 "Containing CUDA device subprogram"_en_US);
1633 }
1634 }
1635 }
1636}
1637
1638void CheckHelper::CheckExternal(const Symbol &symbol) {
1639 if (IsExternal(symbol)) {
1640 std::string interfaceName{symbol.name().ToString()};
1641 if (const auto *bind{symbol.GetBindName()}) {
1642 interfaceName = *bind;
1643 }
1644 if (const Symbol * global{FindGlobal(symbol)};
1645 global && global != &symbol) {
1646 std::string definitionName{global->name().ToString()};
1647 if (const auto *bind{global->GetBindName()}) {
1648 definitionName = *bind;
1649 }
1650 if (interfaceName == definitionName) {
1651 parser::Message *msg{nullptr};
1652 if (!IsProcedure(*global)) {
1653 if ((symbol.flags().test(Symbol::Flag::Function) ||
1654 symbol.flags().test(Symbol::Flag::Subroutine))) {
1655 msg = Warn(common::UsageWarning::ExternalNameConflict,
1656 "The global entity '%s' corresponding to the local procedure '%s' is not a callable subprogram"_warn_en_US,
1657 global->name(), symbol.name());
1658 }
1659 } else if (auto chars{Characterize(symbol)}) {
1660 if (auto globalChars{Characterize(*global)}) {
1661 if (chars->HasExplicitInterface()) {
1662 std::string whyNot;
1663 if (!chars->IsCompatibleWith(*globalChars,
1664 /*ignoreImplicitVsExplicit=*/false, &whyNot)) {
1665 msg = Warn(common::UsageWarning::ExternalInterfaceMismatch,
1666 "The global subprogram '%s' is not compatible with its local procedure declaration (%s)"_warn_en_US,
1667 global->name(), whyNot);
1668 }
1669 } else if (!globalChars->CanBeCalledViaImplicitInterface()) {
1670 // TODO: This should be a hard error if the procedure has
1671 // actually been called (as opposed to just being used as a
1672 // procedure pointer target or passed as an actual argument).
1673 msg = Warn(common::UsageWarning::ExternalInterfaceMismatch,
1674 "The global subprogram '%s' should not be referenced via the implicit interface '%s'"_warn_en_US,
1675 global->name(), symbol.name());
1676 }
1677 }
1678 }
1679 if (msg) {
1680 if (msg->IsFatal()) {
1681 context_.SetError(symbol);
1682 }
1683 evaluate::AttachDeclaration(msg, *global);
1684 evaluate::AttachDeclaration(msg, symbol);
1685 }
1686 }
1687 } else if (auto iter{externalNames_.find(interfaceName)};
1688 iter != externalNames_.end()) {
1689 const Symbol &previous{*iter->second};
1690 if (auto chars{Characterize(symbol)}) {
1691 if (auto previousChars{Characterize(previous)}) {
1692 std::string whyNot;
1693 if (!chars->IsCompatibleWith(*previousChars,
1694 /*ignoreImplicitVsExplicit=*/false, &whyNot)) {
1695 if (auto *msg{Warn(common::UsageWarning::ExternalInterfaceMismatch,
1696 "The external interface '%s' is not compatible with an earlier definition (%s)"_warn_en_US,
1697 symbol.name(), whyNot)}) {
1698 evaluate::AttachDeclaration(msg, previous);
1699 evaluate::AttachDeclaration(msg, symbol);
1700 }
1701 }
1702 }
1703 }
1704 } else {
1705 externalNames_.emplace(interfaceName, symbol);
1706 }
1707 }
1708}
1709
1710void CheckHelper::CheckDerivedType(
1711 const Symbol &derivedType, const DerivedTypeDetails &details) {
1712 if (details.isForwardReferenced() && !context_.HasError(derivedType)) {
1713 messages_.Say("The derived type '%s' has not been defined"_err_en_US,
1714 derivedType.name());
1715 }
1716 const Scope *scope{derivedType.scope()};
1717 if (!scope) {
1718 CHECK(details.isForwardReferenced());
1719 return;
1720 }
1721 CHECK(scope->symbol() == &derivedType);
1722 CHECK(scope->IsDerivedType());
1723 if (derivedType.attrs().test(Attr::ABSTRACT) && // C734
1724 (derivedType.attrs().test(Attr::BIND_C) || details.sequence())) {
1725 messages_.Say("An ABSTRACT derived type must be extensible"_err_en_US);
1726 }
1727 if (const DeclTypeSpec *parent{FindParentTypeSpec(derivedType)}) {
1728 const DerivedTypeSpec *parentDerived{parent->AsDerived()};
1729 if (!IsExtensibleType(parentDerived)) { // C705
1730 messages_.Say("The parent type is not extensible"_err_en_US);
1731 }
1732 if (!derivedType.attrs().test(Attr::ABSTRACT) && parentDerived &&
1733 parentDerived->typeSymbol().attrs().test(Attr::ABSTRACT)) {
1734 ScopeComponentIterator components{*parentDerived};
1735 for (const Symbol &component : components) {
1736 if (component.attrs().test(Attr::DEFERRED)) {
1737 if (scope->FindComponent(component.name()) == &component) {
1738 SayWithDeclaration(component,
1739 "Non-ABSTRACT extension of ABSTRACT derived type '%s' lacks a binding for DEFERRED procedure '%s'"_err_en_US,
1740 parentDerived->typeSymbol().name(), component.name());
1741 }
1742 }
1743 }
1744 }
1745 DerivedTypeSpec derived{derivedType.name(), derivedType};
1746 derived.set_scope(*scope);
1747 if (FindCoarrayUltimateComponent(derived) && // C736
1748 !(parentDerived && FindCoarrayUltimateComponent(*parentDerived))) {
1749 messages_.Say(
1750 "Type '%s' has a coarray ultimate component so the type at the base "
1751 "of its type extension chain ('%s') must be a type that has a "
1752 "coarray ultimate component"_err_en_US,
1753 derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name());
1754 }
1755 if (FindEventOrLockPotentialComponent(derived) && // C737
1756 !(FindEventOrLockPotentialComponent(*parentDerived) ||
1757 IsEventTypeOrLockType(parentDerived))) {
1758 messages_.Say(
1759 "Type '%s' has an EVENT_TYPE or LOCK_TYPE component, so the type "
1760 "at the base of its type extension chain ('%s') must either have an "
1761 "EVENT_TYPE or LOCK_TYPE component, or be EVENT_TYPE or "
1762 "LOCK_TYPE"_err_en_US,
1763 derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name());
1764 }
1765 }
1766 if (HasIntrinsicTypeName(derivedType)) { // C729
1767 messages_.Say("A derived type name cannot be the name of an intrinsic"
1768 " type"_err_en_US);
1769 }
1770 std::map<SourceName, SymbolRef> previous;
1771 for (const auto &pair : details.finals()) {
1772 SourceName source{pair.first};
1773 const Symbol &ref{*pair.second};
1774 if (CheckFinal(ref, source, derivedType) &&
1775 std::all_of(previous.begin(), previous.end(),
1776 [&](std::pair<SourceName, SymbolRef> prev) {
1777 return CheckDistinguishableFinals(
1778 ref, source, *prev.second, prev.first, derivedType);
1779 })) {
1780 previous.emplace(source, ref);
1781 }
1782 }
1783}
1784
1785// C786
1786bool CheckHelper::CheckFinal(
1787 const Symbol &subroutine, SourceName finalName, const Symbol &derivedType) {
1788 if (!IsModuleProcedure(subroutine)) {
1789 SayWithDeclaration(subroutine, finalName,
1790 "FINAL subroutine '%s' of derived type '%s' must be a module procedure"_err_en_US,
1791 subroutine.name(), derivedType.name());
1792 return false;
1793 }
1794 const Procedure *proc{Characterize(subroutine)};
1795 if (!proc) {
1796 return false; // error recovery
1797 }
1798 if (!proc->IsSubroutine()) {
1799 SayWithDeclaration(subroutine, finalName,
1800 "FINAL subroutine '%s' of derived type '%s' must be a subroutine"_err_en_US,
1801 subroutine.name(), derivedType.name());
1802 return false;
1803 }
1804 if (proc->dummyArguments.size() != 1) {
1805 SayWithDeclaration(subroutine, finalName,
1806 "FINAL subroutine '%s' of derived type '%s' must have a single dummy argument"_err_en_US,
1807 subroutine.name(), derivedType.name());
1808 return false;
1809 }
1810 const auto &arg{proc->dummyArguments[0]};
1811 const Symbol *errSym{&subroutine};
1812 if (const auto *details{subroutine.detailsIf<SubprogramDetails>()}) {
1813 if (!details->dummyArgs().empty()) {
1814 if (const Symbol *argSym{details->dummyArgs()[0]}) {
1815 errSym = argSym;
1816 }
1817 }
1818 }
1819 const auto *ddo{std::get_if<DummyDataObject>(&arg.u)};
1820 if (!ddo) {
1821 SayWithDeclaration(subroutine, finalName,
1822 "FINAL subroutine '%s' of derived type '%s' must have a single dummy argument that is a data object"_err_en_US,
1823 subroutine.name(), derivedType.name());
1824 return false;
1825 }
1826 bool ok{true};
1827 if (arg.IsOptional()) {
1828 SayWithDeclaration(*errSym, finalName,
1829 "FINAL subroutine '%s' of derived type '%s' must not have an OPTIONAL dummy argument"_err_en_US,
1830 subroutine.name(), derivedType.name());
1831 ok = false;
1832 }
1833 if (ddo->attrs.test(DummyDataObject::Attr::Allocatable)) {
1834 SayWithDeclaration(*errSym, finalName,
1835 "FINAL subroutine '%s' of derived type '%s' must not have an ALLOCATABLE dummy argument"_err_en_US,
1836 subroutine.name(), derivedType.name());
1837 ok = false;
1838 }
1839 if (ddo->attrs.test(DummyDataObject::Attr::Pointer)) {
1840 SayWithDeclaration(*errSym, finalName,
1841 "FINAL subroutine '%s' of derived type '%s' must not have a POINTER dummy argument"_err_en_US,
1842 subroutine.name(), derivedType.name());
1843 ok = false;
1844 }
1845 if (ddo->intent == common::Intent::Out) {
1846 SayWithDeclaration(*errSym, finalName,
1847 "FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with INTENT(OUT)"_err_en_US,
1848 subroutine.name(), derivedType.name());
1849 ok = false;
1850 }
1851 if (ddo->attrs.test(DummyDataObject::Attr::Value)) {
1852 SayWithDeclaration(*errSym, finalName,
1853 "FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with the VALUE attribute"_err_en_US,
1854 subroutine.name(), derivedType.name());
1855 ok = false;
1856 }
1857 if (ddo->type.corank() > 0) {
1858 SayWithDeclaration(*errSym, finalName,
1859 "FINAL subroutine '%s' of derived type '%s' must not have a coarray dummy argument"_err_en_US,
1860 subroutine.name(), derivedType.name());
1861 ok = false;
1862 }
1863 if (ddo->type.type().IsPolymorphic()) {
1864 SayWithDeclaration(*errSym, finalName,
1865 "FINAL subroutine '%s' of derived type '%s' must not have a polymorphic dummy argument"_err_en_US,
1866 subroutine.name(), derivedType.name());
1867 ok = false;
1868 } else if (ddo->type.type().category() != TypeCategory::Derived ||
1869 &ddo->type.type().GetDerivedTypeSpec().typeSymbol() != &derivedType) {
1870 SayWithDeclaration(*errSym, finalName,
1871 "FINAL subroutine '%s' of derived type '%s' must have a TYPE(%s) dummy argument"_err_en_US,
1872 subroutine.name(), derivedType.name(), derivedType.name());
1873 ok = false;
1874 } else { // check that all LEN type parameters are assumed
1875 for (auto ref : OrderParameterDeclarations(derivedType)) {
1876 if (IsLenTypeParameter(*ref)) {
1877 const auto *value{
1878 ddo->type.type().GetDerivedTypeSpec().FindParameter(ref->name())};
1879 if (!value || !value->isAssumed()) {
1880 SayWithDeclaration(*errSym, finalName,
1881 "FINAL subroutine '%s' of derived type '%s' must have a dummy argument with an assumed LEN type parameter '%s=*'"_err_en_US,
1882 subroutine.name(), derivedType.name(), ref->name());
1883 ok = false;
1884 }
1885 }
1886 }
1887 }
1888 return ok;
1889}
1890
1891bool CheckHelper::CheckDistinguishableFinals(const Symbol &f1,
1892 SourceName f1Name, const Symbol &f2, SourceName f2Name,
1893 const Symbol &derivedType) {
1894 const Procedure *p1{Characterize(f1)};
1895 const Procedure *p2{Characterize(f2)};
1896 if (p1 && p2) {
1897 std::optional<bool> areDistinct{characteristics::Distinguishable(
1898 context_.languageFeatures(), *p1, *p2)};
1899 if (areDistinct.value_or(u: false)) {
1900 return true;
1901 }
1902 if (auto *msg{messages_.Say(f1Name,
1903 "FINAL subroutines '%s' and '%s' of derived type '%s' cannot be distinguished by rank or KIND type parameter value"_err_en_US,
1904 f1Name, f2Name, derivedType.name())}) {
1905 msg->Attach(f2Name, "FINAL declaration of '%s'"_en_US, f2.name())
1906 .Attach(f1.name(), "Definition of '%s'"_en_US, f1Name)
1907 .Attach(f2.name(), "Definition of '%s'"_en_US, f2Name);
1908 }
1909 }
1910 return false;
1911}
1912
1913void CheckHelper::CheckHostAssoc(
1914 const Symbol &symbol, const HostAssocDetails &details) {
1915 const Symbol &hostSymbol{details.symbol()};
1916 if (hostSymbol.test(Symbol::Flag::ImplicitOrError)) {
1917 if (details.implicitOrSpecExprError) {
1918 messages_.Say("Implicitly typed local entity '%s' not allowed in"
1919 " specification expression"_err_en_US,
1920 symbol.name());
1921 } else if (details.implicitOrExplicitTypeError) {
1922 messages_.Say(
1923 "No explicit type declared for '%s'"_err_en_US, symbol.name());
1924 }
1925 }
1926}
1927
1928void CheckHelper::CheckGeneric(
1929 const Symbol &symbol, const GenericDetails &details) {
1930 CheckSpecifics(symbol, details);
1931 common::visit(common::visitors{
1932 [&](const common::DefinedIo &io) {
1933 CheckDefinedIoProc(symbol, details, io);
1934 },
1935 [&](const GenericKind::OtherKind &other) {
1936 if (other == GenericKind::OtherKind::Name) {
1937 CheckGenericVsIntrinsic(symbol, details);
1938 }
1939 },
1940 [](const auto &) {},
1941 },
1942 details.kind().u);
1943 // Ensure that shadowed symbols are checked
1944 if (details.specific()) {
1945 Check(*details.specific());
1946 }
1947 if (details.derivedType()) {
1948 Check(*details.derivedType());
1949 }
1950}
1951
1952// Check that the specifics of this generic are distinguishable from each other
1953void CheckHelper::CollectSpecifics(DistinguishabilityHelper &helper,
1954 const Symbol &generic, const GenericDetails &details) {
1955 GenericKind kind{details.kind()};
1956 for (const Symbol &specific : details.specificProcs()) {
1957 if (specific.attrs().test(Attr::ABSTRACT)) {
1958 if (auto *msg{messages_.Say(generic.name(),
1959 "Generic interface '%s' must not use abstract interface '%s' as a specific procedure"_err_en_US,
1960 generic.name(), specific.name())}) {
1961 msg->Attach(
1962 specific.name(), "Definition of '%s'"_en_US, specific.name());
1963 }
1964 continue;
1965 }
1966 if (specific.attrs().test(Attr::INTRINSIC)) {
1967 // GNU Fortran allows INTRINSIC procedures in generics.
1968 auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
1969 specific.name().ToString())};
1970 if (intrinsic && !intrinsic->isRestrictedSpecific) {
1971 if (auto *msg{Warn(common::LanguageFeature::IntrinsicAsSpecific,
1972 specific.name(),
1973 "Specific procedure '%s' of generic interface '%s' should not be INTRINSIC"_port_en_US,
1974 specific.name(), generic.name())}) {
1975 msg->Attach(
1976 generic.name(), "Definition of '%s'"_en_US, generic.name());
1977 }
1978 } else {
1979 if (auto *msg{Warn(common::LanguageFeature::IntrinsicAsSpecific,
1980 specific.name(),
1981 "Procedure '%s' of generic interface '%s' is INTRINSIC but not an unrestricted specific intrinsic function"_port_en_US,
1982 specific.name(), generic.name())}) {
1983 msg->Attach(
1984 generic.name(), "Definition of '%s'"_en_US, generic.name());
1985 }
1986 continue;
1987 }
1988 }
1989 if (IsStmtFunction(specific)) {
1990 if (auto *msg{messages_.Say(specific.name(),
1991 "Specific procedure '%s' of generic interface '%s' may not be a statement function"_err_en_US,
1992 specific.name(), generic.name())}) {
1993 msg->Attach(generic.name(), "Definition of '%s'"_en_US, generic.name());
1994 }
1995 continue;
1996 }
1997 if (const Procedure *procedure{Characterize(specific)}) {
1998 if (procedure->HasExplicitInterface()) {
1999 helper.Add(generic, kind, specific, *procedure);
2000 } else {
2001 if (auto *msg{messages_.Say(specific.name(),
2002 "Specific procedure '%s' of generic interface '%s' must have an explicit interface"_err_en_US,
2003 specific.name(), generic.name())}) {
2004 msg->Attach(
2005 generic.name(), "Definition of '%s'"_en_US, generic.name());
2006 }
2007 }
2008 }
2009 }
2010 if (const Scope * parent{generic.owner().GetDerivedTypeParent()}) {
2011 if (const Symbol * inherited{parent->FindComponent(generic.name())}) {
2012 if (IsAccessible(*inherited, generic.owner().parent())) {
2013 if (const auto *details{inherited->detailsIf<GenericDetails>()}) {
2014 // Include specifics of inherited generic of the same name, too
2015 CollectSpecifics(helper, *inherited, *details);
2016 }
2017 }
2018 }
2019 }
2020}
2021
2022void CheckHelper::CheckSpecifics(
2023 const Symbol &generic, const GenericDetails &details) {
2024 DistinguishabilityHelper helper{context_};
2025 CollectSpecifics(helper, generic, details);
2026 helper.Check(generic.owner());
2027}
2028
2029static bool CUDAHostDeviceDiffer(
2030 const Procedure &proc, const DummyDataObject &arg) {
2031 auto procCUDA{
2032 proc.cudaSubprogramAttrs.value_or(common::CUDASubprogramAttrs::Host)};
2033 bool procIsHostOnly{procCUDA == common::CUDASubprogramAttrs::Host};
2034 bool procIsDeviceOnly{
2035 !procIsHostOnly && procCUDA != common::CUDASubprogramAttrs::HostDevice};
2036 const auto &argCUDA{arg.cudaDataAttr};
2037 bool argIsHostOnly{!argCUDA || *argCUDA == common::CUDADataAttr::Pinned};
2038 bool argIsDeviceOnly{(!argCUDA && procIsDeviceOnly) ||
2039 (argCUDA &&
2040 (*argCUDA != common::CUDADataAttr::Managed &&
2041 *argCUDA != common::CUDADataAttr::Pinned &&
2042 *argCUDA != common::CUDADataAttr::Unified))};
2043 return (procIsHostOnly && argIsDeviceOnly) ||
2044 (procIsDeviceOnly && argIsHostOnly);
2045}
2046
2047static bool ConflictsWithIntrinsicAssignment(const Procedure &proc) {
2048 const auto &lhsData{std::get<DummyDataObject>(proc.dummyArguments[0].u)};
2049 const auto &lhsTnS{lhsData.type};
2050 const auto &rhsData{std::get<DummyDataObject>(proc.dummyArguments[1].u)};
2051 const auto &rhsTnS{rhsData.type};
2052 return !CUDAHostDeviceDiffer(proc, lhsData) &&
2053 !CUDAHostDeviceDiffer(proc, rhsData) &&
2054 Tristate::No ==
2055 IsDefinedAssignment(
2056 lhsTnS.type(), lhsTnS.Rank(), rhsTnS.type(), rhsTnS.Rank());
2057}
2058
2059static bool ConflictsWithIntrinsicOperator(
2060 const GenericKind &kind, const Procedure &proc) {
2061 if (!kind.IsIntrinsicOperator()) {
2062 return false;
2063 }
2064 const auto &arg0Data{std::get<DummyDataObject>(proc.dummyArguments[0].u)};
2065 if (CUDAHostDeviceDiffer(proc, arg0Data)) {
2066 return false;
2067 }
2068 const auto &arg0TnS{arg0Data.type};
2069 auto type0{arg0TnS.type()};
2070 if (proc.dummyArguments.size() == 1) { // unary
2071 return common::visit(
2072 common::visitors{
2073 [&](common::NumericOperator) { return IsIntrinsicNumeric(type0); },
2074 [&](common::LogicalOperator) { return IsIntrinsicLogical(type0); },
2075 [](const auto &) -> bool { DIE("bad generic kind"); },
2076 },
2077 kind.u);
2078 } else { // binary
2079 int rank0{arg0TnS.Rank()};
2080 const auto &arg1Data{std::get<DummyDataObject>(proc.dummyArguments[1].u)};
2081 if (CUDAHostDeviceDiffer(proc, arg1Data)) {
2082 return false;
2083 }
2084 const auto &arg1TnS{arg1Data.type};
2085 auto type1{arg1TnS.type()};
2086 int rank1{arg1TnS.Rank()};
2087 return common::visit(
2088 common::visitors{
2089 [&](common::NumericOperator) {
2090 return IsIntrinsicNumeric(type0, rank0, type1, rank1);
2091 },
2092 [&](common::LogicalOperator) {
2093 return IsIntrinsicLogical(type0, rank0, type1, rank1);
2094 },
2095 [&](common::RelationalOperator opr) {
2096 return IsIntrinsicRelational(opr, type0, rank0, type1, rank1);
2097 },
2098 [&](GenericKind::OtherKind x) {
2099 CHECK(x == GenericKind::OtherKind::Concat);
2100 return IsIntrinsicConcat(type0, rank0, type1, rank1);
2101 },
2102 [](const auto &) -> bool { DIE("bad generic kind"); },
2103 },
2104 kind.u);
2105 }
2106}
2107
2108// Check if this procedure can be used for defined operators (see 15.4.3.4.2).
2109bool CheckHelper::CheckDefinedOperator(SourceName opName, GenericKind kind,
2110 const Symbol &specific, const Procedure &proc) {
2111 if (context_.HasError(specific)) {
2112 return false;
2113 }
2114 std::optional<parser::MessageFixedText> msg;
2115 auto checkDefinedOperatorArgs{
2116 [&](SourceName opName, const Symbol &specific, const Procedure &proc) {
2117 bool arg0Defined{CheckDefinedOperatorArg(opName, specific, proc, 0)};
2118 bool arg1Defined{CheckDefinedOperatorArg(opName, specific, proc, 1)};
2119 return arg0Defined && arg1Defined;
2120 }};
2121 if (specific.attrs().test(Attr::NOPASS)) { // C774
2122 msg = "%s procedure '%s' may not have NOPASS attribute"_err_en_US;
2123 } else if (!proc.functionResult.has_value()) {
2124 msg = "%s procedure '%s' must be a function"_err_en_US;
2125 } else if (proc.functionResult->IsAssumedLengthCharacter()) {
2126 const auto *subpDetails{specific.detailsIf<SubprogramDetails>()};
2127 if (subpDetails && !subpDetails->isDummy() && subpDetails->isInterface()) {
2128 // Error is caught by more general test for interfaces with
2129 // assumed-length character function results
2130 return true;
2131 }
2132 msg = "%s function '%s' may not have assumed-length CHARACTER(*)"
2133 " result"_err_en_US;
2134 } else if (auto m{CheckNumberOfArgs(kind, proc.dummyArguments.size())}) {
2135 if (m->IsFatal()) {
2136 msg = *m;
2137 } else {
2138 evaluate::AttachDeclaration(
2139 Warn(common::UsageWarning::DefinedOperatorArgs, specific.name(),
2140 std::move(*m), MakeOpName(opName), specific.name()),
2141 specific);
2142 return true;
2143 }
2144 } else if (!checkDefinedOperatorArgs(opName, specific, proc)) {
2145 return false; // error was reported
2146 } else if (ConflictsWithIntrinsicOperator(kind, proc)) {
2147 msg = "%s function '%s' conflicts with intrinsic operator"_err_en_US;
2148 }
2149 if (msg) {
2150 SayWithDeclaration(
2151 specific, std::move(*msg), MakeOpName(opName), specific.name());
2152 context_.SetError(specific);
2153 return false;
2154 }
2155 return true;
2156}
2157
2158// If the number of arguments is wrong for this intrinsic operator, return
2159// false and return the error message in msg.
2160std::optional<parser::MessageFixedText> CheckHelper::CheckNumberOfArgs(
2161 const GenericKind &kind, std::size_t nargs) {
2162 if (!kind.IsIntrinsicOperator()) {
2163 if (nargs < 1 || nargs > 2) {
2164 if (context_.ShouldWarn(common::UsageWarning::DefinedOperatorArgs)) {
2165 return "%s function '%s' should have 1 or 2 dummy arguments"_warn_en_US;
2166 }
2167 }
2168 return std::nullopt;
2169 }
2170 std::size_t min{2}, max{2}; // allowed number of args; default is binary
2171 common::visit(common::visitors{
2172 [&](const common::NumericOperator &x) {
2173 if (x == common::NumericOperator::Add ||
2174 x == common::NumericOperator::Subtract) {
2175 min = 1; // + and - are unary or binary
2176 }
2177 },
2178 [&](const common::LogicalOperator &x) {
2179 if (x == common::LogicalOperator::Not) {
2180 min = 1; // .NOT. is unary
2181 max = 1;
2182 }
2183 },
2184 [](const common::RelationalOperator &) {
2185 // all are binary
2186 },
2187 [](const GenericKind::OtherKind &x) {
2188 CHECK(x == GenericKind::OtherKind::Concat);
2189 },
2190 [](const auto &) { DIE("expected intrinsic operator"); },
2191 },
2192 kind.u);
2193 if (nargs >= min && nargs <= max) {
2194 return std::nullopt;
2195 } else if (max == 1) {
2196 return "%s function '%s' must have one dummy argument"_err_en_US;
2197 } else if (min == 2) {
2198 return "%s function '%s' must have two dummy arguments"_err_en_US;
2199 } else {
2200 return "%s function '%s' must have one or two dummy arguments"_err_en_US;
2201 }
2202}
2203
2204bool CheckHelper::CheckDefinedOperatorArg(const SourceName &opName,
2205 const Symbol &symbol, const Procedure &proc, std::size_t pos) {
2206 if (pos >= proc.dummyArguments.size()) {
2207 return true;
2208 }
2209 auto &arg{proc.dummyArguments.at(pos)};
2210 std::optional<parser::MessageFixedText> msg;
2211 if (arg.IsOptional()) {
2212 msg =
2213 "In %s function '%s', dummy argument '%s' may not be OPTIONAL"_err_en_US;
2214 } else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)};
2215 dataObject == nullptr) {
2216 msg =
2217 "In %s function '%s', dummy argument '%s' must be a data object"_err_en_US;
2218 } else if (dataObject->intent == common::Intent::Out) {
2219 msg =
2220 "In %s function '%s', dummy argument '%s' may not be INTENT(OUT)"_err_en_US;
2221 } else if (dataObject->intent != common::Intent::In &&
2222 !dataObject->attrs.test(DummyDataObject::Attr::Value)) {
2223 evaluate::AttachDeclaration(
2224 Warn(common::UsageWarning::DefinedOperatorArgs,
2225 "In %s function '%s', dummy argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US,
2226 parser::ToUpperCaseLetters(opName.ToString()), symbol.name(),
2227 arg.name),
2228 symbol);
2229 return true;
2230 }
2231 if (msg) {
2232 SayWithDeclaration(symbol, std::move(*msg),
2233 parser::ToUpperCaseLetters(opName.ToString()), symbol.name(), arg.name);
2234 return false;
2235 }
2236 return true;
2237}
2238
2239// Check if this procedure can be used for defined assignment (see 15.4.3.4.3).
2240bool CheckHelper::CheckDefinedAssignment(
2241 const Symbol &specific, const Procedure &proc) {
2242 if (context_.HasError(specific)) {
2243 return false;
2244 }
2245 std::optional<parser::MessageFixedText> msg;
2246 if (specific.attrs().test(Attr::NOPASS)) { // C774
2247 msg = "Defined assignment procedure '%s' may not have"
2248 " NOPASS attribute"_err_en_US;
2249 } else if (!proc.IsSubroutine()) {
2250 msg = "Defined assignment procedure '%s' must be a subroutine"_err_en_US;
2251 } else if (proc.dummyArguments.size() != 2) {
2252 msg = "Defined assignment subroutine '%s' must have"
2253 " two dummy arguments"_err_en_US;
2254 } else {
2255 // Check both arguments even if the first has an error.
2256 bool ok0{CheckDefinedAssignmentArg(specific, proc.dummyArguments[0], 0)};
2257 bool ok1{CheckDefinedAssignmentArg(specific, proc.dummyArguments[1], 1)};
2258 if (!(ok0 && ok1)) {
2259 return false; // error was reported
2260 } else if (ConflictsWithIntrinsicAssignment(proc)) {
2261 msg =
2262 "Defined assignment subroutine '%s' conflicts with intrinsic assignment"_err_en_US;
2263 } else {
2264 return true; // OK
2265 }
2266 }
2267 SayWithDeclaration(specific, std::move(msg.value()), specific.name());
2268 context_.SetError(specific);
2269 return false;
2270}
2271
2272bool CheckHelper::CheckDefinedAssignmentArg(
2273 const Symbol &symbol, const DummyArgument &arg, int pos) {
2274 std::optional<parser::MessageFixedText> msg;
2275 if (arg.IsOptional()) {
2276 msg = "In defined assignment subroutine '%s', dummy argument '%s'"
2277 " may not be OPTIONAL"_err_en_US;
2278 } else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)}) {
2279 if (pos == 0) {
2280 if (dataObject->intent == common::Intent::In) {
2281 msg = "In defined assignment subroutine '%s', first dummy argument '%s'"
2282 " may not have INTENT(IN)"_err_en_US;
2283 } else if (dataObject->intent != common::Intent::Out &&
2284 dataObject->intent != common::Intent::InOut) {
2285 msg =
2286 "In defined assignment subroutine '%s', first dummy argument '%s' should have INTENT(OUT) or INTENT(INOUT)"_warn_en_US;
2287 }
2288 } else if (pos == 1) {
2289 if (dataObject->intent == common::Intent::Out) {
2290 msg = "In defined assignment subroutine '%s', second dummy"
2291 " argument '%s' may not have INTENT(OUT)"_err_en_US;
2292 } else if (dataObject->intent != common::Intent::In &&
2293 !dataObject->attrs.test(DummyDataObject::Attr::Value)) {
2294 msg =
2295 "In defined assignment subroutine '%s', second dummy argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US;
2296 } else if (dataObject->attrs.test(DummyDataObject::Attr::Pointer)) {
2297 msg =
2298 "In defined assignment subroutine '%s', second dummy argument '%s' must not be a pointer"_err_en_US;
2299 } else if (dataObject->attrs.test(DummyDataObject::Attr::Allocatable)) {
2300 msg =
2301 "In defined assignment subroutine '%s', second dummy argument '%s' must not be an allocatable"_err_en_US;
2302 }
2303 } else {
2304 DIE("pos must be 0 or 1");
2305 }
2306 } else {
2307 msg = "In defined assignment subroutine '%s', dummy argument '%s'"
2308 " must be a data object"_err_en_US;
2309 }
2310 if (msg) {
2311 if (msg->IsFatal()) {
2312 SayWithDeclaration(symbol, std::move(*msg), symbol.name(), arg.name);
2313 context_.SetError(symbol);
2314 return false;
2315 } else {
2316 evaluate::AttachDeclaration(
2317 Warn(common::UsageWarning::DefinedOperatorArgs, std::move(*msg),
2318 symbol.name(), arg.name),
2319 symbol);
2320 }
2321 }
2322 return true;
2323}
2324
2325// Report a conflicting attribute error if symbol has both of these attributes
2326bool CheckHelper::CheckConflicting(const Symbol &symbol, Attr a1, Attr a2) {
2327 if (symbol.attrs().test(a1) && symbol.attrs().test(a2)) {
2328 messages_.Say("'%s' may not have both the %s and %s attributes"_err_en_US,
2329 symbol.name(), AttrToString(a1), AttrToString(a2));
2330 return true;
2331 } else {
2332 return false;
2333 }
2334}
2335
2336void CheckHelper::WarnMissingFinal(const Symbol &symbol) {
2337 const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
2338 if (!object || object->IsAssumedRank() ||
2339 (!IsAutomaticallyDestroyed(symbol) &&
2340 symbol.owner().kind() != Scope::Kind::DerivedType)) {
2341 return;
2342 }
2343 const DeclTypeSpec *type{object->type()};
2344 const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
2345 const Symbol *derivedSym{derived ? &derived->typeSymbol() : nullptr};
2346 int rank{object->shape().Rank()};
2347 const Symbol *initialDerivedSym{derivedSym};
2348 while (const auto *derivedDetails{
2349 derivedSym ? derivedSym->detailsIf<DerivedTypeDetails>() : nullptr}) {
2350 if (!derivedDetails->finals().empty() &&
2351 !derivedDetails->GetFinalForRank(rank)) {
2352 if (auto *msg{derivedSym == initialDerivedSym
2353 ? Warn(common::UsageWarning::Final, symbol.name(),
2354 "'%s' of derived type '%s' does not have a FINAL subroutine for its rank (%d)"_warn_en_US,
2355 symbol.name(), derivedSym->name(), rank)
2356 : Warn(common::UsageWarning::Final, symbol.name(),
2357 "'%s' of derived type '%s' extended from '%s' does not have a FINAL subroutine for its rank (%d)"_warn_en_US,
2358 symbol.name(), initialDerivedSym->name(),
2359 derivedSym->name(), rank)}) {
2360 msg->Attach(derivedSym->name(),
2361 "Declaration of derived type '%s'"_en_US, derivedSym->name());
2362 }
2363 return;
2364 }
2365 derived = derivedSym->GetParentTypeSpec();
2366 derivedSym = derived ? &derived->typeSymbol() : nullptr;
2367 }
2368}
2369
2370const Procedure *CheckHelper::Characterize(const Symbol &symbol) {
2371 auto it{characterizeCache_.find(symbol)};
2372 if (it == characterizeCache_.end()) {
2373 auto pair{characterizeCache_.emplace(SymbolRef{symbol},
2374 Procedure::Characterize(symbol, context_.foldingContext()))};
2375 it = pair.first;
2376 }
2377 return common::GetPtrFromOptional(it->second);
2378}
2379
2380void CheckHelper::CheckVolatile(const Symbol &symbol,
2381 const DerivedTypeSpec *derived) { // C866 - C868
2382 if (IsIntentIn(symbol)) {
2383 messages_.Say(
2384 "VOLATILE attribute may not apply to an INTENT(IN) argument"_err_en_US);
2385 }
2386 if (IsProcedure(symbol)) {
2387 messages_.Say("VOLATILE attribute may apply only to a variable"_err_en_US);
2388 }
2389 if (symbol.has<UseDetails>() || symbol.has<HostAssocDetails>()) {
2390 const Symbol &ultimate{symbol.GetUltimate()};
2391 if (evaluate::IsCoarray(ultimate)) {
2392 messages_.Say(
2393 "VOLATILE attribute may not apply to a coarray accessed by USE or host association"_err_en_US);
2394 }
2395 if (derived) {
2396 if (FindCoarrayUltimateComponent(*derived)) {
2397 messages_.Say(
2398 "VOLATILE attribute may not apply to a type with a coarray ultimate component accessed by USE or host association"_err_en_US);
2399 }
2400 }
2401 }
2402}
2403
2404void CheckHelper::CheckContiguous(const Symbol &symbol) {
2405 if (evaluate::IsVariable(symbol) &&
2406 ((IsPointer(symbol) && symbol.Rank() > 0) || IsAssumedShape(symbol) ||
2407 evaluate::IsAssumedRank(symbol))) {
2408 } else {
2409 parser::MessageFixedText msg{symbol.owner().IsDerivedType()
2410 ? "CONTIGUOUS component '%s' should be an array with the POINTER attribute"_port_en_US
2411 : "CONTIGUOUS entity '%s' should be an array pointer, assumed-shape, or assumed-rank"_port_en_US};
2412 if (!context_.IsEnabled(common::LanguageFeature::RedundantContiguous)) {
2413 msg.set_severity(parser::Severity::Error);
2414 messages_.Say(std::move(msg), symbol.name());
2415 } else {
2416 Warn(common::LanguageFeature::RedundantContiguous, std::move(msg),
2417 symbol.name());
2418 }
2419 }
2420}
2421
2422void CheckHelper::CheckPointer(const Symbol &symbol) { // C852
2423 CheckConflicting(symbol, Attr::POINTER, Attr::TARGET);
2424 CheckConflicting(symbol, Attr::POINTER, Attr::ALLOCATABLE); // C751
2425 CheckConflicting(symbol, Attr::POINTER, Attr::INTRINSIC);
2426 // Prohibit constant pointers. The standard does not explicitly prohibit
2427 // them, but the PARAMETER attribute requires a entity-decl to have an
2428 // initialization that is a constant-expr, and the only form of
2429 // initialization that allows a constant-expr is the one that's not a "=>"
2430 // pointer initialization. See C811, C807, and section 8.5.13.
2431 CheckConflicting(symbol, Attr::POINTER, Attr::PARAMETER);
2432 if (symbol.Corank() > 0) {
2433 messages_.Say(
2434 "'%s' may not have the POINTER attribute because it is a coarray"_err_en_US,
2435 symbol.name());
2436 }
2437}
2438
2439// C760 constraints on the passed-object dummy argument
2440// C757 constraints on procedure pointer components
2441void CheckHelper::CheckPassArg(
2442 const Symbol &proc, const Symbol *interface0, const WithPassArg &details) {
2443 if (proc.attrs().test(Attr::NOPASS)) {
2444 return;
2445 }
2446 const auto &name{proc.name()};
2447 const Symbol *interface {
2448 interface0 ? FindInterface(*interface0) : nullptr
2449 };
2450 if (!interface) {
2451 messages_.Say(name,
2452 "Procedure component '%s' must have NOPASS attribute or explicit interface"_err_en_US,
2453 name);
2454 return;
2455 }
2456 const auto *subprogram{interface->detailsIf<SubprogramDetails>()};
2457 if (!subprogram) {
2458 messages_.Say(name,
2459 "Procedure component '%s' has invalid interface '%s'"_err_en_US, name,
2460 interface->name());
2461 return;
2462 }
2463 std::optional<SourceName> passName{details.passName()};
2464 const auto &dummyArgs{subprogram->dummyArgs()};
2465 if (!passName) {
2466 if (dummyArgs.empty()) {
2467 messages_.Say(name,
2468 proc.has<ProcEntityDetails>()
2469 ? "Procedure component '%s' with no dummy arguments"
2470 " must have NOPASS attribute"_err_en_US
2471 : "Procedure binding '%s' with no dummy arguments"
2472 " must have NOPASS attribute"_err_en_US,
2473 name);
2474 context_.SetError(*interface);
2475 return;
2476 }
2477 Symbol *argSym{dummyArgs[0]};
2478 if (!argSym) {
2479 messages_.Say(interface->name(),
2480 "Cannot use an alternate return as the passed-object dummy "
2481 "argument"_err_en_US);
2482 return;
2483 }
2484 passName = dummyArgs[0]->name();
2485 }
2486 std::optional<int> passArgIndex{};
2487 for (std::size_t i{0}; i < dummyArgs.size(); ++i) {
2488 if (dummyArgs[i] && dummyArgs[i]->name() == *passName) {
2489 passArgIndex = i;
2490 break;
2491 }
2492 }
2493 if (!passArgIndex) { // C758
2494 messages_.Say(*passName,
2495 "'%s' is not a dummy argument of procedure interface '%s'"_err_en_US,
2496 *passName, interface->name());
2497 return;
2498 }
2499 const Symbol &passArg{*dummyArgs[*passArgIndex]};
2500 std::optional<parser::MessageFixedText> msg;
2501 if (!passArg.has<ObjectEntityDetails>()) {
2502 msg = "Passed-object dummy argument '%s' of procedure '%s'"
2503 " must be a data object"_err_en_US;
2504 } else if (passArg.attrs().test(Attr::POINTER)) {
2505 msg = "Passed-object dummy argument '%s' of procedure '%s'"
2506 " may not have the POINTER attribute"_err_en_US;
2507 } else if (passArg.attrs().test(Attr::ALLOCATABLE)) {
2508 msg = "Passed-object dummy argument '%s' of procedure '%s'"
2509 " may not have the ALLOCATABLE attribute"_err_en_US;
2510 } else if (passArg.attrs().test(Attr::VALUE)) {
2511 msg = "Passed-object dummy argument '%s' of procedure '%s'"
2512 " may not have the VALUE attribute"_err_en_US;
2513 } else if (passArg.Rank() > 0) {
2514 msg = "Passed-object dummy argument '%s' of procedure '%s'"
2515 " must be scalar"_err_en_US;
2516 }
2517 if (msg) {
2518 messages_.Say(name, std::move(*msg), passName.value(), name);
2519 return;
2520 }
2521 const DeclTypeSpec *type{passArg.GetType()};
2522 if (!type) {
2523 return; // an error already occurred
2524 }
2525 const Symbol &typeSymbol{*proc.owner().GetSymbol()};
2526 const DerivedTypeSpec *derived{type->AsDerived()};
2527 if (!derived || derived->typeSymbol() != typeSymbol) {
2528 messages_.Say(name,
2529 "Passed-object dummy argument '%s' of procedure '%s'"
2530 " must be of type '%s' but is '%s'"_err_en_US,
2531 passName.value(), name, typeSymbol.name(), type->AsFortran());
2532 return;
2533 }
2534 if (IsExtensibleType(derived) != type->IsPolymorphic()) {
2535 messages_.Say(name,
2536 type->IsPolymorphic()
2537 ? "Passed-object dummy argument '%s' of procedure '%s'"
2538 " may not be polymorphic because '%s' is not extensible"_err_en_US
2539 : "Passed-object dummy argument '%s' of procedure '%s'"
2540 " must be polymorphic because '%s' is extensible"_err_en_US,
2541 passName.value(), name, typeSymbol.name());
2542 return;
2543 }
2544 for (const auto &[paramName, paramValue] : derived->parameters()) {
2545 if (paramValue.isLen() && !paramValue.isAssumed()) {
2546 messages_.Say(name,
2547 "Passed-object dummy argument '%s' of procedure '%s'"
2548 " has non-assumed length parameter '%s'"_err_en_US,
2549 passName.value(), name, paramName);
2550 }
2551 }
2552}
2553
2554void CheckHelper::CheckProcBinding(
2555 const Symbol &symbol, const ProcBindingDetails &binding) {
2556 const Scope &dtScope{symbol.owner()};
2557 CHECK(dtScope.kind() == Scope::Kind::DerivedType);
2558 bool isInaccessibleDeferred{false};
2559 const Symbol *overridden{
2560 FindOverriddenBinding(symbol, isInaccessibleDeferred)};
2561 if (symbol.attrs().test(Attr::DEFERRED)) {
2562 if (const Symbol *dtSymbol{dtScope.symbol()}) {
2563 if (!dtSymbol->attrs().test(Attr::ABSTRACT)) { // C733
2564 SayWithDeclaration(*dtSymbol,
2565 "Procedure bound to non-ABSTRACT derived type '%s' may not be DEFERRED"_err_en_US,
2566 dtSymbol->name());
2567 }
2568 }
2569 if (symbol.attrs().test(Attr::NON_OVERRIDABLE)) {
2570 messages_.Say(
2571 "Type-bound procedure '%s' may not be both DEFERRED and NON_OVERRIDABLE"_err_en_US,
2572 symbol.name());
2573 }
2574 if (overridden && !overridden->attrs().test(Attr::DEFERRED)) {
2575 SayWithDeclaration(*overridden,
2576 "Override of non-DEFERRED '%s' must not be DEFERRED"_err_en_US,
2577 symbol.name());
2578 }
2579 }
2580 if (binding.symbol().attrs().test(Attr::INTRINSIC) &&
2581 !context_.intrinsics().IsSpecificIntrinsicFunction(
2582 binding.symbol().name().ToString())) {
2583 messages_.Say(
2584 "Intrinsic procedure '%s' is not a specific intrinsic permitted for use in the definition of binding '%s'"_err_en_US,
2585 binding.symbol().name(), symbol.name());
2586 }
2587 if (overridden) {
2588 if (isInaccessibleDeferred) {
2589 evaluate::AttachDeclaration(
2590 Warn(common::LanguageFeature::InaccessibleDeferredOverride,
2591 symbol.name(),
2592 "Override of PRIVATE DEFERRED '%s' should appear in its module"_warn_en_US,
2593 symbol.name()),
2594 *overridden);
2595 }
2596 if (overridden->attrs().test(Attr::NON_OVERRIDABLE)) {
2597 SayWithDeclaration(*overridden,
2598 "Override of NON_OVERRIDABLE '%s' is not permitted"_err_en_US,
2599 symbol.name());
2600 }
2601 if (const auto *overriddenBinding{
2602 overridden->detailsIf<ProcBindingDetails>()}) {
2603 if (!IsPureProcedure(symbol) && IsPureProcedure(*overridden)) {
2604 SayWithDeclaration(*overridden,
2605 "An overridden pure type-bound procedure binding must also be pure"_err_en_US);
2606 return;
2607 }
2608 if (!IsElementalProcedure(binding.symbol()) &&
2609 IsElementalProcedure(*overridden)) {
2610 SayWithDeclaration(*overridden,
2611 "A type-bound procedure and its override must both, or neither, be ELEMENTAL"_err_en_US);
2612 return;
2613 }
2614 bool isNopass{symbol.attrs().test(Attr::NOPASS)};
2615 if (isNopass != overridden->attrs().test(Attr::NOPASS)) {
2616 SayWithDeclaration(*overridden,
2617 isNopass
2618 ? "A NOPASS type-bound procedure may not override a passed-argument procedure"_err_en_US
2619 : "A passed-argument type-bound procedure may not override a NOPASS procedure"_err_en_US);
2620 } else {
2621 const auto *bindingChars{Characterize(symbol)};
2622 const auto *overriddenChars{Characterize(*overridden)};
2623 if (bindingChars && overriddenChars) {
2624 if (isNopass) {
2625 if (!bindingChars->CanOverride(*overriddenChars, std::nullopt)) {
2626 SayWithDeclaration(*overridden,
2627 "A NOPASS type-bound procedure and its override must have identical interfaces"_err_en_US);
2628 }
2629 } else if (!context_.HasError(binding.symbol())) {
2630 auto passIndex{bindingChars->FindPassIndex(binding.passName())};
2631 auto overriddenPassIndex{
2632 overriddenChars->FindPassIndex(overriddenBinding->passName())};
2633 if (passIndex && overriddenPassIndex) {
2634 if (*passIndex != *overriddenPassIndex) {
2635 SayWithDeclaration(*overridden,
2636 "A type-bound procedure and its override must use the same PASS argument"_err_en_US);
2637 } else if (!bindingChars->CanOverride(
2638 *overriddenChars, passIndex)) {
2639 SayWithDeclaration(*overridden,
2640 "A type-bound procedure and its override must have compatible interfaces"_err_en_US);
2641 }
2642 }
2643 }
2644 }
2645 }
2646 if (symbol.attrs().test(Attr::PRIVATE)) {
2647 if (FindModuleContaining(dtScope) ==
2648 FindModuleContaining(overridden->owner())) {
2649 // types declared in same madule
2650 if (!overridden->attrs().test(Attr::PRIVATE)) {
2651 SayWithDeclaration(*overridden,
2652 "A PRIVATE procedure may not override a PUBLIC procedure"_err_en_US);
2653 }
2654 } else { // types declared in distinct madules
2655 if (!CheckAccessibleSymbol(dtScope.parent(), *overridden)) {
2656 SayWithDeclaration(*overridden,
2657 "A PRIVATE procedure may not override an accessible procedure"_err_en_US);
2658 }
2659 }
2660 }
2661 } else {
2662 SayWithDeclaration(*overridden,
2663 "A type-bound procedure binding may not have the same name as a parent component"_err_en_US);
2664 }
2665 }
2666 CheckPassArg(symbol, &binding.symbol(), binding);
2667}
2668
2669void CheckHelper::Check(const Scope &scope) {
2670 scope_ = &scope;
2671 common::Restorer<const Symbol *> restorer{innermostSymbol_, innermostSymbol_};
2672 if (const Symbol *symbol{scope.symbol()}) {
2673 innermostSymbol_ = symbol;
2674 }
2675 if (scope.IsParameterizedDerivedTypeInstantiation()) {
2676 auto restorer{common::ScopedSet(scopeIsUninstantiatedPDT_, false)};
2677 auto restorer2{context_.foldingContext().messages().SetContext(
2678 scope.instantiationContext().get())};
2679 for (const auto &pair : scope) {
2680 CheckPointerInitialization(*pair.second);
2681 }
2682 } else {
2683 auto restorer{common::ScopedSet(
2684 scopeIsUninstantiatedPDT_, scope.IsParameterizedDerivedType())};
2685 for (const auto &set : scope.equivalenceSets()) {
2686 CheckEquivalenceSet(set);
2687 }
2688 for (const auto &pair : scope) {
2689 Check(*pair.second);
2690 }
2691 if (scope.IsSubmodule() && scope.symbol()) {
2692 // Submodule names are not in their parent's scopes
2693 Check(*scope.symbol());
2694 }
2695 for (const auto &pair : scope.commonBlocks()) {
2696 CheckCommonBlock(*pair.second);
2697 }
2698 int mainProgCnt{0};
2699 for (const Scope &child : scope.children()) {
2700 Check(child);
2701 // A program shall consist of exactly one main program (5.2.2).
2702 if (child.kind() == Scope::Kind::MainProgram) {
2703 ++mainProgCnt;
2704 if (mainProgCnt > 1) {
2705 messages_.Say(child.sourceRange(),
2706 "A source file cannot contain more than one main program"_err_en_US);
2707 }
2708 }
2709 }
2710 if (scope.kind() == Scope::Kind::BlockData) {
2711 CheckBlockData(scope);
2712 }
2713 if (auto name{scope.GetName()}) {
2714 auto iter{scope.find(*name)};
2715 if (iter != scope.end()) {
2716 const char *kind{nullptr};
2717 switch (scope.kind()) {
2718 case Scope::Kind::Module:
2719 kind = scope.symbol()->get<ModuleDetails>().isSubmodule()
2720 ? "submodule"
2721 : "module";
2722 break;
2723 case Scope::Kind::MainProgram:
2724 kind = "main program";
2725 break;
2726 case Scope::Kind::BlockData:
2727 kind = "BLOCK DATA subprogram";
2728 break;
2729 default:;
2730 }
2731 if (kind) {
2732 Warn(common::LanguageFeature::BenignNameClash, iter->second->name(),
2733 "Name '%s' declared in a %s should not have the same name as the %s"_port_en_US,
2734 *name, kind, kind);
2735 }
2736 }
2737 }
2738 CheckGenericOps(scope);
2739 }
2740}
2741
2742void CheckHelper::CheckEquivalenceSet(const EquivalenceSet &set) {
2743 auto iter{
2744 std::find_if(set.begin(), set.end(), [](const EquivalenceObject &object) {
2745 return FindCommonBlockContaining(object.symbol) != nullptr;
2746 })};
2747 if (iter != set.end()) {
2748 const Symbol &commonBlock{DEREF(FindCommonBlockContaining(iter->symbol))};
2749 for (auto &object : set) {
2750 if (&object != &*iter) {
2751 if (auto *details{object.symbol.detailsIf<ObjectEntityDetails>()}) {
2752 if (details->commonBlock()) {
2753 if (details->commonBlock() != &commonBlock) { // 8.10.3 paragraph 1
2754 if (auto *msg{messages_.Say(object.symbol.name(),
2755 "Two objects in the same EQUIVALENCE set may not be members of distinct COMMON blocks"_err_en_US)}) {
2756 msg->Attach(iter->symbol.name(),
2757 "Other object in EQUIVALENCE set"_en_US)
2758 .Attach(details->commonBlock()->name(),
2759 "COMMON block containing '%s'"_en_US,
2760 object.symbol.name())
2761 .Attach(commonBlock.name(),
2762 "COMMON block containing '%s'"_en_US,
2763 iter->symbol.name());
2764 }
2765 }
2766 } else {
2767 // Mark all symbols in the equivalence set with the same COMMON
2768 // block to prevent spurious error messages about initialization
2769 // in BLOCK DATA outside COMMON
2770 details->set_commonBlock(commonBlock);
2771 }
2772 }
2773 }
2774 }
2775 }
2776 for (const EquivalenceObject &object : set) {
2777 CheckEquivalenceObject(object);
2778 }
2779}
2780
2781static bool InCommonWithBind(const Symbol &symbol) {
2782 if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
2783 const Symbol *commonBlock{details->commonBlock()};
2784 return commonBlock && commonBlock->attrs().test(Attr::BIND_C);
2785 } else {
2786 return false;
2787 }
2788}
2789
2790void CheckHelper::CheckEquivalenceObject(const EquivalenceObject &object) {
2791 parser::MessageFixedText msg;
2792 const Symbol &symbol{object.symbol};
2793 if (symbol.owner().IsDerivedType()) {
2794 msg =
2795 "Derived type component '%s' is not allowed in an equivalence set"_err_en_US;
2796 } else if (IsDummy(symbol)) {
2797 msg = "Dummy argument '%s' is not allowed in an equivalence set"_err_en_US;
2798 } else if (symbol.IsFuncResult()) {
2799 msg = "Function result '%s' is not allow in an equivalence set"_err_en_US;
2800 } else if (IsPointer(symbol)) {
2801 msg = "Pointer '%s' is not allowed in an equivalence set"_err_en_US;
2802 } else if (IsAllocatable(symbol)) {
2803 msg =
2804 "Allocatable variable '%s' is not allowed in an equivalence set"_err_en_US;
2805 } else if (symbol.Corank() > 0) {
2806 msg = "Coarray '%s' is not allowed in an equivalence set"_err_en_US;
2807 } else if (symbol.has<UseDetails>()) {
2808 msg =
2809 "Use-associated variable '%s' is not allowed in an equivalence set"_err_en_US;
2810 } else if (symbol.attrs().test(Attr::BIND_C)) {
2811 msg =
2812 "Variable '%s' with BIND attribute is not allowed in an equivalence set"_err_en_US;
2813 } else if (symbol.attrs().test(Attr::TARGET)) {
2814 msg =
2815 "Variable '%s' with TARGET attribute is not allowed in an equivalence set"_err_en_US;
2816 } else if (IsNamedConstant(symbol)) {
2817 msg = "Named constant '%s' is not allowed in an equivalence set"_err_en_US;
2818 } else if (InCommonWithBind(symbol)) {
2819 msg =
2820 "Variable '%s' in common block with BIND attribute is not allowed in an equivalence set"_err_en_US;
2821 } else if (!symbol.has<ObjectEntityDetails>()) {
2822 msg = "'%s' in equivalence set is not a data object"_err_en_US;
2823 } else if (const auto *type{symbol.GetType()}) {
2824 const auto *derived{type->AsDerived()};
2825 if (derived && !derived->IsVectorType()) {
2826 if (const auto *comp{
2827 FindUltimateComponent(*derived, IsAllocatableOrPointer)}) {
2828 msg = IsPointer(*comp)
2829 ? "Derived type object '%s' with pointer ultimate component is not allowed in an equivalence set"_err_en_US
2830 : "Derived type object '%s' with allocatable ultimate component is not allowed in an equivalence set"_err_en_US;
2831 } else if (!derived->typeSymbol().get<DerivedTypeDetails>().sequence()) {
2832 msg =
2833 "Nonsequence derived type object '%s' is not allowed in an equivalence set"_err_en_US;
2834 }
2835 } else if (IsAutomatic(symbol)) {
2836 msg =
2837 "Automatic object '%s' is not allowed in an equivalence set"_err_en_US;
2838 } else if (symbol.test(Symbol::Flag::CrayPointee)) {
2839 messages_.Say(object.symbol.name(),
2840 "Cray pointee '%s' may not be a member of an EQUIVALENCE group"_err_en_US,
2841 object.symbol.name());
2842 }
2843 }
2844 if (!msg.text().empty()) {
2845 context_.Say(object.source, std::move(msg), symbol.name());
2846 }
2847}
2848
2849void CheckHelper::CheckBlockData(const Scope &scope) {
2850 // BLOCK DATA subprograms should contain only named common blocks.
2851 // C1415 presents a list of statements that shouldn't appear in
2852 // BLOCK DATA, but so long as the subprogram contains no executable
2853 // code and allocates no storage outside named COMMON, we're happy
2854 // (e.g., an ENUM is strictly not allowed).
2855 for (const auto &pair : scope) {
2856 const Symbol &symbol{*pair.second};
2857 if (!(symbol.has<CommonBlockDetails>() || symbol.has<UseDetails>() ||
2858 symbol.has<UseErrorDetails>() || symbol.has<DerivedTypeDetails>() ||
2859 symbol.has<SubprogramDetails>() ||
2860 symbol.has<ObjectEntityDetails>() ||
2861 (symbol.has<ProcEntityDetails>() &&
2862 !symbol.attrs().test(Attr::POINTER)))) {
2863 messages_.Say(symbol.name(),
2864 "'%s' may not appear in a BLOCK DATA subprogram"_err_en_US,
2865 symbol.name());
2866 }
2867 }
2868}
2869
2870// Check distinguishability of generic assignment and operators.
2871// For these, generics and generic bindings must be considered together.
2872void CheckHelper::CheckGenericOps(const Scope &scope) {
2873 DistinguishabilityHelper helper{context_};
2874 auto addSpecifics{[&](const Symbol &generic) {
2875 if (!IsAccessible(generic, scope)) {
2876 return;
2877 }
2878 const auto *details{generic.GetUltimate().detailsIf<GenericDetails>()};
2879 if (!details) {
2880 // Not a generic; ensure characteristics are defined if a function.
2881 auto restorer{messages_.SetLocation(generic.name())};
2882 if (IsFunction(generic) && !context_.HasError(generic)) {
2883 if (const Symbol *result{FindFunctionResult(generic)};
2884 result && !context_.HasError(*result)) {
2885 Characterize(generic);
2886 }
2887 }
2888 return;
2889 }
2890 GenericKind kind{details->kind()};
2891 if (!kind.IsAssignment() && !kind.IsOperator()) {
2892 return;
2893 }
2894 const SymbolVector &specifics{details->specificProcs()};
2895 const std::vector<SourceName> &bindingNames{details->bindingNames()};
2896 for (std::size_t i{0}; i < specifics.size(); ++i) {
2897 const Symbol &specific{*specifics[i]};
2898 auto restorer{messages_.SetLocation(bindingNames[i])};
2899 if (const Procedure *proc{Characterize(specific)}) {
2900 if (kind.IsAssignment()) {
2901 if (!CheckDefinedAssignment(specific, *proc)) {
2902 continue;
2903 }
2904 } else {
2905 if (!CheckDefinedOperator(generic.name(), kind, specific, *proc)) {
2906 continue;
2907 }
2908 }
2909 helper.Add(generic, kind, specific, *proc);
2910 }
2911 }
2912 }};
2913 for (const auto &pair : scope) {
2914 const Symbol &symbol{*pair.second};
2915 addSpecifics(symbol);
2916 const Symbol &ultimate{symbol.GetUltimate()};
2917 if (ultimate.has<DerivedTypeDetails>()) {
2918 if (const Scope *typeScope{ultimate.scope()}) {
2919 for (const auto &pair2 : *typeScope) {
2920 addSpecifics(*pair2.second);
2921 }
2922 }
2923 }
2924 }
2925 helper.Check(scope);
2926}
2927
2928static bool IsSubprogramDefinition(const Symbol &symbol) {
2929 const auto *subp{symbol.detailsIf<SubprogramDetails>()};
2930 return subp && !subp->isInterface() && symbol.scope() &&
2931 symbol.scope()->kind() == Scope::Kind::Subprogram;
2932}
2933
2934static bool IsExternalProcedureDefinition(const Symbol &symbol) {
2935 return IsBlockData(symbol) ||
2936 (IsSubprogramDefinition(symbol) &&
2937 (IsExternal(symbol) || symbol.GetBindName()));
2938}
2939
2940static std::optional<std::string> DefinesGlobalName(const Symbol &symbol) {
2941 if (const auto *module{symbol.detailsIf<ModuleDetails>()}) {
2942 if (!module->isSubmodule() && !symbol.owner().IsIntrinsicModules()) {
2943 return symbol.name().ToString();
2944 }
2945 } else if (IsBlockData(symbol)) {
2946 return symbol.name().ToString();
2947 } else {
2948 const std::string *bindC{symbol.GetBindName()};
2949 if (symbol.has<CommonBlockDetails>() ||
2950 IsExternalProcedureDefinition(symbol) ||
2951 (symbol.owner().IsGlobal() && IsExternal(symbol))) {
2952 return bindC ? *bindC : symbol.name().ToString();
2953 } else if (bindC &&
2954 (symbol.has<ObjectEntityDetails>() || IsModuleProcedure(symbol))) {
2955 return *bindC;
2956 }
2957 }
2958 return std::nullopt;
2959}
2960
2961static bool IsSameSymbolFromHermeticModule(
2962 const Symbol &symbol, const Symbol &other) {
2963 return symbol.name() == other.name() && symbol.owner().IsModule() &&
2964 other.owner().IsModule() && symbol.owner() != other.owner() &&
2965 symbol.owner().GetName() &&
2966 symbol.owner().GetName() == other.owner().GetName();
2967}
2968
2969// 19.2 p2
2970void CheckHelper::CheckGlobalName(const Symbol &symbol) {
2971 if (auto global{DefinesGlobalName(symbol)}) {
2972 auto pair{globalNames_.emplace(std::move(*global), symbol)};
2973 if (!pair.second) {
2974 const Symbol &other{*pair.first->second};
2975 if (context_.HasError(symbol) || context_.HasError(other)) {
2976 // don't pile on
2977 } else if (symbol.has<CommonBlockDetails>() &&
2978 other.has<CommonBlockDetails>() && symbol.name() == other.name()) {
2979 // Two common blocks can have the same global name so long as
2980 // they're not in the same scope.
2981 } else if ((IsProcedure(symbol) || IsBlockData(symbol)) &&
2982 (IsProcedure(other) || IsBlockData(symbol: other)) &&
2983 (!IsExternalProcedureDefinition(symbol) ||
2984 !IsExternalProcedureDefinition(symbol: other))) {
2985 // both are procedures/BLOCK DATA, not both definitions
2986 } else if (IsSameSymbolFromHermeticModule(symbol, other)) {
2987 // Both symbols are the same thing.
2988 } else if (symbol.has<ModuleDetails>()) {
2989 Warn(common::LanguageFeature::BenignNameClash, symbol.name(),
2990 "Module '%s' conflicts with a global name"_port_en_US,
2991 pair.first->first);
2992 } else if (other.has<ModuleDetails>()) {
2993 Warn(common::LanguageFeature::BenignNameClash, symbol.name(),
2994 "Global name '%s' conflicts with a module"_port_en_US,
2995 pair.first->first);
2996 } else if (auto *msg{messages_.Say(symbol.name(),
2997 "Two entities have the same global name '%s'"_err_en_US,
2998 pair.first->first)}) {
2999 msg->Attach(other.name(), "Conflicting declaration"_en_US);
3000 context_.SetError(symbol);
3001 context_.SetError(other);
3002 }
3003 }
3004 }
3005}
3006
3007void CheckHelper::CheckProcedureAssemblyName(const Symbol &symbol) {
3008 if (!IsProcedure(symbol) || symbol != symbol.GetUltimate())
3009 return;
3010 const std::string *bindName{symbol.GetBindName()};
3011 const bool hasExplicitBindingLabel{
3012 symbol.GetIsExplicitBindName() && bindName};
3013 if (hasExplicitBindingLabel || IsExternal(symbol)) {
3014 const std::string assemblyName{hasExplicitBindingLabel
3015 ? *bindName
3016 : common::GetExternalAssemblyName(
3017 symbol.name().ToString(), context_.underscoring())};
3018 auto pair{procedureAssemblyNames_.emplace(std::move(assemblyName), symbol)};
3019 if (!pair.second) {
3020 const Symbol &other{*pair.first->second};
3021 const bool otherHasExplicitBindingLabel{
3022 other.GetIsExplicitBindName() && other.GetBindName()};
3023 if (otherHasExplicitBindingLabel != hasExplicitBindingLabel) {
3024 // The BIND(C,NAME="...") binding label is the same as the name that
3025 // will be used in LLVM IR for an external procedure declared without
3026 // BIND(C) in the same file. While this is not forbidden by the
3027 // standard, this name collision would lead to a crash when producing
3028 // the IR.
3029 if (auto *msg{messages_.Say(symbol.name(),
3030 "%s procedure assembly name conflicts with %s procedure assembly name"_err_en_US,
3031 hasExplicitBindingLabel ? "BIND(C)" : "Non BIND(C)",
3032 hasExplicitBindingLabel ? "non BIND(C)" : "BIND(C)")}) {
3033 msg->Attach(other.name(), "Conflicting declaration"_en_US);
3034 }
3035 context_.SetError(symbol);
3036 context_.SetError(other);
3037 }
3038 // Otherwise, the global names also match and the conflict is analyzed
3039 // by CheckGlobalName.
3040 }
3041 }
3042}
3043
3044parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
3045 const Symbol &symbol) {
3046 parser::Messages msgs;
3047 if (examinedByWhyNotInteroperable_.find(symbol) !=
3048 examinedByWhyNotInteroperable_.end()) {
3049 return msgs;
3050 }
3051 examinedByWhyNotInteroperable_.insert(symbol);
3052 if (const auto *derived{symbol.detailsIf<DerivedTypeDetails>()}) {
3053 if (derived->sequence()) { // C1801
3054 msgs.Say(symbol.name(),
3055 "An interoperable derived type cannot have the SEQUENCE attribute"_err_en_US);
3056 } else if (!derived->paramNameOrder().empty()) { // C1802
3057 msgs.Say(symbol.name(),
3058 "An interoperable derived type cannot have a type parameter"_err_en_US);
3059 } else if (const auto *parent{
3060 symbol.scope()->GetDerivedTypeParent()}) { // C1803
3061 if (symbol.attrs().test(Attr::BIND_C)) {
3062 msgs.Say(symbol.name(),
3063 "A derived type with the BIND attribute cannot be an extended derived type"_err_en_US);
3064 } else {
3065 bool interoperableParent{true};
3066 if (parent->symbol()) {
3067 auto bad{WhyNotInteroperableDerivedType(*parent->symbol())};
3068 if (bad.AnyFatalError()) {
3069 auto &msg{msgs.Say(symbol.name(),
3070 "The parent of an interoperable type is not interoperable"_err_en_US)};
3071 bad.AttachTo(msg, parser::Severity::None);
3072 interoperableParent = false;
3073 }
3074 }
3075 if (interoperableParent) {
3076 msgs.Say(symbol.name(),
3077 "An interoperable type should not be an extended derived type"_warn_en_US);
3078 }
3079 }
3080 }
3081 const Symbol *parentComponent{symbol.scope()
3082 ? derived->GetParentComponent(*symbol.scope())
3083 : nullptr};
3084 for (const auto &pair : *symbol.scope()) {
3085 const Symbol &component{*pair.second};
3086 if (&component == parentComponent) {
3087 continue; // was checked above
3088 }
3089 if (IsProcedure(component)) { // C1804
3090 msgs.Say(component.name(),
3091 "An interoperable derived type cannot have a type bound procedure"_err_en_US);
3092 } else if (IsAllocatableOrPointer(component)) { // C1806
3093 msgs.Say(component.name(),
3094 "An interoperable derived type cannot have a pointer or allocatable component"_err_en_US);
3095 } else if (const auto *type{component.GetType()}) {
3096 if (const auto *derived{type->AsDerived()}) {
3097 auto bad{WhyNotInteroperableDerivedType(derived->typeSymbol())};
3098 if (bad.AnyFatalError()) {
3099 auto &msg{msgs.Say(component.name(),
3100 "Component '%s' of an interoperable derived type must have an interoperable type but does not"_err_en_US,
3101 component.name())};
3102 bad.AttachTo(msg, parser::Severity::None);
3103 } else if (!derived->typeSymbol().GetUltimate().attrs().test(
3104 Attr::BIND_C)) {
3105 auto &msg{
3106 msgs.Say(component.name(),
3107 "Derived type of component '%s' of an interoperable derived type should have the BIND attribute"_warn_en_US,
3108 component.name())
3109 .Attach(derived->typeSymbol().name(),
3110 "Non-BIND(C) component type"_en_US)};
3111 bad.AttachTo(msg, parser::Severity::None);
3112 } else {
3113 msgs.Annex(std::move(bad));
3114 }
3115 } else if (auto dyType{evaluate::DynamicType::From(*type)}; dyType &&
3116 !evaluate::IsInteroperableIntrinsicType(
3117 *dyType, &context_.languageFeatures())
3118 .value_or(false)) {
3119 if (type->category() == DeclTypeSpec::Logical) {
3120 if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {
3121 msgs.Say(common::UsageWarning::LogicalVsCBool, component.name(),
3122 "A LOGICAL component of an interoperable type should have the interoperable KIND=C_BOOL"_port_en_US);
3123 }
3124 } else if (type->category() == DeclTypeSpec::Character && dyType &&
3125 dyType->kind() == 1) {
3126 if (context_.ShouldWarn(common::UsageWarning::BindCCharLength)) {
3127 msgs.Say(common::UsageWarning::BindCCharLength, component.name(),
3128 "A CHARACTER component of an interoperable type should have length 1"_port_en_US);
3129 }
3130 } else {
3131 msgs.Say(component.name(),
3132 "Each component of an interoperable derived type must have an interoperable type"_err_en_US);
3133 }
3134 }
3135 }
3136 if (auto extents{
3137 evaluate::GetConstantExtents(foldingContext_, &component)};
3138 extents && evaluate::GetSize(*extents) == 0) {
3139 msgs.Say(component.name(),
3140 "An array component of an interoperable type must have at least one element"_err_en_US);
3141 }
3142 }
3143 if (derived->componentNames().empty()) { // F'2023 C1805
3144 if (context_.ShouldWarn(common::LanguageFeature::EmptyBindCDerivedType)) {
3145 msgs.Say(common::LanguageFeature::EmptyBindCDerivedType, symbol.name(),
3146 "A derived type with the BIND attribute should not be empty"_warn_en_US);
3147 }
3148 }
3149 }
3150 if (msgs.AnyFatalError()) {
3151 examinedByWhyNotInteroperable_.erase(symbol);
3152 }
3153 return msgs;
3154}
3155
3156parser::Messages CheckHelper::WhyNotInteroperableObject(
3157 const Symbol &symbol, bool allowNonInteroperableType) {
3158 parser::Messages msgs;
3159 if (examinedByWhyNotInteroperable_.find(symbol) !=
3160 examinedByWhyNotInteroperable_.end()) {
3161 return msgs;
3162 }
3163 bool isExplicitBindC{symbol.attrs().test(Attr::BIND_C)};
3164 examinedByWhyNotInteroperable_.insert(symbol);
3165 CHECK(symbol.has<ObjectEntityDetails>());
3166 if (isExplicitBindC && !symbol.owner().IsModule()) {
3167 msgs.Say(symbol.name(),
3168 "A variable with BIND(C) attribute may only appear in the specification part of a module"_err_en_US);
3169 }
3170 auto shape{evaluate::GetShape(foldingContext_, symbol)};
3171 if (shape) {
3172 if (evaluate::GetRank(*shape) == 0) { // 18.3.4
3173 if (IsAllocatableOrPointer(symbol) && !IsDummy(symbol)) {
3174 msgs.Say(symbol.name(),
3175 "A scalar interoperable variable may not be ALLOCATABLE or POINTER"_err_en_US);
3176 }
3177 } else if (auto extents{
3178 evaluate::AsConstantExtents(foldingContext_, *shape)}) {
3179 if (evaluate::GetSize(*extents) == 0) {
3180 msgs.Say(symbol.name(),
3181 "Interoperable array must have at least one element"_err_en_US);
3182 }
3183 } else if (!evaluate::IsExplicitShape(symbol) &&
3184 !IsAssumedSizeArray(symbol) &&
3185 !(IsDummy(symbol) && !symbol.attrs().test(Attr::VALUE))) {
3186 msgs.Say(symbol.name(),
3187 "BIND(C) array must have explicit shape or be assumed-size unless a dummy argument without the VALUE attribute"_err_en_US);
3188 }
3189 }
3190 if (const auto *type{symbol.GetType()}) {
3191 const auto *derived{type->AsDerived()};
3192 if (derived && !derived->typeSymbol().attrs().test(Attr::BIND_C)) {
3193 if (allowNonInteroperableType) { // portability warning only
3194 evaluate::AttachDeclaration(
3195 context_.Warn(common::UsageWarning::Portability, symbol.name(),
3196 "The derived type of this interoperable object should be BIND(C)"_port_en_US),
3197 derived->typeSymbol());
3198 } else if (!context_.IsEnabled(
3199 common::LanguageFeature::NonBindCInteroperability)) {
3200 msgs.Say(symbol.name(),
3201 "The derived type of an interoperable object must be BIND(C)"_err_en_US)
3202 .Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);
3203 } else if (auto bad{
3204 WhyNotInteroperableDerivedType(derived->typeSymbol())};
3205 bad.AnyFatalError()) {
3206 bad.AttachTo(
3207 msgs.Say(symbol.name(),
3208 "The derived type of an interoperable object must be interoperable, but is not"_err_en_US)
3209 .Attach(derived->typeSymbol().name(),
3210 "Non-interoperable type"_en_US),
3211 parser::Severity::None);
3212 } else {
3213 msgs.Say(symbol.name(),
3214 "The derived type of an interoperable object should be BIND(C)"_warn_en_US)
3215 .Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);
3216 }
3217 }
3218 if (type->IsAssumedType()) { // ok
3219 } else if (IsAssumedLengthCharacter(symbol) &&
3220 !IsAllocatableOrPointer(symbol)) {
3221 } else if (IsAllocatableOrPointer(symbol) &&
3222 type->category() == DeclTypeSpec::Character &&
3223 type->characterTypeSpec().length().isDeferred()) {
3224 // ok; F'2023 18.3.7 p2(6)
3225 } else if (derived) { // type has been checked
3226 } else if (auto dyType{evaluate::DynamicType::From(*type)}; dyType &&
3227 evaluate::IsInteroperableIntrinsicType(
3228 *dyType, InModuleFile() ? nullptr : &context_.languageFeatures())
3229 .value_or(false)) {
3230 // F'2023 18.3.7 p2(4,5)
3231 // N.B. Language features are not passed to IsInteroperableIntrinsicType
3232 // when processing a module file, since the module file might have been
3233 // compiled with CUDA while the client is not.
3234 } else if (type->category() == DeclTypeSpec::Logical) {
3235 if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {
3236 if (IsDummy(symbol)) {
3237 msgs.Say(common::UsageWarning::LogicalVsCBool, symbol.name(),
3238 "A BIND(C) LOGICAL dummy argument should have the interoperable KIND=C_BOOL"_port_en_US);
3239 } else {
3240 msgs.Say(common::UsageWarning::LogicalVsCBool, symbol.name(),
3241 "A BIND(C) LOGICAL object should have the interoperable KIND=C_BOOL"_port_en_US);
3242 }
3243 }
3244 } else if (symbol.attrs().test(Attr::VALUE)) {
3245 msgs.Say(symbol.name(),
3246 "A BIND(C) VALUE dummy argument must have an interoperable type"_err_en_US);
3247 } else {
3248 msgs.Say(symbol.name(),
3249 "A BIND(C) object must have an interoperable type"_err_en_US);
3250 }
3251 }
3252 if (IsOptional(symbol) && !symbol.attrs().test(Attr::VALUE)) {
3253 msgs.Say(symbol.name(),
3254 "An interoperable procedure with an OPTIONAL dummy argument might not be portable"_port_en_US);
3255 }
3256 if (IsDescriptor(symbol) && IsPointer(symbol) &&
3257 symbol.attrs().test(Attr::CONTIGUOUS)) {
3258 msgs.Say(symbol.name(),
3259 "An interoperable pointer must not be CONTIGUOUS"_err_en_US);
3260 }
3261 if (msgs.AnyFatalError()) {
3262 examinedByWhyNotInteroperable_.erase(symbol);
3263 }
3264 return msgs;
3265}
3266
3267parser::Messages CheckHelper::WhyNotInteroperableFunctionResult(
3268 const Symbol &symbol) {
3269 parser::Messages msgs;
3270 if (IsPointer(symbol) || IsAllocatable(symbol)) {
3271 msgs.Say(symbol.name(),
3272 "Interoperable function result may not have ALLOCATABLE or POINTER attribute"_err_en_US);
3273 }
3274 if (const DeclTypeSpec * type{symbol.GetType()};
3275 type && type->category() == DeclTypeSpec::Character) {
3276 bool isConstOne{false}; // 18.3.1(1)
3277 if (const auto &len{type->characterTypeSpec().length().GetExplicit()}) {
3278 if (auto constLen{evaluate::ToInt64(*len)}) {
3279 isConstOne = constLen == 1;
3280 }
3281 }
3282 if (!isConstOne) {
3283 msgs.Say(symbol.name(),
3284 "Interoperable character function result must have length one"_err_en_US);
3285 }
3286 }
3287 if (symbol.Rank() > 0) {
3288 msgs.Say(symbol.name(),
3289 "Interoperable function result must be scalar"_err_en_US);
3290 }
3291 return msgs;
3292}
3293
3294parser::Messages CheckHelper::WhyNotInteroperableProcedure(
3295 const Symbol &symbol, bool isError) {
3296 parser::Messages msgs;
3297 if (examinedByWhyNotInteroperable_.find(symbol) !=
3298 examinedByWhyNotInteroperable_.end()) {
3299 return msgs;
3300 }
3301 isError |= symbol.attrs().test(Attr::BIND_C);
3302 examinedByWhyNotInteroperable_.insert(symbol);
3303 if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
3304 if (isError) {
3305 if (!proc->procInterface() ||
3306 !proc->procInterface()->attrs().test(Attr::BIND_C)) {
3307 msgs.Say(symbol.name(),
3308 "An interface name with the BIND attribute must appear if the BIND attribute appears in a procedure declaration"_err_en_US);
3309 }
3310 } else if (!proc->procInterface()) {
3311 msgs.Say(symbol.name(),
3312 "An interoperable procedure should have an interface"_port_en_US);
3313 } else if (!proc->procInterface()->attrs().test(Attr::BIND_C)) {
3314 auto bad{WhyNotInteroperableProcedure(
3315 *proc->procInterface(), /*isError=*/false)};
3316 if (bad.AnyFatalError()) {
3317 bad.AttachTo(msgs.Say(symbol.name(),
3318 "An interoperable procedure must have an interoperable interface"_err_en_US));
3319 } else {
3320 msgs.Say(symbol.name(),
3321 "An interoperable procedure should have an interface with the BIND attribute"_warn_en_US);
3322 }
3323 }
3324 } else if (const auto *subp{symbol.detailsIf<SubprogramDetails>()}) {
3325 for (const Symbol *dummy : subp->dummyArgs()) {
3326 if (dummy) {
3327 parser::Messages dummyMsgs;
3328 if (dummy->has<ProcEntityDetails>() ||
3329 dummy->has<SubprogramDetails>()) {
3330 dummyMsgs = WhyNotInteroperableProcedure(*dummy, /*isError=*/false);
3331 if (dummyMsgs.empty() && !dummy->attrs().test(Attr::BIND_C)) {
3332 dummyMsgs.Say(dummy->name(),
3333 "A dummy procedure of an interoperable procedure should be BIND(C)"_warn_en_US);
3334 }
3335 } else if (dummy->has<ObjectEntityDetails>()) {
3336 // Emit only optional portability warnings for non-interoperable
3337 // types when the dummy argument is not VALUE and will be implemented
3338 // on the C side by either a cdesc_t * or a void *. F'2023 18.3.7 (5)
3339 bool allowNonInteroperableType{!dummy->attrs().test(Attr::VALUE) &&
3340 (IsDescriptor(*dummy) || IsAssumedType(*dummy))};
3341 dummyMsgs =
3342 WhyNotInteroperableObject(*dummy, allowNonInteroperableType);
3343 } else {
3344 CheckBindC(*dummy);
3345 }
3346 msgs.Annex(std::move(dummyMsgs));
3347 } else {
3348 msgs.Say(symbol.name(),
3349 "A subprogram interface with the BIND attribute may not have an alternate return argument"_err_en_US);
3350 }
3351 }
3352 if (subp->isFunction()) {
3353 if (subp->result().has<ObjectEntityDetails>()) {
3354 msgs.Annex(WhyNotInteroperableFunctionResult(subp->result()));
3355 } else {
3356 msgs.Say(subp->result().name(),
3357 "The result of an interoperable function must be a data object"_err_en_US);
3358 }
3359 }
3360 }
3361 if (msgs.AnyFatalError()) {
3362 examinedByWhyNotInteroperable_.erase(symbol);
3363 }
3364 return msgs;
3365}
3366
3367void CheckHelper::CheckBindC(const Symbol &symbol) {
3368 bool isExplicitBindC{symbol.attrs().test(Attr::BIND_C)};
3369 if (isExplicitBindC) {
3370 CheckConflicting(symbol, Attr::BIND_C, Attr::ELEMENTAL);
3371 CheckConflicting(symbol, Attr::BIND_C, Attr::INTRINSIC);
3372 CheckConflicting(symbol, Attr::BIND_C, Attr::PARAMETER);
3373 } else {
3374 // symbol must be interoperable (e.g., dummy argument of interoperable
3375 // procedure interface) but is not itself BIND(C).
3376 }
3377 parser::Messages whyNot;
3378 if (const std::string * bindName{symbol.GetBindName()};
3379 bindName) { // has a binding name
3380 if (!bindName->empty()) {
3381 bool ok{bindName->front() == '_' || parser::IsLetter(bindName->front())};
3382 for (char ch : *bindName) {
3383 ok &= ch == '_' || parser::IsLetter(ch) || parser::IsDecimalDigit(ch);
3384 }
3385 if (!ok) {
3386 messages_.Say(symbol.name(),
3387 "Symbol has a BIND(C) name that is not a valid C language identifier"_err_en_US);
3388 context_.SetError(symbol);
3389 }
3390 }
3391 }
3392 if (symbol.GetIsExplicitBindName()) { // BIND(C,NAME=...); C1552, C1529
3393 auto defClass{ClassifyProcedure(symbol)};
3394 if (IsProcedurePointer(symbol)) {
3395 messages_.Say(symbol.name(),
3396 "A procedure pointer may not have a BIND attribute with a name"_err_en_US);
3397 context_.SetError(symbol);
3398 } else if (defClass == ProcedureDefinitionClass::None ||
3399 IsExternal(symbol)) {
3400 } else if (symbol.attrs().test(Attr::ABSTRACT)) {
3401 messages_.Say(symbol.name(),
3402 "An ABSTRACT interface may not have a BIND attribute with a name"_err_en_US);
3403 context_.SetError(symbol);
3404 } else if (defClass == ProcedureDefinitionClass::Internal ||
3405 defClass == ProcedureDefinitionClass::Dummy) {
3406 messages_.Say(symbol.name(),
3407 "An internal or dummy procedure may not have a BIND(C,NAME=) binding label"_err_en_US);
3408 context_.SetError(symbol);
3409 }
3410 }
3411 if (symbol.has<ObjectEntityDetails>()) {
3412 whyNot = WhyNotInteroperableObject(symbol);
3413 } else if (symbol.has<ProcEntityDetails>() ||
3414 symbol.has<SubprogramDetails>()) {
3415 whyNot = WhyNotInteroperableProcedure(symbol, /*isError=*/isExplicitBindC);
3416 } else if (symbol.has<DerivedTypeDetails>()) {
3417 whyNot = WhyNotInteroperableDerivedType(symbol);
3418 }
3419 if (!whyNot.empty()) {
3420 bool anyFatal{whyNot.AnyFatalError()};
3421 if (anyFatal ||
3422 (!InModuleFile() &&
3423 context_.ShouldWarn(
3424 common::LanguageFeature::NonBindCInteroperability))) {
3425 context_.messages().Annex(std::move(whyNot));
3426 }
3427 if (anyFatal) {
3428 context_.SetError(symbol);
3429 }
3430 }
3431}
3432
3433bool CheckHelper::CheckDioDummyIsData(
3434 const Symbol &subp, const Symbol *arg, std::size_t position) {
3435 if (arg && arg->detailsIf<ObjectEntityDetails>()) {
3436 if (evaluate::IsAssumedRank(*arg)) {
3437 messages_.Say(arg->name(),
3438 "Dummy argument '%s' may not be assumed-rank"_err_en_US, arg->name());
3439 return false;
3440 } else {
3441 return true;
3442 }
3443 } else {
3444 if (arg) {
3445 messages_.Say(arg->name(),
3446 "Dummy argument '%s' must be a data object"_err_en_US, arg->name());
3447 } else {
3448 messages_.Say(subp.name(),
3449 "Dummy argument %d of '%s' must be a data object"_err_en_US, position,
3450 subp.name());
3451 }
3452 return false;
3453 }
3454}
3455
3456void CheckHelper::CheckAlreadySeenDefinedIo(const DerivedTypeSpec &derivedType,
3457 common::DefinedIo ioKind, const Symbol &proc, const Symbol &generic) {
3458 // Check for conflict between non-type-bound defined I/O and type-bound
3459 // generics. It's okay to have two or more distinct defined I/O procedures for
3460 // the same type if they're coming from distinct non-type-bound interfaces.
3461 // (The non-type-bound interfaces would have been merged into a single generic
3462 // -- with errors where indistinguishable -- when both were visible from the
3463 // same scope.)
3464 if (generic.owner().IsDerivedType()) {
3465 return;
3466 }
3467 if (const Scope * dtScope{derivedType.scope()}) {
3468 if (auto iter{dtScope->find(generic.name())}; iter != dtScope->end() &&
3469 IsAccessible(*iter->second, generic.owner())) {
3470 for (auto specRef : iter->second->get<GenericDetails>().specificProcs()) {
3471 const Symbol *specific{&specRef->get<ProcBindingDetails>().symbol()};
3472 if (specific == &proc) {
3473 continue; // unambiguous, accept
3474 }
3475 if (const auto *peDetails{specific->detailsIf<ProcEntityDetails>()}) {
3476 specific = peDetails->procInterface();
3477 if (!specific) {
3478 continue;
3479 }
3480 }
3481 if (const auto *specDT{GetDtvArgDerivedType(*specific)};
3482 specDT && evaluate::AreSameDerivedType(derivedType, *specDT)) {
3483 SayWithDeclaration(*specRef, proc.name(),
3484 "Derived type '%s' has conflicting type-bound input/output procedure '%s'"_err_en_US,
3485 derivedType.name(), GenericKind::AsFortran(ioKind));
3486 return;
3487 }
3488 }
3489 }
3490 }
3491}
3492
3493void CheckHelper::CheckDioDummyIsDerived(const Symbol &proc, const Symbol &arg,
3494 common::DefinedIo ioKind, const Symbol &generic) {
3495 if (const DeclTypeSpec *type{arg.GetType()}) {
3496 if (const DerivedTypeSpec *derivedType{type->AsDerived()}) {
3497 CheckAlreadySeenDefinedIo(*derivedType, ioKind, proc, generic);
3498 bool isPolymorphic{type->IsPolymorphic()};
3499 if (isPolymorphic != IsExtensibleType(derivedType)) {
3500 messages_.Say(arg.name(),
3501 "Dummy argument '%s' of a defined input/output procedure must be %s when the derived type is %s"_err_en_US,
3502 arg.name(), isPolymorphic ? "TYPE()" : "CLASS()",
3503 isPolymorphic ? "not extensible" : "extensible");
3504 }
3505 } else {
3506 messages_.Say(arg.name(),
3507 "Dummy argument '%s' of a defined input/output procedure must have a derived type"_err_en_US,
3508 arg.name());
3509 }
3510 }
3511}
3512
3513void CheckHelper::CheckDioDummyIsDefaultInteger(
3514 const Symbol &subp, const Symbol &arg) {
3515 if (const DeclTypeSpec *type{arg.GetType()};
3516 type && type->IsNumeric(TypeCategory::Integer)) {
3517 if (const auto kind{evaluate::ToInt64(type->numericTypeSpec().kind())};
3518 kind && *kind == context_.GetDefaultKind(TypeCategory::Integer)) {
3519 return;
3520 }
3521 }
3522 messages_.Say(arg.name(),
3523 "Dummy argument '%s' of a defined input/output procedure must be an INTEGER of default KIND"_err_en_US,
3524 arg.name());
3525}
3526
3527void CheckHelper::CheckDioDummyIsScalar(const Symbol &subp, const Symbol &arg) {
3528 if (arg.Rank() > 0) {
3529 messages_.Say(arg.name(),
3530 "Dummy argument '%s' of a defined input/output procedure must be a scalar"_err_en_US,
3531 arg.name());
3532 }
3533}
3534
3535void CheckHelper::CheckDioDtvArg(const Symbol &proc, const Symbol &subp,
3536 const Symbol *arg, common::DefinedIo ioKind, const Symbol &generic) {
3537 // Dtv argument looks like: dtv-type-spec, INTENT(INOUT) :: dtv
3538 if (CheckDioDummyIsData(subp, arg, position: 0)) {
3539 CheckDioDummyIsDerived(proc, *arg, ioKind, generic);
3540 CheckDioDummyAttrs(subp, *arg,
3541 ioKind == common::DefinedIo::ReadFormatted ||
3542 ioKind == common::DefinedIo::ReadUnformatted
3543 ? Attr::INTENT_INOUT
3544 : Attr::INTENT_IN);
3545 }
3546}
3547
3548// If an explicit INTRINSIC name is a function, so must all the specifics be,
3549// and similarly for subroutines
3550void CheckHelper::CheckGenericVsIntrinsic(
3551 const Symbol &symbol, const GenericDetails &generic) {
3552 if (symbol.attrs().test(Attr::INTRINSIC)) {
3553 const evaluate::IntrinsicProcTable &table{
3554 context_.foldingContext().intrinsics()};
3555 bool isSubroutine{table.IsIntrinsicSubroutine(symbol.name().ToString())};
3556 if (isSubroutine || table.IsIntrinsicFunction(symbol.name().ToString())) {
3557 for (const SymbolRef &ref : generic.specificProcs()) {
3558 const Symbol &ultimate{ref->GetUltimate()};
3559 bool specificFunc{ultimate.test(Symbol::Flag::Function)};
3560 bool specificSubr{ultimate.test(Symbol::Flag::Subroutine)};
3561 if (!specificFunc && !specificSubr) {
3562 if (const auto *proc{ultimate.detailsIf<SubprogramDetails>()}) {
3563 if (proc->isFunction()) {
3564 specificFunc = true;
3565 } else {
3566 specificSubr = true;
3567 }
3568 }
3569 }
3570 if ((specificFunc || specificSubr) &&
3571 isSubroutine != specificSubr) { // C848
3572 messages_.Say(symbol.name(),
3573 "Generic interface '%s' with explicit intrinsic %s of the same name may not have specific procedure '%s' that is a %s"_err_en_US,
3574 symbol.name(), isSubroutine ? "subroutine" : "function",
3575 ref->name(), isSubroutine ? "function" : "subroutine");
3576 }
3577 }
3578 }
3579 }
3580}
3581
3582void CheckHelper::CheckDefaultIntegerArg(
3583 const Symbol &subp, const Symbol *arg, Attr intent) {
3584 // Argument looks like: INTEGER, INTENT(intent) :: arg
3585 if (CheckDioDummyIsData(subp, arg, position: 1)) {
3586 CheckDioDummyIsDefaultInteger(subp, arg: *arg);
3587 CheckDioDummyIsScalar(subp, arg: *arg);
3588 CheckDioDummyAttrs(subp, *arg, intent);
3589 }
3590}
3591
3592void CheckHelper::CheckDioAssumedLenCharacterArg(const Symbol &subp,
3593 const Symbol *arg, std::size_t argPosition, Attr intent) {
3594 // Argument looks like: CHARACTER (LEN=*), INTENT(intent) :: (iotype OR iomsg)
3595 if (CheckDioDummyIsData(subp, arg, position: argPosition)) {
3596 CheckDioDummyAttrs(subp, *arg, intent);
3597 const DeclTypeSpec *type{arg ? arg->GetType() : nullptr};
3598 const IntrinsicTypeSpec *intrinsic{type ? type->AsIntrinsic() : nullptr};
3599 const auto kind{
3600 intrinsic ? evaluate::ToInt64(intrinsic->kind()) : std::nullopt};
3601 if (!IsAssumedLengthCharacter(*arg) ||
3602 (!kind ||
3603 *kind !=
3604 context_.defaultKinds().GetDefaultKind(
3605 TypeCategory::Character))) {
3606 messages_.Say(arg->name(),
3607 "Dummy argument '%s' of a defined input/output procedure must be assumed-length CHARACTER of default kind"_err_en_US,
3608 arg->name());
3609 }
3610 }
3611}
3612
3613void CheckHelper::CheckDioVlistArg(
3614 const Symbol &subp, const Symbol *arg, std::size_t argPosition) {
3615 // Vlist argument looks like: INTEGER, INTENT(IN) :: v_list(:)
3616 if (CheckDioDummyIsData(subp, arg, position: argPosition)) {
3617 CheckDioDummyIsDefaultInteger(subp, arg: *arg);
3618 CheckDioDummyAttrs(subp, *arg, Attr::INTENT_IN);
3619 const auto *objectDetails{arg->detailsIf<ObjectEntityDetails>()};
3620 if (!objectDetails || !objectDetails->shape().CanBeAssumedShape() ||
3621 objectDetails->shape().Rank() != 1) {
3622 messages_.Say(arg->name(),
3623 "Dummy argument '%s' of a defined input/output procedure must be assumed shape vector"_err_en_US,
3624 arg->name());
3625 }
3626 }
3627}
3628
3629void CheckHelper::CheckDioArgCount(
3630 const Symbol &subp, common::DefinedIo ioKind, std::size_t argCount) {
3631 const std::size_t requiredArgCount{
3632 (std::size_t)(ioKind == common::DefinedIo::ReadFormatted ||
3633 ioKind == common::DefinedIo::WriteFormatted
3634 ? 6
3635 : 4)};
3636 if (argCount != requiredArgCount) {
3637 SayWithDeclaration(subp,
3638 "Defined input/output procedure '%s' must have %d dummy arguments rather than %d"_err_en_US,
3639 subp.name(), requiredArgCount, argCount);
3640 context_.SetError(subp);
3641 }
3642}
3643
3644void CheckHelper::CheckDioDummyAttrs(
3645 const Symbol &subp, const Symbol &arg, Attr goodIntent) {
3646 // Defined I/O procedures can't have attributes other than INTENT
3647 Attrs attrs{arg.attrs()};
3648 if (!attrs.test(goodIntent)) {
3649 messages_.Say(arg.name(),
3650 "Dummy argument '%s' of a defined input/output procedure must have intent '%s'"_err_en_US,
3651 arg.name(), AttrToString(goodIntent));
3652 }
3653 attrs = attrs - Attr::INTENT_IN - Attr::INTENT_OUT - Attr::INTENT_INOUT;
3654 if (!attrs.empty()) {
3655 messages_.Say(arg.name(),
3656 "Dummy argument '%s' of a defined input/output procedure may not have any attributes"_err_en_US,
3657 arg.name());
3658 }
3659}
3660
3661// Enforce semantics for defined input/output procedures (12.6.4.8.2) and C777
3662void CheckHelper::CheckDefinedIoProc(const Symbol &symbol,
3663 const GenericDetails &details, common::DefinedIo ioKind) {
3664 for (auto ref : details.specificProcs()) {
3665 const Symbol &ultimate{ref->GetUltimate()};
3666 const auto *binding{ultimate.detailsIf<ProcBindingDetails>()};
3667 if (ultimate.attrs().test(Attr::NOPASS)) { // C774
3668 messages_.Say(
3669 "Defined input/output procedure '%s' may not have NOPASS attribute"_err_en_US,
3670 ultimate.name());
3671 context_.SetError(ultimate);
3672 }
3673 const Symbol *specificProc{binding ? &binding->symbol() : &ultimate};
3674 const Symbol *specificSubp{specificProc};
3675 if (const auto *peDetails{specificSubp->detailsIf<ProcEntityDetails>()}) {
3676 specificSubp = peDetails->procInterface();
3677 if (!specificSubp) {
3678 continue;
3679 }
3680 }
3681 if (const auto *subpDetails{specificSubp->detailsIf<SubprogramDetails>()}) {
3682 const std::vector<Symbol *> &dummyArgs{subpDetails->dummyArgs()};
3683 CheckDioArgCount(*specificSubp, ioKind, dummyArgs.size());
3684 int argCount{0};
3685 for (auto *arg : dummyArgs) {
3686 if (arg && arg->Corank() > 0) {
3687 evaluate::AttachDeclaration(
3688 messages_.Say(arg->name(),
3689 "Dummy argument '%s' of defined input/output procedure '%s' may not be a coarray"_err_en_US,
3690 arg->name(), ultimate.name()),
3691 *arg);
3692 }
3693 switch (argCount++) {
3694 case 0:
3695 // dtv-type-spec, INTENT(INOUT) :: dtv
3696 CheckDioDtvArg(*specificProc, *specificSubp, arg, ioKind, symbol);
3697 break;
3698 case 1:
3699 // INTEGER, INTENT(IN) :: unit
3700 CheckDefaultIntegerArg(*specificSubp, arg, Attr::INTENT_IN);
3701 break;
3702 case 2:
3703 if (ioKind == common::DefinedIo::ReadFormatted ||
3704 ioKind == common::DefinedIo::WriteFormatted) {
3705 // CHARACTER (LEN=*), INTENT(IN) :: iotype
3706 CheckDioAssumedLenCharacterArg(
3707 *specificSubp, arg, argCount, Attr::INTENT_IN);
3708 } else {
3709 // INTEGER, INTENT(OUT) :: iostat
3710 CheckDefaultIntegerArg(*specificSubp, arg, Attr::INTENT_OUT);
3711 }
3712 break;
3713 case 3:
3714 if (ioKind == common::DefinedIo::ReadFormatted ||
3715 ioKind == common::DefinedIo::WriteFormatted) {
3716 // INTEGER, INTENT(IN) :: v_list(:)
3717 CheckDioVlistArg(*specificSubp, arg, argCount);
3718 } else {
3719 // CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
3720 CheckDioAssumedLenCharacterArg(
3721 *specificSubp, arg, argCount, Attr::INTENT_INOUT);
3722 }
3723 break;
3724 case 4:
3725 // INTEGER, INTENT(OUT) :: iostat
3726 CheckDefaultIntegerArg(*specificSubp, arg, Attr::INTENT_OUT);
3727 break;
3728 case 5:
3729 // CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
3730 CheckDioAssumedLenCharacterArg(
3731 *specificSubp, arg, argCount, Attr::INTENT_INOUT);
3732 break;
3733 default:;
3734 }
3735 }
3736 }
3737 }
3738}
3739
3740void CheckHelper::CheckSymbolType(const Symbol &symbol) {
3741 const Symbol *result{FindFunctionResult(symbol)};
3742 const Symbol &relevant{result ? *result : symbol};
3743 if (IsAllocatable(relevant)) { // always ok
3744 } else if (IsProcedurePointer(symbol) && result && IsPointer(*result)) {
3745 // procedure pointer returning allocatable or pointer: ok
3746 } else if (IsPointer(relevant) && !IsProcedure(relevant)) {
3747 // object pointers are always ok
3748 } else if (auto dyType{evaluate::DynamicType::From(relevant)}) {
3749 if (dyType->IsPolymorphic() && !dyType->IsAssumedType() &&
3750 !(IsDummy(symbol) && !IsProcedure(relevant))) { // C708
3751 messages_.Say(
3752 "CLASS entity '%s' must be a dummy argument, allocatable, or object pointer"_err_en_US,
3753 symbol.name());
3754 }
3755 if (dyType->HasDeferredTypeParameter()) { // C702
3756 messages_.Say(
3757 "'%s' has a type %s with a deferred type parameter but is neither an allocatable nor an object pointer"_err_en_US,
3758 symbol.name(), dyType->AsFortran());
3759 }
3760 if (!symbol.has<ObjectEntityDetails>()) {
3761 if (const DerivedTypeSpec *
3762 derived{evaluate::GetDerivedTypeSpec(*dyType)}) {
3763 if (IsEventTypeOrLockType(derived)) {
3764 messages_.Say(
3765 "Entity '%s' with EVENT_TYPE or LOCK_TYPE must be an object"_err_en_US,
3766 symbol.name());
3767 } else if (auto iter{FindEventOrLockPotentialComponent(*derived)}) {
3768 messages_.Say(
3769 "Entity '%s' with EVENT_TYPE or LOCK_TYPE potential subobject component '%s' must be an object"_err_en_US,
3770 symbol.name(), iter.BuildResultDesignatorName());
3771 }
3772 }
3773 }
3774 }
3775}
3776
3777void CheckHelper::CheckModuleProcedureDef(const Symbol &symbol) {
3778 auto procClass{ClassifyProcedure(symbol)};
3779 if (const auto *subprogram{symbol.detailsIf<SubprogramDetails>()};
3780 subprogram &&
3781 (procClass == ProcedureDefinitionClass::Module &&
3782 symbol.attrs().test(Attr::MODULE)) &&
3783 !subprogram->bindName() && !subprogram->isInterface()) {
3784 const Symbol &interface {
3785 subprogram->moduleInterface() ? *subprogram->moduleInterface() : symbol
3786 };
3787 if (const Symbol *
3788 module{interface.owner().kind() == Scope::Kind::Module
3789 ? interface.owner().symbol()
3790 : nullptr};
3791 module && module->has<ModuleDetails>()) {
3792 std::pair<SourceName, const Symbol *> key{symbol.name(), module};
3793 auto iter{moduleProcs_.find(key)};
3794 if (iter == moduleProcs_.end()) {
3795 moduleProcs_.emplace(std::move(key), symbol);
3796 } else if (
3797 auto *msg{messages_.Say(symbol.name(),
3798 "Module procedure '%s' in '%s' has multiple definitions"_err_en_US,
3799 symbol.name(), GetModuleOrSubmoduleName(*module))}) {
3800 msg->Attach(iter->second->name(), "Previous definition of '%s'"_en_US,
3801 symbol.name());
3802 }
3803 }
3804 }
3805}
3806
3807void SubprogramMatchHelper::Check(
3808 const Symbol &symbol1, const Symbol &symbol2) {
3809 const auto details1{symbol1.get<SubprogramDetails>()};
3810 const auto details2{symbol2.get<SubprogramDetails>()};
3811 if (details1.isFunction() != details2.isFunction()) {
3812 Say(symbol1, symbol2,
3813 details1.isFunction()
3814 ? "Module function '%s' was declared as a subroutine in the"
3815 " corresponding interface body"_err_en_US
3816 : "Module subroutine '%s' was declared as a function in the"
3817 " corresponding interface body"_err_en_US);
3818 return;
3819 }
3820 const auto &args1{details1.dummyArgs()};
3821 const auto &args2{details2.dummyArgs()};
3822 int nargs1{static_cast<int>(args1.size())};
3823 int nargs2{static_cast<int>(args2.size())};
3824 if (nargs1 != nargs2) {
3825 Say(symbol1, symbol2,
3826 "Module subprogram '%s' has %d args but the corresponding interface"
3827 " body has %d"_err_en_US,
3828 nargs1, nargs2);
3829 return;
3830 }
3831 bool nonRecursive1{symbol1.attrs().test(Attr::NON_RECURSIVE)};
3832 if (nonRecursive1 != symbol2.attrs().test(Attr::NON_RECURSIVE)) { // C1551
3833 Say(symbol1, symbol2,
3834 nonRecursive1
3835 ? "Module subprogram '%s' has NON_RECURSIVE prefix but"
3836 " the corresponding interface body does not"_err_en_US
3837 : "Module subprogram '%s' does not have NON_RECURSIVE prefix but "
3838 "the corresponding interface body does"_err_en_US);
3839 }
3840 const std::string *bindName1{details1.bindName()};
3841 const std::string *bindName2{details2.bindName()};
3842 if (!bindName1 && !bindName2) {
3843 // OK - neither has a binding label
3844 } else if (!bindName1) {
3845 Say(symbol1, symbol2,
3846 "Module subprogram '%s' does not have a binding label but the"
3847 " corresponding interface body does"_err_en_US);
3848 } else if (!bindName2) {
3849 Say(symbol1, symbol2,
3850 "Module subprogram '%s' has a binding label but the"
3851 " corresponding interface body does not"_err_en_US);
3852 } else if (*bindName1 != *bindName2) {
3853 Say(symbol1, symbol2,
3854 "Module subprogram '%s' has binding label '%s' but the corresponding"
3855 " interface body has '%s'"_err_en_US,
3856 *details1.bindName(), *details2.bindName());
3857 }
3858 const Procedure *proc1{checkHelper.Characterize(symbol1)};
3859 const Procedure *proc2{checkHelper.Characterize(symbol2)};
3860 if (!proc1 || !proc2) {
3861 return;
3862 }
3863 if (proc1->attrs.test(Procedure::Attr::Pure) !=
3864 proc2->attrs.test(Procedure::Attr::Pure)) {
3865 Say(symbol1, symbol2,
3866 "Module subprogram '%s' and its corresponding interface body are not both PURE"_err_en_US);
3867 }
3868 if (proc1->attrs.test(Procedure::Attr::Elemental) !=
3869 proc2->attrs.test(Procedure::Attr::Elemental)) {
3870 Say(symbol1, symbol2,
3871 "Module subprogram '%s' and its corresponding interface body are not both ELEMENTAL"_err_en_US);
3872 }
3873 if (proc1->attrs.test(Procedure::Attr::BindC) !=
3874 proc2->attrs.test(Procedure::Attr::BindC)) {
3875 Say(symbol1, symbol2,
3876 "Module subprogram '%s' and its corresponding interface body are not both BIND(C)"_err_en_US);
3877 }
3878 if (proc1->functionResult && proc2->functionResult) {
3879 std::string whyNot;
3880 if (!proc1->functionResult->IsCompatibleWith(
3881 *proc2->functionResult, &whyNot)) {
3882 Say(symbol1, symbol2,
3883 "Result of function '%s' is not compatible with the result of the corresponding interface body: %s"_err_en_US,
3884 whyNot);
3885 }
3886 }
3887 for (int i{0}; i < nargs1; ++i) {
3888 const Symbol *arg1{args1[i]};
3889 const Symbol *arg2{args2[i]};
3890 if (arg1 && !arg2) {
3891 Say(symbol1, symbol2,
3892 "Dummy argument %2$d of '%1$s' is not an alternate return indicator"
3893 " but the corresponding argument in the interface body is"_err_en_US,
3894 i + 1);
3895 } else if (!arg1 && arg2) {
3896 Say(symbol1, symbol2,
3897 "Dummy argument %2$d of '%1$s' is an alternate return indicator but"
3898 " the corresponding argument in the interface body is not"_err_en_US,
3899 i + 1);
3900 } else if (arg1 && arg2) {
3901 SourceName name1{arg1->name()};
3902 SourceName name2{arg2->name()};
3903 if (name1 != name2) {
3904 Say(*arg1, *arg2,
3905 "Dummy argument name '%s' does not match corresponding name '%s'"
3906 " in interface body"_err_en_US,
3907 name2);
3908 } else {
3909 CheckDummyArg(
3910 *arg1, *arg2, proc1->dummyArguments[i], proc2->dummyArguments[i]);
3911 }
3912 }
3913 }
3914}
3915
3916void SubprogramMatchHelper::CheckDummyArg(const Symbol &symbol1,
3917 const Symbol &symbol2, const DummyArgument &arg1,
3918 const DummyArgument &arg2) {
3919 common::visit(
3920 common::visitors{
3921 [&](const DummyDataObject &obj1, const DummyDataObject &obj2) {
3922 CheckDummyDataObject(symbol1, symbol2, obj1, obj2);
3923 },
3924 [&](const DummyProcedure &proc1, const DummyProcedure &proc2) {
3925 CheckDummyProcedure(symbol1, symbol2, proc1, proc2);
3926 },
3927 [&](const DummyDataObject &, const auto &) {
3928 Say(symbol1, symbol2,
3929 "Dummy argument '%s' is a data object; the corresponding"
3930 " argument in the interface body is not"_err_en_US);
3931 },
3932 [&](const DummyProcedure &, const auto &) {
3933 Say(symbol1, symbol2,
3934 "Dummy argument '%s' is a procedure; the corresponding"
3935 " argument in the interface body is not"_err_en_US);
3936 },
3937 [&](const auto &, const auto &) {
3938 llvm_unreachable("Dummy arguments are not data objects or"
3939 "procedures");
3940 },
3941 },
3942 arg1.u, arg2.u);
3943}
3944
3945void SubprogramMatchHelper::CheckDummyDataObject(const Symbol &symbol1,
3946 const Symbol &symbol2, const DummyDataObject &obj1,
3947 const DummyDataObject &obj2) {
3948 if (!CheckSameIntent(symbol1, symbol2, obj1.intent, obj2.intent)) {
3949 } else if (!CheckSameAttrs(symbol1, symbol2, obj1.attrs, obj2.attrs)) {
3950 } else if (!obj1.type.type().IsEquivalentTo(obj2.type.type())) {
3951 Say(symbol1, symbol2,
3952 "Dummy argument '%s' has type %s; the corresponding argument in the interface body has distinct type %s"_err_en_US,
3953 obj1.type.type().AsFortran(), obj2.type.type().AsFortran());
3954 } else if (!ShapesAreCompatible(obj1, obj2)) {
3955 Say(symbol1, symbol2,
3956 "The shape of dummy argument '%s' does not match the shape of the"
3957 " corresponding argument in the interface body"_err_en_US);
3958 }
3959 // TODO: coshape
3960}
3961
3962void SubprogramMatchHelper::CheckDummyProcedure(const Symbol &symbol1,
3963 const Symbol &symbol2, const DummyProcedure &proc1,
3964 const DummyProcedure &proc2) {
3965 std::string whyNot;
3966 if (!CheckSameIntent(symbol1, symbol2, proc1.intent, proc2.intent)) {
3967 } else if (!CheckSameAttrs(symbol1, symbol2, proc1.attrs, proc2.attrs)) {
3968 } else if (!proc2.IsCompatibleWith(proc1, &whyNot)) {
3969 Say(symbol1, symbol2,
3970 "Dummy procedure '%s' is not compatible with the corresponding argument in the interface body: %s"_err_en_US,
3971 whyNot);
3972 } else if (proc1 != proc2) {
3973 evaluate::AttachDeclaration(
3974 symbol1.owner().context().Warn(
3975 common::UsageWarning::MismatchingDummyProcedure,
3976 "Dummy procedure '%s' does not exactly match the corresponding argument in the interface body"_warn_en_US,
3977 symbol1.name()),
3978 symbol2);
3979 }
3980}
3981
3982bool SubprogramMatchHelper::CheckSameIntent(const Symbol &symbol1,
3983 const Symbol &symbol2, common::Intent intent1, common::Intent intent2) {
3984 if (intent1 == intent2) {
3985 return true;
3986 } else {
3987 Say(symbol1, symbol2,
3988 "The intent of dummy argument '%s' does not match the intent"
3989 " of the corresponding argument in the interface body"_err_en_US);
3990 return false;
3991 }
3992}
3993
3994// Report an error referring to first symbol with declaration of second symbol
3995template <typename... A>
3996void SubprogramMatchHelper::Say(const Symbol &symbol1, const Symbol &symbol2,
3997 parser::MessageFixedText &&text, A &&...args) {
3998 auto &message{context().Say(symbol1.name(), std::move(text), symbol1.name(),
3999 std::forward<A>(args)...)};
4000 evaluate::AttachDeclaration(message, symbol2);
4001}
4002
4003template <typename ATTRS>
4004bool SubprogramMatchHelper::CheckSameAttrs(
4005 const Symbol &symbol1, const Symbol &symbol2, ATTRS attrs1, ATTRS attrs2) {
4006 if (attrs1 == attrs2) {
4007 return true;
4008 }
4009 attrs1.IterateOverMembers([&](auto attr) {
4010 if (!attrs2.test(attr)) {
4011 Say(symbol1, symbol2,
4012 "Dummy argument '%s' has the %s attribute; the corresponding"
4013 " argument in the interface body does not"_err_en_US,
4014 AsFortran(attr));
4015 }
4016 });
4017 attrs2.IterateOverMembers([&](auto attr) {
4018 if (!attrs1.test(attr)) {
4019 Say(symbol1, symbol2,
4020 "Dummy argument '%s' does not have the %s attribute; the"
4021 " corresponding argument in the interface body does"_err_en_US,
4022 AsFortran(attr));
4023 }
4024 });
4025 return false;
4026}
4027
4028bool SubprogramMatchHelper::ShapesAreCompatible(
4029 const DummyDataObject &obj1, const DummyDataObject &obj2) {
4030 return characteristics::ShapesAreCompatible(
4031 FoldShape(obj1.type.shape()), FoldShape(obj2.type.shape()));
4032}
4033
4034evaluate::Shape SubprogramMatchHelper::FoldShape(const evaluate::Shape &shape) {
4035 evaluate::Shape result;
4036 for (const auto &extent : shape) {
4037 result.emplace_back(
4038 evaluate::Fold(context().foldingContext(), common::Clone(extent)));
4039 }
4040 return result;
4041}
4042
4043void DistinguishabilityHelper::Add(const Symbol &generic, GenericKind kind,
4044 const Symbol &specific, const Procedure &procedure) {
4045 const Symbol &ultimate{specific.GetUltimate()};
4046 if (!context_.HasError(ultimate)) {
4047 nameToSpecifics_[generic.name()].emplace(
4048 &ultimate, ProcedureInfo{kind, procedure});
4049 }
4050}
4051
4052void DistinguishabilityHelper::Check(const Scope &scope) {
4053 if (FindModuleFileContaining(scope)) {
4054 // Distinguishability was checked when the module was created;
4055 // don't let optional warnings then become errors now.
4056 return;
4057 }
4058 for (const auto &[name, info] : nameToSpecifics_) {
4059 for (auto iter1{info.begin()}; iter1 != info.end(); ++iter1) {
4060 const auto &[ultimate, procInfo]{*iter1};
4061 const auto &[kind, proc]{procInfo};
4062 for (auto iter2{iter1}; ++iter2 != info.end();) {
4063 const auto &[ultimate2, procInfo2]{*iter2};
4064 if (&*ultimate == &*ultimate2) {
4065 continue; // ok, actually the same procedure/binding
4066 } else if (const auto *binding1{
4067 ultimate->detailsIf<ProcBindingDetails>()}) {
4068 if (const auto *binding2{
4069 ultimate2->detailsIf<ProcBindingDetails>()}) {
4070 if (&binding1->symbol().GetUltimate() ==
4071 &binding2->symbol().GetUltimate()) {
4072 continue; // ok, (NOPASS) bindings resolve identically
4073 } else if (ultimate->name() == ultimate2->name()) {
4074 continue; // override, possibly of DEFERRED
4075 }
4076 }
4077 } else if (ultimate->has<ProcBindingDetails>() &&
4078 ultimate2->has<ProcBindingDetails>() &&
4079 ultimate->name() == ultimate2->name()) {
4080 continue; // override, possibly of DEFERRED
4081 }
4082 auto distinguishable{kind.IsName()
4083 ? evaluate::characteristics::Distinguishable
4084 : evaluate::characteristics::DistinguishableOpOrAssign};
4085 std::optional<bool> distinct{distinguishable(
4086 context_.languageFeatures(), proc, procInfo2.procedure)};
4087 if (!distinct.value_or(false)) {
4088 SayNotDistinguishable(GetTopLevelUnitContaining(scope), name, kind,
4089 *ultimate, *ultimate2, distinct.has_value());
4090 }
4091 }
4092 }
4093 }
4094}
4095
4096void DistinguishabilityHelper::SayNotDistinguishable(const Scope &scope,
4097 const SourceName &name, GenericKind kind, const Symbol &proc1,
4098 const Symbol &proc2, bool isHardConflict) {
4099 bool isUseAssociated{!scope.sourceRange().Contains(name)};
4100 // The rules for distinguishing specific procedures (F'2023 15.4.3.4.5)
4101 // are inadequate for some real-world cases like pFUnit.
4102 // When there are optional dummy arguments or unlimited polymorphic
4103 // dummy data object arguments, the best that we can do is emit an optional
4104 // portability warning. Also, named generics created by USE association
4105 // merging shouldn't receive hard errors for ambiguity.
4106 // (Non-named generics might be defined I/O procedures or defined
4107 // assignments that need to be used by the runtime.)
4108 bool isWarning{!isHardConflict || (isUseAssociated && kind.IsName())};
4109 if (isWarning &&
4110 (!context_.ShouldWarn(
4111 common::LanguageFeature::IndistinguishableSpecifics) ||
4112 FindModuleFileContaining(scope))) {
4113 return;
4114 }
4115 std::string name1{proc1.name().ToString()};
4116 std::string name2{proc2.name().ToString()};
4117 if (kind.IsOperator() || kind.IsAssignment()) {
4118 // proc1 and proc2 may come from different scopes so qualify their names
4119 if (proc1.owner().IsDerivedType()) {
4120 name1 = proc1.owner().GetName()->ToString() + '%' + name1;
4121 }
4122 if (proc2.owner().IsDerivedType()) {
4123 name2 = proc2.owner().GetName()->ToString() + '%' + name2;
4124 }
4125 }
4126 parser::Message *msg;
4127 if (!isUseAssociated) {
4128 CHECK(isWarning == !isHardConflict);
4129 msg = &context_.Say(name,
4130 isHardConflict
4131 ? "Generic '%s' may not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_err_en_US
4132 : "Generic '%s' should not have specific procedures '%s' and '%s' as their interfaces are not distinguishable by the rules in the standard"_port_en_US,
4133 MakeOpName(name), name1, name2);
4134 } else {
4135 msg = &context_.Say(*GetTopLevelUnitContaining(proc1).GetName(),
4136 isHardConflict
4137 ? (isWarning
4138 ? "USE-associated generic '%s' should not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_warn_en_US
4139 : "USE-associated generic '%s' may not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_err_en_US)
4140 : "USE-associated generic '%s' should not have specific procedures '%s' and '%s' as their interfaces are not distinguishable by the rules in the standard"_port_en_US,
4141 MakeOpName(name), name1, name2);
4142 }
4143 AttachDeclaration(*msg, scope, proc1);
4144 AttachDeclaration(*msg, scope, proc2);
4145}
4146
4147// `evaluate::AttachDeclaration` doesn't handle the generic case where `proc`
4148// comes from a different module but is not necessarily use-associated.
4149void DistinguishabilityHelper::AttachDeclaration(
4150 parser::Message &msg, const Scope &scope, const Symbol &proc) {
4151 const Scope &unit{GetTopLevelUnitContaining(proc)};
4152 if (unit == scope) {
4153 evaluate::AttachDeclaration(msg, proc);
4154 } else {
4155 msg.Attach(unit.GetName().value(),
4156 "'%s' is USE-associated from module '%s'"_en_US, proc.name(),
4157 unit.GetName().value());
4158 }
4159}
4160
4161void CheckDeclarations(SemanticsContext &context) {
4162 CheckHelper{context}.Check();
4163}
4164} // namespace Fortran::semantics
4165

Provided by KDAB

Privacy Policy
Update your C++ knowledge – Modern C++11/14/17 Training
Find out more

source code of flang/lib/Semantics/check-declarations.cpp