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 | |
27 | namespace Fortran::semantics { |
28 | |
29 | namespace characteristics = evaluate::characteristics; |
30 | using characteristics::DummyArgument; |
31 | using characteristics::DummyDataObject; |
32 | using characteristics::DummyProcedure; |
33 | using characteristics::FunctionResult; |
34 | using characteristics::Procedure; |
35 | |
36 | class DistinguishabilityHelper; |
37 | |
38 | class CheckHelper { |
39 | public: |
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 | |
59 | private: |
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 | |
211 | class DistinguishabilityHelper { |
212 | public: |
213 | DistinguishabilityHelper(SemanticsContext &context) : context_{context} {} |
214 | void Add(const Symbol &, GenericKind, const Symbol &, const Procedure &); |
215 | void Check(const Scope &); |
216 | |
217 | private: |
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 | |
231 | void 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 | |
242 | void CheckHelper::Check(const ArraySpec &shape) { |
243 | for (const auto &spec : shape) { |
244 | Check(spec); |
245 | } |
246 | } |
247 | |
248 | void 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 | |
259 | static bool IsBlockData(const Scope &scope) { |
260 | return scope.kind() == Scope::Kind::BlockData; |
261 | } |
262 | |
263 | static bool IsBlockData(const Symbol &symbol) { |
264 | return symbol.scope() && IsBlockData(*symbol.scope()); |
265 | } |
266 | |
267 | void 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 | |
521 | void 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 |
536 | void 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 | |
567 | void 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 | |
623 | void 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 | |
666 | void 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 | |
1201 | void 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 |
1270 | void 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 | |
1344 | void 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 |
1411 | class SubprogramMatchHelper { |
1412 | public: |
1413 | explicit SubprogramMatchHelper(CheckHelper &checkHelper) |
1414 | : checkHelper{checkHelper} {} |
1415 | |
1416 | void Check(const Symbol &, const Symbol &); |
1417 | |
1418 | private: |
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? |
1453 | bool 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 | |
1473 | void 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 | |
1638 | void 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 | |
1710 | void 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 |
1786 | bool 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 | |
1891 | bool 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 | |
1913 | void 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 | |
1928 | void 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 |
1953 | void 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 | |
2022 | void 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 | |
2029 | static 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 | |
2047 | static 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 | |
2059 | static 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). |
2109 | bool 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. |
2160 | std::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 | |
2204 | bool 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). |
2240 | bool 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 | |
2272 | bool 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 |
2326 | bool 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 | |
2336 | void 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 | |
2370 | const 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 | |
2380 | void 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 | |
2404 | void 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 | |
2422 | void 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 |
2441 | void 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 | |
2554 | void 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 | |
2669 | void 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 | |
2742 | void 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 | |
2781 | static 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 | |
2790 | void 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 | |
2849 | void 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. |
2872 | void 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 | |
2928 | static 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 | |
2934 | static bool IsExternalProcedureDefinition(const Symbol &symbol) { |
2935 | return IsBlockData(symbol) || |
2936 | (IsSubprogramDefinition(symbol) && |
2937 | (IsExternal(symbol) || symbol.GetBindName())); |
2938 | } |
2939 | |
2940 | static 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 | |
2961 | static 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 |
2970 | void 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 | |
3007 | void 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 | |
3044 | parser::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 | |
3156 | parser::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 | |
3267 | parser::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 | |
3294 | parser::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 | |
3367 | void 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 | |
3433 | bool 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 | |
3456 | void 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 | |
3493 | void 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 | |
3513 | void 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 | |
3527 | void 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 | |
3535 | void 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 |
3550 | void 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 | |
3582 | void 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 | |
3592 | void 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 | |
3613 | void 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 | |
3629 | void 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 | |
3644 | void 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 |
3662 | void 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 | |
3740 | void 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 | |
3777 | void 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 | |
3807 | void 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 | |
3916 | void 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 | |
3945 | void 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 | |
3962 | void 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 | |
3982 | bool 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 |
3995 | template <typename... A> |
3996 | void 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 | |
4003 | template <typename ATTRS> |
4004 | bool 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 | |
4028 | bool SubprogramMatchHelper::ShapesAreCompatible( |
4029 | const DummyDataObject &obj1, const DummyDataObject &obj2) { |
4030 | return characteristics::ShapesAreCompatible( |
4031 | FoldShape(obj1.type.shape()), FoldShape(obj2.type.shape())); |
4032 | } |
4033 | |
4034 | evaluate::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 | |
4043 | void 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 | |
4052 | void 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 | |
4096 | void 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. |
4149 | void 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 | |
4161 | void CheckDeclarations(SemanticsContext &context) { |
4162 | CheckHelper{context}.Check(); |
4163 | } |
4164 | } // namespace Fortran::semantics |
4165 |
Definitions
- CheckHelper
- CheckHelper
- context
- Check
- Check
- Check
- CheckSpecExpr
- InPure
- InElemental
- InFunction
- InInterface
- SayWithDeclaration
- InModuleFile
- Warn
- Warn
- TypeWithDefinedIo
- DistinguishabilityHelper
- DistinguishabilityHelper
- ProcedureInfo
- Check
- Check
- Check
- IsBlockData
- IsBlockData
- Check
- CheckCommonBlock
- CheckExplicitSave
- CheckValue
- CheckAssumedTypeEntity
- CheckObjectEntity
- CheckPointerInitialization
- CheckArraySpec
- CheckProcEntity
- SubprogramMatchHelper
- SubprogramMatchHelper
- context
- FoldShape
- AsFortran
- AsFortran
- IsResultOkToDiffer
- CheckSubprogram
- CheckExternal
- CheckDerivedType
- CheckFinal
- CheckDistinguishableFinals
- CheckHostAssoc
- CheckGeneric
- CollectSpecifics
- CheckSpecifics
- CUDAHostDeviceDiffer
- ConflictsWithIntrinsicAssignment
- ConflictsWithIntrinsicOperator
- CheckDefinedOperator
- CheckNumberOfArgs
- CheckDefinedOperatorArg
- CheckDefinedAssignment
- CheckDefinedAssignmentArg
- CheckConflicting
- WarnMissingFinal
- Characterize
- CheckVolatile
- CheckContiguous
- CheckPointer
- CheckPassArg
- CheckProcBinding
- Check
- CheckEquivalenceSet
- InCommonWithBind
- CheckEquivalenceObject
- CheckBlockData
- CheckGenericOps
- IsSubprogramDefinition
- IsExternalProcedureDefinition
- DefinesGlobalName
- IsSameSymbolFromHermeticModule
- CheckGlobalName
- CheckProcedureAssemblyName
- WhyNotInteroperableDerivedType
- WhyNotInteroperableObject
- WhyNotInteroperableFunctionResult
- WhyNotInteroperableProcedure
- CheckBindC
- CheckDioDummyIsData
- CheckAlreadySeenDefinedIo
- CheckDioDummyIsDerived
- CheckDioDummyIsDefaultInteger
- CheckDioDummyIsScalar
- CheckDioDtvArg
- CheckGenericVsIntrinsic
- CheckDefaultIntegerArg
- CheckDioAssumedLenCharacterArg
- CheckDioVlistArg
- CheckDioArgCount
- CheckDioDummyAttrs
- CheckDefinedIoProc
- CheckSymbolType
- CheckModuleProcedureDef
- Check
- CheckDummyArg
- CheckDummyDataObject
- CheckDummyProcedure
- CheckSameIntent
- Say
- CheckSameAttrs
- ShapesAreCompatible
- FoldShape
- Add
- Check
- SayNotDistinguishable
- AttachDeclaration
Update your C++ knowledge – Modern C++11/14/17 Training
Find out more