1//===-- lib/Evaluate/characteristics.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#include "flang/Evaluate/characteristics.h"
10#include "flang/Common/indirection.h"
11#include "flang/Evaluate/check-expression.h"
12#include "flang/Evaluate/fold.h"
13#include "flang/Evaluate/intrinsics.h"
14#include "flang/Evaluate/tools.h"
15#include "flang/Evaluate/type.h"
16#include "flang/Parser/message.h"
17#include "flang/Semantics/scope.h"
18#include "flang/Semantics/symbol.h"
19#include "flang/Semantics/tools.h"
20#include "llvm/Support/raw_ostream.h"
21#include <initializer_list>
22
23using namespace Fortran::parser::literals;
24
25namespace Fortran::evaluate::characteristics {
26
27// Copy attributes from a symbol to dst based on the mapping in pairs.
28// An ASYNCHRONOUS attribute counts even if it is implied.
29template <typename A, typename B>
30static void CopyAttrs(const semantics::Symbol &src, A &dst,
31 const std::initializer_list<std::pair<semantics::Attr, B>> &pairs) {
32 for (const auto &pair : pairs) {
33 if (src.attrs().test(pair.first)) {
34 dst.attrs.set(pair.second);
35 }
36 }
37}
38
39// Shapes of function results and dummy arguments have to have
40// the same rank, the same deferred dimensions, and the same
41// values for explicit dimensions when constant.
42bool ShapesAreCompatible(const std::optional<Shape> &x,
43 const std::optional<Shape> &y, bool *possibleWarning) {
44 if (!x || !y) {
45 return !x && !y;
46 }
47 if (x->size() != y->size()) {
48 return false;
49 }
50 auto yIter{y->begin()};
51 for (const auto &xDim : *x) {
52 const auto &yDim{*yIter++};
53 if (xDim && yDim) {
54 if (auto equiv{AreEquivalentInInterface(*xDim, *yDim)}) {
55 if (!*equiv) {
56 return false;
57 }
58 } else if (possibleWarning) {
59 *possibleWarning = true;
60 }
61 } else if (xDim || yDim) {
62 return false;
63 }
64 }
65 return true;
66}
67
68bool TypeAndShape::operator==(const TypeAndShape &that) const {
69 return type_.IsEquivalentTo(that.type_) &&
70 ShapesAreCompatible(shape_, that.shape_) && attrs_ == that.attrs_ &&
71 corank_ == that.corank_;
72}
73
74TypeAndShape &TypeAndShape::Rewrite(FoldingContext &context) {
75 LEN_ = Fold(context, std::move(LEN_));
76 if (LEN_) {
77 if (auto n{ToInt64(*LEN_)}) {
78 type_ = DynamicType{type_.kind(), *n};
79 }
80 }
81 shape_ = Fold(context, std::move(shape_));
82 return *this;
83}
84
85std::optional<TypeAndShape> TypeAndShape::Characterize(
86 const semantics::Symbol &symbol, FoldingContext &context,
87 bool invariantOnly) {
88 const auto &ultimate{symbol.GetUltimate()};
89 return common::visit(
90 common::visitors{
91 [&](const semantics::ProcEntityDetails &proc) {
92 if (proc.procInterface()) {
93 return Characterize(
94 *proc.procInterface(), context, invariantOnly);
95 } else if (proc.type()) {
96 return Characterize(*proc.type(), context, invariantOnly);
97 } else {
98 return std::optional<TypeAndShape>{};
99 }
100 },
101 [&](const semantics::AssocEntityDetails &assoc) {
102 return Characterize(assoc, context, invariantOnly);
103 },
104 [&](const semantics::ProcBindingDetails &binding) {
105 return Characterize(binding.symbol(), context, invariantOnly);
106 },
107 [&](const auto &x) -> std::optional<TypeAndShape> {
108 using Ty = std::decay_t<decltype(x)>;
109 if constexpr (std::is_same_v<Ty, semantics::EntityDetails> ||
110 std::is_same_v<Ty, semantics::ObjectEntityDetails> ||
111 std::is_same_v<Ty, semantics::TypeParamDetails>) {
112 if (const semantics::DeclTypeSpec * type{ultimate.GetType()}) {
113 if (auto dyType{DynamicType::From(*type)}) {
114 TypeAndShape result{std::move(*dyType),
115 GetShape(context, ultimate, invariantOnly)};
116 result.AcquireAttrs(ultimate);
117 result.AcquireLEN(ultimate);
118 return std::move(result.Rewrite(context));
119 }
120 }
121 }
122 return std::nullopt;
123 },
124 },
125 // GetUltimate() used here, not ResolveAssociations(), because
126 // we need the type/rank of an associate entity from TYPE IS,
127 // CLASS IS, or RANK statement.
128 ultimate.details());
129}
130
131std::optional<TypeAndShape> TypeAndShape::Characterize(
132 const semantics::AssocEntityDetails &assoc, FoldingContext &context,
133 bool invariantOnly) {
134 std::optional<TypeAndShape> result;
135 if (auto type{DynamicType::From(assoc.type())}) {
136 if (auto rank{assoc.rank()}) {
137 if (*rank >= 0 && *rank <= common::maxRank) {
138 result = TypeAndShape{std::move(*type), Shape(*rank)};
139 }
140 } else if (auto shape{GetShape(context, assoc.expr(), invariantOnly)}) {
141 result = TypeAndShape{std::move(*type), std::move(*shape)};
142 }
143 if (result && type->category() == TypeCategory::Character) {
144 if (const auto *chExpr{UnwrapExpr<Expr<SomeCharacter>>(assoc.expr())}) {
145 if (auto len{chExpr->LEN()}) {
146 result->set_LEN(std::move(*len));
147 }
148 }
149 }
150 }
151 return Fold(context, std::move(result));
152}
153
154std::optional<TypeAndShape> TypeAndShape::Characterize(
155 const semantics::DeclTypeSpec &spec, FoldingContext &context,
156 bool /*invariantOnly=*/) {
157 if (auto type{DynamicType::From(spec)}) {
158 return Fold(context, TypeAndShape{std::move(*type)});
159 } else {
160 return std::nullopt;
161 }
162}
163
164std::optional<TypeAndShape> TypeAndShape::Characterize(
165 const ActualArgument &arg, FoldingContext &context, bool invariantOnly) {
166 if (const auto *expr{arg.UnwrapExpr()}) {
167 return Characterize(*expr, context, invariantOnly);
168 } else if (const Symbol * assumed{arg.GetAssumedTypeDummy()}) {
169 return Characterize(*assumed, context, invariantOnly);
170 } else {
171 return std::nullopt;
172 }
173}
174
175bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages,
176 const TypeAndShape &that, const char *thisIs, const char *thatIs,
177 bool omitShapeConformanceCheck,
178 enum CheckConformanceFlags::Flags flags) const {
179 if (!type_.IsTkCompatibleWith(that.type_)) {
180 messages.Say(
181 "%1$s type '%2$s' is not compatible with %3$s type '%4$s'"_err_en_US,
182 thatIs, that.AsFortran(), thisIs, AsFortran());
183 return false;
184 }
185 return omitShapeConformanceCheck || (!shape_ && !that.shape_) ||
186 (shape_ && that.shape_ &&
187 CheckConformance(
188 messages, *shape_, *that.shape_, flags, thisIs, thatIs)
189 .value_or(true /*fail only when nonconformance is known now*/));
190}
191
192std::optional<Expr<SubscriptInteger>> TypeAndShape::MeasureElementSizeInBytes(
193 FoldingContext &foldingContext, bool align) const {
194 if (LEN_) {
195 CHECK(type_.category() == TypeCategory::Character);
196 return Fold(foldingContext,
197 Expr<SubscriptInteger>{
198 foldingContext.targetCharacteristics().GetByteSize(
199 type_.category(), type_.kind())} *
200 Expr<SubscriptInteger>{*LEN_});
201 }
202 if (auto elementBytes{type_.MeasureSizeInBytes(foldingContext, align)}) {
203 return Fold(foldingContext, std::move(*elementBytes));
204 }
205 return std::nullopt;
206}
207
208std::optional<Expr<SubscriptInteger>> TypeAndShape::MeasureSizeInBytes(
209 FoldingContext &foldingContext) const {
210 if (auto elements{GetSize(shape_)}) {
211 // Sizes of arrays (even with single elements) are multiples of
212 // their alignments.
213 if (auto elementBytes{
214 MeasureElementSizeInBytes(foldingContext, Rank() > 0)}) {
215 return Fold(
216 foldingContext, std::move(*elements) * std::move(*elementBytes));
217 }
218 }
219 return std::nullopt;
220}
221
222void TypeAndShape::AcquireAttrs(const semantics::Symbol &symbol) {
223 if (IsAssumedShape(symbol)) {
224 attrs_.set(Attr::AssumedShape);
225 } else if (IsDeferredShape(symbol)) {
226 attrs_.set(Attr::DeferredShape);
227 } else if (semantics::IsAssumedSizeArray(symbol)) {
228 attrs_.set(Attr::AssumedSize);
229 }
230 if (int corank{GetCorank(symbol)}; corank > 0) {
231 corank_ = corank;
232 }
233 if (const auto *object{
234 symbol.GetUltimate().detailsIf<semantics::ObjectEntityDetails>()};
235 object && object->IsAssumedRank()) {
236 attrs_.set(Attr::AssumedRank);
237 }
238}
239
240void TypeAndShape::AcquireLEN() {
241 if (auto len{type_.GetCharLength()}) {
242 LEN_ = std::move(len);
243 }
244}
245
246void TypeAndShape::AcquireLEN(const semantics::Symbol &symbol) {
247 if (type_.category() == TypeCategory::Character) {
248 if (auto len{DataRef{symbol}.LEN()}) {
249 LEN_ = std::move(*len);
250 }
251 }
252}
253
254std::string TypeAndShape::AsFortran() const {
255 return type_.AsFortran(LEN_ ? LEN_->AsFortran() : "");
256}
257
258llvm::raw_ostream &TypeAndShape::Dump(llvm::raw_ostream &o) const {
259 o << type_.AsFortran(LEN_ ? LEN_->AsFortran() : "");
260 attrs_.Dump(o, EnumToString);
261 if (!shape_) {
262 o << " dimension(..)";
263 } else if (!shape_->empty()) {
264 o << " dimension";
265 char sep{'('};
266 for (const auto &expr : *shape_) {
267 o << sep;
268 sep = ',';
269 if (expr) {
270 expr->AsFortran(o);
271 } else {
272 o << ':';
273 }
274 }
275 o << ')';
276 }
277 if (isPossibleSequenceAssociation_) {
278 o << " isPossibleSequenceAssociation";
279 }
280 return o;
281}
282
283bool DummyDataObject::operator==(const DummyDataObject &that) const {
284 return type == that.type && attrs == that.attrs && intent == that.intent &&
285 coshape == that.coshape && cudaDataAttr == that.cudaDataAttr;
286}
287
288static bool IsOkWithSequenceAssociation(
289 const TypeAndShape &t1, const TypeAndShape &t2) {
290 return t1.isPossibleSequenceAssociation() &&
291 (t2.isPossibleSequenceAssociation() || t2.CanBeSequenceAssociated());
292}
293
294bool DummyDataObject::IsCompatibleWith(const DummyDataObject &actual,
295 std::string *whyNot, std::optional<std::string> *warning) const {
296 if (!IsOkWithSequenceAssociation(type, actual.type) &&
297 !IsOkWithSequenceAssociation(actual.type, type)) {
298 bool possibleWarning{false};
299 if (!ShapesAreCompatible(
300 type.shape(), actual.type.shape(), &possibleWarning)) {
301 if (whyNot) {
302 *whyNot = "incompatible dummy data object shapes";
303 }
304 return false;
305 } else if (warning && possibleWarning) {
306 *warning = "distinct dummy data object shapes";
307 }
308 }
309 // Treat deduced dummy character type as if it were assumed-length character
310 // to avoid useless "implicit interfaces have distinct type" warnings from
311 // CALL FOO('abc'); CALL FOO('abcd').
312 bool deducedAssumedLength{type.type().category() == TypeCategory::Character &&
313 attrs.test(Attr::DeducedFromActual)};
314 bool compatibleTypes{deducedAssumedLength
315 ? type.type().IsTkCompatibleWith(actual.type.type())
316 : type.type().IsTkLenCompatibleWith(actual.type.type())};
317 if (!compatibleTypes) {
318 if (whyNot) {
319 *whyNot = "incompatible dummy data object types: "s +
320 type.type().AsFortran() + " vs " + actual.type.type().AsFortran();
321 }
322 return false;
323 }
324 if (type.type().IsPolymorphic() != actual.type.type().IsPolymorphic()) {
325 if (whyNot) {
326 *whyNot = "incompatible dummy data object polymorphism: "s +
327 type.type().AsFortran() + " vs " + actual.type.type().AsFortran();
328 }
329 return false;
330 }
331 if (type.type().category() == TypeCategory::Character &&
332 !deducedAssumedLength) {
333 if (actual.type.type().IsAssumedLengthCharacter() !=
334 type.type().IsAssumedLengthCharacter()) {
335 if (whyNot) {
336 *whyNot = "assumed-length character vs explicit-length character";
337 }
338 return false;
339 }
340 if (!type.type().IsAssumedLengthCharacter() && type.LEN() &&
341 actual.type.LEN()) {
342 auto len{ToInt64(*type.LEN())};
343 auto actualLen{ToInt64(*actual.type.LEN())};
344 if (len.has_value() != actualLen.has_value()) {
345 if (whyNot) {
346 *whyNot = "constant-length vs non-constant-length character dummy "
347 "arguments";
348 }
349 return false;
350 } else if (len && *len != *actualLen) {
351 if (whyNot) {
352 *whyNot = "character dummy arguments with distinct lengths";
353 }
354 return false;
355 }
356 }
357 }
358 if (!attrs.test(Attr::DeducedFromActual) &&
359 !actual.attrs.test(Attr::DeducedFromActual) &&
360 type.attrs() != actual.type.attrs()) {
361 if (whyNot) {
362 *whyNot = "incompatible dummy data object shape attributes";
363 auto differences{type.attrs() ^ actual.type.attrs()};
364 auto sep{": "s};
365 differences.IterateOverMembers([&](TypeAndShape::Attr x) {
366 *whyNot += sep + std::string{TypeAndShape::EnumToString(x)};
367 sep = ", ";
368 });
369 }
370 return false;
371 }
372 if (!IdenticalSignificantAttrs(attrs, actual.attrs)) {
373 if (whyNot) {
374 *whyNot = "incompatible dummy data object attributes";
375 auto differences{attrs ^ actual.attrs};
376 auto sep{": "s};
377 differences.IterateOverMembers([&](DummyDataObject::Attr x) {
378 *whyNot += sep + std::string{EnumToString(x)};
379 sep = ", ";
380 });
381 }
382 return false;
383 }
384 if (intent != actual.intent) {
385 if (whyNot) {
386 *whyNot = "incompatible dummy data object intents";
387 }
388 return false;
389 }
390 if (coshape != actual.coshape) {
391 if (whyNot) {
392 *whyNot = "incompatible dummy data object coshapes";
393 }
394 return false;
395 }
396 if (ignoreTKR != actual.ignoreTKR) {
397 if (whyNot) {
398 *whyNot = "incompatible !DIR$ IGNORE_TKR directives";
399 }
400 }
401 if (!attrs.test(Attr::Value) &&
402 !common::AreCompatibleCUDADataAttrs(cudaDataAttr, actual.cudaDataAttr,
403 ignoreTKR, warning,
404 /*allowUnifiedMatchingRule=*/false,
405 /*=isHostDeviceProcedure*/ false)) {
406 if (whyNot) {
407 *whyNot = "incompatible CUDA data attributes";
408 }
409 }
410 return true;
411}
412
413static common::Intent GetIntent(const semantics::Attrs &attrs) {
414 if (attrs.test(semantics::Attr::INTENT_IN)) {
415 return common::Intent::In;
416 } else if (attrs.test(semantics::Attr::INTENT_OUT)) {
417 return common::Intent::Out;
418 } else if (attrs.test(semantics::Attr::INTENT_INOUT)) {
419 return common::Intent::InOut;
420 } else {
421 return common::Intent::Default;
422 }
423}
424
425std::optional<DummyDataObject> DummyDataObject::Characterize(
426 const semantics::Symbol &symbol, FoldingContext &context) {
427 if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()};
428 object || symbol.has<semantics::EntityDetails>()) {
429 if (auto type{TypeAndShape::Characterize(
430 symbol, context, /*invariantOnly=*/false)}) {
431 std::optional<DummyDataObject> result{std::move(*type)};
432 using semantics::Attr;
433 CopyAttrs<DummyDataObject, DummyDataObject::Attr>(symbol, *result,
434 {
435 {Attr::OPTIONAL, DummyDataObject::Attr::Optional},
436 {Attr::ALLOCATABLE, DummyDataObject::Attr::Allocatable},
437 {Attr::ASYNCHRONOUS, DummyDataObject::Attr::Asynchronous},
438 {Attr::CONTIGUOUS, DummyDataObject::Attr::Contiguous},
439 {Attr::VALUE, DummyDataObject::Attr::Value},
440 {Attr::VOLATILE, DummyDataObject::Attr::Volatile},
441 {Attr::POINTER, DummyDataObject::Attr::Pointer},
442 {Attr::TARGET, DummyDataObject::Attr::Target},
443 });
444 result->intent = GetIntent(symbol.attrs());
445 result->ignoreTKR = GetIgnoreTKR(symbol);
446 if (object) {
447 result->cudaDataAttr = object->cudaDataAttr();
448 if (!result->cudaDataAttr &&
449 !result->attrs.test(DummyDataObject::Attr::Value) &&
450 semantics::IsCUDADeviceContext(&symbol.owner())) {
451 result->cudaDataAttr = common::CUDADataAttr::Device;
452 }
453 }
454 return result;
455 }
456 }
457 return std::nullopt;
458}
459
460bool DummyDataObject::CanBePassedViaImplicitInterface(
461 std::string *whyNot) const {
462 if ((attrs &
463 Attrs{Attr::Allocatable, Attr::Asynchronous, Attr::Optional,
464 Attr::Pointer, Attr::Target, Attr::Value, Attr::Volatile})
465 .any()) {
466 if (whyNot) {
467 *whyNot = "a dummy argument has the allocatable, asynchronous, optional, "
468 "pointer, target, value, or volatile attribute";
469 }
470 return false; // 15.4.2.2(3)(a)
471 } else if ((type.attrs() &
472 TypeAndShape::Attrs{TypeAndShape::Attr::AssumedShape,
473 TypeAndShape::Attr::AssumedRank})
474 .any() ||
475 type.corank() > 0) {
476 if (whyNot) {
477 *whyNot = "a dummy argument is assumed-shape, assumed-rank, or a coarray";
478 }
479 return false; // 15.4.2.2(3)(b-d)
480 } else if (type.type().IsPolymorphic()) {
481 if (whyNot) {
482 *whyNot = "a dummy argument is polymorphic";
483 }
484 return false; // 15.4.2.2(3)(f)
485 } else if (cudaDataAttr) {
486 if (whyNot) {
487 *whyNot = "a dummy argument has a CUDA data attribute";
488 }
489 return false;
490 } else if (const auto *derived{GetDerivedTypeSpec(type.type())}) {
491 if (derived->parameters().empty()) { // 15.4.2.2(3)(e)
492 return true;
493 } else {
494 if (whyNot) {
495 *whyNot = "a dummy argument has derived type parameters";
496 }
497 return false;
498 }
499 } else {
500 return true;
501 }
502}
503
504bool DummyDataObject::IsPassedByDescriptor(bool isBindC) const {
505 constexpr TypeAndShape::Attrs shapeRequiringBox{
506 TypeAndShape::Attr::AssumedShape, TypeAndShape::Attr::DeferredShape,
507 TypeAndShape::Attr::AssumedRank};
508 if ((attrs & Attrs{Attr::Allocatable, Attr::Pointer}).any()) {
509 return true;
510 } else if ((type.attrs() & shapeRequiringBox).any()) {
511 return true; // pass shape in descriptor
512 } else if (type.corank() > 0) {
513 return true; // pass coshape in descriptor
514 } else if (type.type().IsPolymorphic() && !type.type().IsAssumedType()) {
515 // Need to pass dynamic type info in a descriptor.
516 return true;
517 } else if (const auto *derived{GetDerivedTypeSpec(type.type())}) {
518 if (!derived->parameters().empty()) {
519 for (const auto &param : derived->parameters()) {
520 if (param.second.isLen()) {
521 // Need to pass length type parameters in a descriptor.
522 return true;
523 }
524 }
525 }
526 } else if (isBindC && type.type().IsAssumedLengthCharacter()) {
527 // Fortran 2018 18.3.6 point 2 (5)
528 return true;
529 }
530 return false;
531}
532
533llvm::raw_ostream &DummyDataObject::Dump(llvm::raw_ostream &o) const {
534 attrs.Dump(o, EnumToString);
535 if (intent != common::Intent::Default) {
536 o << "INTENT(" << common::EnumToString(intent) << ')';
537 }
538 type.Dump(o);
539 if (!coshape.empty()) {
540 char sep{'['};
541 for (const auto &expr : coshape) {
542 expr.AsFortran(o << sep);
543 sep = ',';
544 }
545 }
546 if (cudaDataAttr) {
547 o << " cudaDataAttr: " << common::EnumToString(*cudaDataAttr);
548 }
549 if (!ignoreTKR.empty()) {
550 ignoreTKR.Dump(o << ' ', common::EnumToString);
551 }
552 return o;
553}
554
555DummyProcedure::DummyProcedure(Procedure &&p)
556 : procedure{new Procedure{std::move(p)}} {}
557
558bool DummyProcedure::operator==(const DummyProcedure &that) const {
559 return attrs == that.attrs && intent == that.intent &&
560 procedure.value() == that.procedure.value();
561}
562
563bool DummyProcedure::IsCompatibleWith(
564 const DummyProcedure &actual, std::string *whyNot) const {
565 if (attrs != actual.attrs) {
566 if (whyNot) {
567 *whyNot = "incompatible dummy procedure attributes";
568 }
569 return false;
570 }
571 if (intent != actual.intent) {
572 if (whyNot) {
573 *whyNot = "incompatible dummy procedure intents";
574 }
575 return false;
576 }
577 if (!procedure.value().IsCompatibleWith(actual.procedure.value(),
578 /*ignoreImplicitVsExplicit=*/false, whyNot)) {
579 if (whyNot) {
580 *whyNot = "incompatible dummy procedure interfaces: "s + *whyNot;
581 }
582 return false;
583 }
584 return true;
585}
586
587bool DummyProcedure::CanBePassedViaImplicitInterface(
588 std::string *whyNot) const {
589 if ((attrs & Attrs{Attr::Optional, Attr::Pointer}).any()) {
590 if (whyNot) {
591 *whyNot = "a dummy procedure is optional or a pointer";
592 }
593 return false; // 15.4.2.2(3)(a)
594 }
595 return true;
596}
597
598static std::string GetSeenProcs(
599 const semantics::UnorderedSymbolSet &seenProcs) {
600 // Sort the symbols so that they appear in the same order on all platforms
601 auto ordered{semantics::OrderBySourcePosition(seenProcs)};
602 std::string result;
603 llvm::interleave(
604 ordered,
605 [&](const SymbolRef p) { result += '\'' + p->name().ToString() + '\''; },
606 [&]() { result += ", "; });
607 return result;
608}
609
610// These functions with arguments of type UnorderedSymbolSet are used with
611// mutually recursive calls when characterizing a Procedure, a DummyArgument,
612// or a DummyProcedure to detect circularly defined procedures as required by
613// 15.4.3.6, paragraph 2.
614static std::optional<DummyArgument> CharacterizeDummyArgument(
615 const semantics::Symbol &symbol, FoldingContext &context,
616 semantics::UnorderedSymbolSet seenProcs);
617static std::optional<FunctionResult> CharacterizeFunctionResult(
618 const semantics::Symbol &symbol, FoldingContext &context,
619 semantics::UnorderedSymbolSet seenProcs, bool emitError);
620
621static std::optional<Procedure> CharacterizeProcedure(
622 const semantics::Symbol &original, FoldingContext &context,
623 semantics::UnorderedSymbolSet seenProcs, bool emitError) {
624 const auto &symbol{ResolveAssociations(original)};
625 if (seenProcs.find(symbol) != seenProcs.end()) {
626 std::string procsList{GetSeenProcs(seenProcs)};
627 context.messages().Say(symbol.name(),
628 "Procedure '%s' is recursively defined. Procedures in the cycle:"
629 " %s"_err_en_US,
630 symbol.name(), procsList);
631 return std::nullopt;
632 }
633 seenProcs.insert(symbol);
634 auto CheckForNested{[&](const Symbol &symbol) {
635 if (emitError) {
636 context.messages().Say(
637 "Procedure '%s' is referenced before being sufficiently defined in a context where it must be so"_err_en_US,
638 symbol.name());
639 }
640 }};
641 auto result{common::visit(
642 common::visitors{
643 [&](const semantics::SubprogramDetails &subp)
644 -> std::optional<Procedure> {
645 Procedure result;
646 if (subp.isFunction()) {
647 if (auto fr{CharacterizeFunctionResult(
648 subp.result(), context, seenProcs, emitError)}) {
649 result.functionResult = std::move(fr);
650 } else {
651 return std::nullopt;
652 }
653 } else {
654 result.attrs.set(Procedure::Attr::Subroutine);
655 }
656 for (const semantics::Symbol *arg : subp.dummyArgs()) {
657 if (!arg) {
658 if (subp.isFunction()) {
659 return std::nullopt;
660 } else {
661 result.dummyArguments.emplace_back(AlternateReturn{});
662 }
663 } else if (auto argCharacteristics{CharacterizeDummyArgument(
664 *arg, context, seenProcs)}) {
665 result.dummyArguments.emplace_back(
666 std::move(argCharacteristics.value()));
667 } else {
668 return std::nullopt;
669 }
670 }
671 result.cudaSubprogramAttrs = subp.cudaSubprogramAttrs();
672 return std::move(result);
673 },
674 [&](const semantics::ProcEntityDetails &proc)
675 -> std::optional<Procedure> {
676 if (symbol.attrs().test(semantics::Attr::INTRINSIC)) {
677 // Fails when the intrinsic is not a specific intrinsic function
678 // from F'2018 table 16.2. In order to handle forward references,
679 // attempts to use impermissible intrinsic procedures as the
680 // interfaces of procedure pointers are caught and flagged in
681 // declaration checking in Semantics.
682 auto intrinsic{context.intrinsics().IsSpecificIntrinsicFunction(
683 symbol.name().ToString())};
684 if (intrinsic && intrinsic->isRestrictedSpecific) {
685 intrinsic.reset(); // Exclude intrinsics from table 16.3.
686 }
687 return intrinsic;
688 }
689 if (const semantics::Symbol *
690 interfaceSymbol{proc.procInterface()}) {
691 auto result{CharacterizeProcedure(
692 *interfaceSymbol, context, seenProcs, /*emitError=*/false)};
693 if (result && (IsDummy(symbol) || IsPointer(symbol))) {
694 // Dummy procedures and procedure pointers may not be
695 // ELEMENTAL, but we do accept the use of elemental intrinsic
696 // functions as their interfaces.
697 result->attrs.reset(Procedure::Attr::Elemental);
698 }
699 return result;
700 } else {
701 Procedure result;
702 result.attrs.set(Procedure::Attr::ImplicitInterface);
703 const semantics::DeclTypeSpec *type{proc.type()};
704 if (symbol.test(semantics::Symbol::Flag::Subroutine)) {
705 // ignore any implicit typing
706 result.attrs.set(Procedure::Attr::Subroutine);
707 if (proc.isCUDAKernel()) {
708 result.cudaSubprogramAttrs =
709 common::CUDASubprogramAttrs::Global;
710 }
711 } else if (type) {
712 if (auto resultType{DynamicType::From(*type)}) {
713 result.functionResult = FunctionResult{*resultType};
714 } else {
715 return std::nullopt;
716 }
717 } else if (symbol.test(semantics::Symbol::Flag::Function)) {
718 return std::nullopt;
719 }
720 // The PASS name, if any, is not a characteristic.
721 return std::move(result);
722 }
723 },
724 [&](const semantics::ProcBindingDetails &binding) {
725 if (auto result{CharacterizeProcedure(binding.symbol(), context,
726 seenProcs, /*emitError=*/false)}) {
727 if (binding.symbol().attrs().test(semantics::Attr::INTRINSIC)) {
728 result->attrs.reset(Procedure::Attr::Elemental);
729 }
730 if (!symbol.attrs().test(semantics::Attr::NOPASS)) {
731 auto passName{binding.passName()};
732 for (auto &dummy : result->dummyArguments) {
733 if (!passName || dummy.name.c_str() == *passName) {
734 dummy.pass = true;
735 break;
736 }
737 }
738 }
739 return result;
740 } else {
741 return std::optional<Procedure>{};
742 }
743 },
744 [&](const semantics::UseDetails &use) {
745 return CharacterizeProcedure(
746 use.symbol(), context, seenProcs, /*emitError=*/false);
747 },
748 [](const semantics::UseErrorDetails &) {
749 // Ambiguous use-association will be handled later during symbol
750 // checks, ignore UseErrorDetails here without actual symbol usage.
751 return std::optional<Procedure>{};
752 },
753 [&](const semantics::HostAssocDetails &assoc) {
754 return CharacterizeProcedure(
755 assoc.symbol(), context, seenProcs, /*emitError=*/false);
756 },
757 [&](const semantics::GenericDetails &generic) {
758 if (const semantics::Symbol * specific{generic.specific()}) {
759 return CharacterizeProcedure(
760 *specific, context, seenProcs, emitError);
761 } else {
762 return std::optional<Procedure>{};
763 }
764 },
765 [&](const semantics::EntityDetails &x) {
766 CheckForNested(symbol);
767 return std::optional<Procedure>{};
768 },
769 [&](const semantics::SubprogramNameDetails &) {
770 if (const semantics::Symbol *
771 ancestor{FindAncestorModuleProcedure(&symbol)}) {
772 return CharacterizeProcedure(
773 *ancestor, context, seenProcs, emitError);
774 }
775 CheckForNested(symbol);
776 return std::optional<Procedure>{};
777 },
778 [&](const auto &) {
779 context.messages().Say(
780 "'%s' is not a procedure"_err_en_US, symbol.name());
781 return std::optional<Procedure>{};
782 },
783 },
784 symbol.details())};
785 if (result && !symbol.has<semantics::ProcBindingDetails>()) {
786 CopyAttrs<Procedure, Procedure::Attr>(symbol, *result,
787 {
788 {semantics::Attr::BIND_C, Procedure::Attr::BindC},
789 });
790 CopyAttrs<Procedure, Procedure::Attr>(DEREF(GetMainEntry(&symbol)), *result,
791 {
792 {semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental},
793 });
794 if (IsPureProcedure(symbol) || // works for ENTRY too
795 (!IsExplicitlyImpureProcedure(symbol) &&
796 result->attrs.test(Procedure::Attr::Elemental))) {
797 result->attrs.set(Procedure::Attr::Pure);
798 }
799 }
800 return result;
801}
802
803static std::optional<DummyProcedure> CharacterizeDummyProcedure(
804 const semantics::Symbol &symbol, FoldingContext &context,
805 semantics::UnorderedSymbolSet seenProcs) {
806 if (auto procedure{CharacterizeProcedure(
807 symbol, context, seenProcs, /*emitError=*/true)}) {
808 // Dummy procedures may not be elemental. Elemental dummy procedure
809 // interfaces are errors when the interface is not intrinsic, and that
810 // error is caught elsewhere. Elemental intrinsic interfaces are
811 // made non-elemental.
812 procedure->attrs.reset(Procedure::Attr::Elemental);
813 DummyProcedure result{std::move(procedure.value())};
814 CopyAttrs<DummyProcedure, DummyProcedure::Attr>(symbol, result,
815 {
816 {semantics::Attr::OPTIONAL, DummyProcedure::Attr::Optional},
817 {semantics::Attr::POINTER, DummyProcedure::Attr::Pointer},
818 });
819 result.intent = GetIntent(symbol.attrs());
820 return result;
821 } else {
822 return std::nullopt;
823 }
824}
825
826llvm::raw_ostream &DummyProcedure::Dump(llvm::raw_ostream &o) const {
827 attrs.Dump(o, EnumToString);
828 if (intent != common::Intent::Default) {
829 o << "INTENT(" << common::EnumToString(intent) << ')';
830 }
831 procedure.value().Dump(o);
832 return o;
833}
834
835llvm::raw_ostream &AlternateReturn::Dump(llvm::raw_ostream &o) const {
836 return o << '*';
837}
838
839DummyArgument::~DummyArgument() {}
840
841bool DummyArgument::operator==(const DummyArgument &that) const {
842 return u == that.u; // name and passed-object usage are not characteristics
843}
844
845bool DummyArgument::IsCompatibleWith(const DummyArgument &actual,
846 std::string *whyNot, std::optional<std::string> *warning) const {
847 if (const auto *ifaceData{std::get_if<DummyDataObject>(&u)}) {
848 if (const auto *actualData{std::get_if<DummyDataObject>(&actual.u)}) {
849 return ifaceData->IsCompatibleWith(*actualData, whyNot, warning);
850 }
851 if (whyNot) {
852 *whyNot = "one dummy argument is an object, the other is not";
853 }
854 } else if (const auto *ifaceProc{std::get_if<DummyProcedure>(&u)}) {
855 if (const auto *actualProc{std::get_if<DummyProcedure>(&actual.u)}) {
856 return ifaceProc->IsCompatibleWith(*actualProc, whyNot);
857 }
858 if (whyNot) {
859 *whyNot = "one dummy argument is a procedure, the other is not";
860 }
861 } else {
862 CHECK(std::holds_alternative<AlternateReturn>(u));
863 if (std::holds_alternative<AlternateReturn>(actual.u)) {
864 return true;
865 }
866 if (whyNot) {
867 *whyNot = "one dummy argument is an alternate return, the other is not";
868 }
869 }
870 return false;
871}
872
873static std::optional<DummyArgument> CharacterizeDummyArgument(
874 const semantics::Symbol &symbol, FoldingContext &context,
875 semantics::UnorderedSymbolSet seenProcs) {
876 auto name{symbol.name().ToString()};
877 if (symbol.has<semantics::ObjectEntityDetails>() ||
878 symbol.has<semantics::EntityDetails>()) {
879 if (auto obj{DummyDataObject::Characterize(symbol, context)}) {
880 return DummyArgument{std::move(name), std::move(obj.value())};
881 }
882 } else if (auto proc{
883 CharacterizeDummyProcedure(symbol, context, seenProcs)}) {
884 return DummyArgument{std::move(name), std::move(proc.value())};
885 }
886 return std::nullopt;
887}
888
889std::optional<DummyArgument> DummyArgument::FromActual(std::string &&name,
890 const Expr<SomeType> &expr, FoldingContext &context,
891 bool forImplicitInterface) {
892 return common::visit(
893 common::visitors{
894 [&](const BOZLiteralConstant &) {
895 DummyDataObject obj{
896 TypeAndShape{DynamicType::TypelessIntrinsicArgument()}};
897 obj.attrs.set(DummyDataObject::Attr::DeducedFromActual);
898 return std::make_optional<DummyArgument>(
899 std::move(name), std::move(obj));
900 },
901 [&](const NullPointer &) {
902 DummyDataObject obj{
903 TypeAndShape{DynamicType::TypelessIntrinsicArgument()}};
904 obj.attrs.set(DummyDataObject::Attr::DeducedFromActual);
905 return std::make_optional<DummyArgument>(
906 std::move(name), std::move(obj));
907 },
908 [&](const ProcedureDesignator &designator) {
909 if (auto proc{Procedure::Characterize(
910 designator, context, /*emitError=*/true)}) {
911 return std::make_optional<DummyArgument>(
912 std::move(name), DummyProcedure{std::move(*proc)});
913 } else {
914 return std::optional<DummyArgument>{};
915 }
916 },
917 [&](const ProcedureRef &call) {
918 if (auto proc{Procedure::Characterize(call, context)}) {
919 return std::make_optional<DummyArgument>(
920 std::move(name), DummyProcedure{std::move(*proc)});
921 } else {
922 return std::optional<DummyArgument>{};
923 }
924 },
925 [&](const auto &) {
926 if (auto type{TypeAndShape::Characterize(expr, context)}) {
927 if (forImplicitInterface &&
928 !type->type().IsUnlimitedPolymorphic() &&
929 type->type().IsPolymorphic()) {
930 // Pass the monomorphic declared type to an implicit interface
931 type->set_type(DynamicType{
932 type->type().GetDerivedTypeSpec(), /*poly=*/false});
933 }
934 if (type->type().category() == TypeCategory::Character &&
935 type->type().kind() == 1) {
936 type->set_isPossibleSequenceAssociation(true);
937 } else if (const Symbol * array{IsArrayElement(expr)}) {
938 type->set_isPossibleSequenceAssociation(
939 IsContiguous(*array, context).value_or(false));
940 } else {
941 type->set_isPossibleSequenceAssociation(expr.Rank() > 0);
942 }
943 DummyDataObject obj{std::move(*type)};
944 obj.attrs.set(DummyDataObject::Attr::DeducedFromActual);
945 return std::make_optional<DummyArgument>(
946 std::move(name), std::move(obj));
947 } else {
948 return std::optional<DummyArgument>{};
949 }
950 },
951 },
952 expr.u);
953}
954
955std::optional<DummyArgument> DummyArgument::FromActual(std::string &&name,
956 const ActualArgument &arg, FoldingContext &context,
957 bool forImplicitInterface) {
958 if (const auto *expr{arg.UnwrapExpr()}) {
959 return FromActual(std::move(name), *expr, context, forImplicitInterface);
960 } else if (arg.GetAssumedTypeDummy()) {
961 return std::nullopt;
962 } else {
963 return DummyArgument{AlternateReturn{}};
964 }
965}
966
967bool DummyArgument::IsOptional() const {
968 return common::visit(
969 common::visitors{
970 [](const DummyDataObject &data) {
971 return data.attrs.test(DummyDataObject::Attr::Optional);
972 },
973 [](const DummyProcedure &proc) {
974 return proc.attrs.test(DummyProcedure::Attr::Optional);
975 },
976 [](const AlternateReturn &) { return false; },
977 },
978 u);
979}
980
981void DummyArgument::SetOptional(bool value) {
982 common::visit(common::visitors{
983 [value](DummyDataObject &data) {
984 data.attrs.set(DummyDataObject::Attr::Optional, value);
985 },
986 [value](DummyProcedure &proc) {
987 proc.attrs.set(DummyProcedure::Attr::Optional, value);
988 },
989 [](AlternateReturn &) { DIE("cannot set optional"); },
990 },
991 u);
992}
993
994void DummyArgument::SetIntent(common::Intent intent) {
995 common::visit(common::visitors{
996 [intent](DummyDataObject &data) { data.intent = intent; },
997 [intent](DummyProcedure &proc) { proc.intent = intent; },
998 [](AlternateReturn &) { DIE("cannot set intent"); },
999 },
1000 u);
1001}
1002
1003common::Intent DummyArgument::GetIntent() const {
1004 return common::visit(
1005 common::visitors{
1006 [](const DummyDataObject &data) { return data.intent; },
1007 [](const DummyProcedure &proc) { return proc.intent; },
1008 [](const AlternateReturn &) -> common::Intent {
1009 DIE("Alternate returns have no intent");
1010 },
1011 },
1012 u);
1013}
1014
1015bool DummyArgument::CanBePassedViaImplicitInterface(std::string *whyNot) const {
1016 if (const auto *object{std::get_if<DummyDataObject>(&u)}) {
1017 return object->CanBePassedViaImplicitInterface(whyNot);
1018 } else if (const auto *proc{std::get_if<DummyProcedure>(&u)}) {
1019 return proc->CanBePassedViaImplicitInterface(whyNot);
1020 } else {
1021 return true;
1022 }
1023}
1024
1025bool DummyArgument::IsTypelessIntrinsicDummy() const {
1026 const auto *argObj{std::get_if<characteristics::DummyDataObject>(&u)};
1027 return argObj && argObj->type.type().IsTypelessIntrinsicArgument();
1028}
1029
1030llvm::raw_ostream &DummyArgument::Dump(llvm::raw_ostream &o) const {
1031 if (!name.empty()) {
1032 o << name << '=';
1033 }
1034 if (pass) {
1035 o << " PASS";
1036 }
1037 common::visit([&](const auto &x) { x.Dump(o); }, u);
1038 return o;
1039}
1040
1041FunctionResult::FunctionResult(DynamicType t) : u{TypeAndShape{t}} {}
1042FunctionResult::FunctionResult(TypeAndShape &&t) : u{std::move(t)} {}
1043FunctionResult::FunctionResult(Procedure &&p) : u{std::move(p)} {}
1044FunctionResult::~FunctionResult() {}
1045
1046bool FunctionResult::operator==(const FunctionResult &that) const {
1047 return attrs == that.attrs && cudaDataAttr == that.cudaDataAttr &&
1048 u == that.u;
1049}
1050
1051static std::optional<FunctionResult> CharacterizeFunctionResult(
1052 const semantics::Symbol &symbol, FoldingContext &context,
1053 semantics::UnorderedSymbolSet seenProcs, bool emitError) {
1054 if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
1055 if (auto type{TypeAndShape::Characterize(
1056 symbol, context, /*invariantOnly=*/false)}) {
1057 FunctionResult result{std::move(*type)};
1058 CopyAttrs<FunctionResult, FunctionResult::Attr>(symbol, result,
1059 {
1060 {semantics::Attr::ALLOCATABLE, FunctionResult::Attr::Allocatable},
1061 {semantics::Attr::CONTIGUOUS, FunctionResult::Attr::Contiguous},
1062 {semantics::Attr::POINTER, FunctionResult::Attr::Pointer},
1063 });
1064 result.cudaDataAttr = object->cudaDataAttr();
1065 return result;
1066 }
1067 } else if (auto maybeProc{CharacterizeProcedure(
1068 symbol, context, seenProcs, emitError)}) {
1069 FunctionResult result{std::move(*maybeProc)};
1070 result.attrs.set(FunctionResult::Attr::Pointer);
1071 return result;
1072 }
1073 return std::nullopt;
1074}
1075
1076std::optional<FunctionResult> FunctionResult::Characterize(
1077 const Symbol &symbol, FoldingContext &context) {
1078 semantics::UnorderedSymbolSet seenProcs;
1079 return CharacterizeFunctionResult(
1080 symbol, context, seenProcs, /*emitError=*/false);
1081}
1082
1083bool FunctionResult::IsAssumedLengthCharacter() const {
1084 if (const auto *ts{std::get_if<TypeAndShape>(&u)}) {
1085 return ts->type().IsAssumedLengthCharacter();
1086 } else {
1087 return false;
1088 }
1089}
1090
1091bool FunctionResult::CanBeReturnedViaImplicitInterface(
1092 std::string *whyNot) const {
1093 if (attrs.test(Attr::Pointer) || attrs.test(Attr::Allocatable)) {
1094 if (whyNot) {
1095 *whyNot = "the function result is a pointer or allocatable";
1096 }
1097 return false; // 15.4.2.2(4)(b)
1098 } else if (cudaDataAttr) {
1099 if (whyNot) {
1100 *whyNot = "the function result has CUDA attributes";
1101 }
1102 return false;
1103 } else if (const auto *typeAndShape{GetTypeAndShape()}) {
1104 if (typeAndShape->Rank() > 0) {
1105 if (whyNot) {
1106 *whyNot = "the function result is an array";
1107 }
1108 return false; // 15.4.2.2(4)(a)
1109 } else {
1110 const DynamicType &type{typeAndShape->type()};
1111 switch (type.category()) {
1112 case TypeCategory::Character:
1113 if (type.knownLength()) {
1114 return true;
1115 } else if (const auto *param{type.charLengthParamValue()}) {
1116 if (const auto &expr{param->GetExplicit()}) {
1117 if (IsConstantExpr(*expr)) { // 15.4.2.2(4)(c)
1118 return true;
1119 } else {
1120 if (whyNot) {
1121 *whyNot = "the function result's length is not constant";
1122 }
1123 return false;
1124 }
1125 } else if (param->isAssumed()) {
1126 return true;
1127 }
1128 }
1129 if (whyNot) {
1130 *whyNot = "the function result's length is not known to the caller";
1131 }
1132 return false;
1133 case TypeCategory::Derived:
1134 if (type.IsPolymorphic()) {
1135 if (whyNot) {
1136 *whyNot = "the function result is polymorphic";
1137 }
1138 return false;
1139 } else {
1140 const auto &spec{type.GetDerivedTypeSpec()};
1141 for (const auto &pair : spec.parameters()) {
1142 if (const auto &expr{pair.second.GetExplicit()}) {
1143 if (!IsConstantExpr(*expr)) {
1144 if (whyNot) {
1145 *whyNot = "the function result's derived type has a "
1146 "non-constant parameter";
1147 }
1148 return false; // 15.4.2.2(4)(c)
1149 }
1150 }
1151 }
1152 return true;
1153 }
1154 default:
1155 return true;
1156 }
1157 }
1158 } else {
1159 if (whyNot) {
1160 *whyNot = "the function result has unknown type or shape";
1161 }
1162 return false; // 15.4.2.2(4)(b) - procedure pointer?
1163 }
1164}
1165
1166static std::optional<std::string> AreIncompatibleFunctionResultShapes(
1167 const Shape &x, const Shape &y) {
1168 // Function results cannot be assumed-rank, hence the non optional arguments.
1169 int rank{GetRank(x)};
1170 if (int yrank{GetRank(y)}; yrank != rank) {
1171 return "rank "s + std::to_string(rank) + " vs " + std::to_string(yrank);
1172 }
1173 for (int j{0}; j < rank; ++j) {
1174 if (x[j] && y[j] && !(*x[j] == *y[j])) {
1175 return x[j]->AsFortran() + " vs " + y[j]->AsFortran();
1176 }
1177 }
1178 return std::nullopt;
1179}
1180
1181bool FunctionResult::IsCompatibleWith(
1182 const FunctionResult &actual, std::string *whyNot) const {
1183 Attrs actualAttrs{actual.attrs};
1184 if (!attrs.test(Attr::Contiguous)) {
1185 actualAttrs.reset(Attr::Contiguous);
1186 }
1187 if (attrs != actualAttrs) {
1188 if (whyNot) {
1189 *whyNot = "function results have incompatible attributes";
1190 }
1191 } else if (cudaDataAttr != actual.cudaDataAttr) {
1192 if (whyNot) {
1193 *whyNot = "function results have incompatible CUDA data attributes";
1194 }
1195 } else if (const auto *ifaceTypeShape{std::get_if<TypeAndShape>(&u)}) {
1196 if (const auto *actualTypeShape{std::get_if<TypeAndShape>(&actual.u)}) {
1197 std::optional<std::string> details;
1198 if (ifaceTypeShape->Rank() != actualTypeShape->Rank()) {
1199 if (whyNot) {
1200 *whyNot = "function results have distinct ranks";
1201 }
1202 } else if (!attrs.test(Attr::Allocatable) && !attrs.test(Attr::Pointer) &&
1203 (details = AreIncompatibleFunctionResultShapes(
1204 ifaceTypeShape->shape().value(),
1205 actualTypeShape->shape().value()))) {
1206 if (whyNot) {
1207 *whyNot = "function results have distinct extents (" + *details + ')';
1208 }
1209 } else if (ifaceTypeShape->type() != actualTypeShape->type()) {
1210 if (ifaceTypeShape->type().category() !=
1211 actualTypeShape->type().category()) {
1212 } else if (ifaceTypeShape->type().category() ==
1213 TypeCategory::Character) {
1214 if (ifaceTypeShape->type().kind() == actualTypeShape->type().kind()) {
1215 if (IsAssumedLengthCharacter() ||
1216 actual.IsAssumedLengthCharacter()) {
1217 return true;
1218 } else {
1219 auto len{ToInt64(ifaceTypeShape->LEN())};
1220 auto actualLen{ToInt64(actualTypeShape->LEN())};
1221 if (len.has_value() != actualLen.has_value()) {
1222 if (whyNot) {
1223 *whyNot = "constant-length vs non-constant-length character "
1224 "results";
1225 }
1226 } else if (len && *len != *actualLen) {
1227 if (whyNot) {
1228 *whyNot = "character results with distinct lengths";
1229 }
1230 } else {
1231 const auto *ifaceLenParam{
1232 ifaceTypeShape->type().charLengthParamValue()};
1233 const auto *actualLenParam{
1234 actualTypeShape->type().charLengthParamValue()};
1235 if (ifaceLenParam && actualLenParam &&
1236 ifaceLenParam->isExplicit() !=
1237 actualLenParam->isExplicit()) {
1238 if (whyNot) {
1239 *whyNot =
1240 "explicit-length vs deferred-length character results";
1241 }
1242 } else {
1243 return true;
1244 }
1245 }
1246 }
1247 }
1248 } else if (ifaceTypeShape->type().category() == TypeCategory::Derived) {
1249 if (ifaceTypeShape->type().IsPolymorphic() ==
1250 actualTypeShape->type().IsPolymorphic() &&
1251 !ifaceTypeShape->type().IsUnlimitedPolymorphic() &&
1252 !actualTypeShape->type().IsUnlimitedPolymorphic() &&
1253 AreSameDerivedType(ifaceTypeShape->type().GetDerivedTypeSpec(),
1254 actualTypeShape->type().GetDerivedTypeSpec())) {
1255 return true;
1256 }
1257 }
1258 if (whyNot) {
1259 *whyNot = "function results have distinct types: "s +
1260 ifaceTypeShape->type().AsFortran() + " vs "s +
1261 actualTypeShape->type().AsFortran();
1262 }
1263 } else {
1264 return true;
1265 }
1266 } else {
1267 if (whyNot) {
1268 *whyNot = "function result type and shape are not known";
1269 }
1270 }
1271 } else {
1272 const auto *ifaceProc{std::get_if<CopyableIndirection<Procedure>>(&u)};
1273 CHECK(ifaceProc != nullptr);
1274 if (const auto *actualProc{
1275 std::get_if<CopyableIndirection<Procedure>>(&actual.u)}) {
1276 if (ifaceProc->value().IsCompatibleWith(actualProc->value(),
1277 /*ignoreImplicitVsExplicit=*/false, whyNot)) {
1278 return true;
1279 }
1280 if (whyNot) {
1281 *whyNot =
1282 "function results are incompatible procedure pointers: "s + *whyNot;
1283 }
1284 } else {
1285 if (whyNot) {
1286 *whyNot =
1287 "one function result is a procedure pointer, the other is not";
1288 }
1289 }
1290 }
1291 return false;
1292}
1293
1294llvm::raw_ostream &FunctionResult::Dump(llvm::raw_ostream &o) const {
1295 attrs.Dump(o, EnumToString);
1296 common::visit(common::visitors{
1297 [&](const TypeAndShape &ts) { ts.Dump(o); },
1298 [&](const CopyableIndirection<Procedure> &p) {
1299 p.value().Dump(o << " procedure(") << ')';
1300 },
1301 },
1302 u);
1303 if (cudaDataAttr) {
1304 o << " cudaDataAttr: " << common::EnumToString(*cudaDataAttr);
1305 }
1306 return o;
1307}
1308
1309Procedure::Procedure(FunctionResult &&fr, DummyArguments &&args, Attrs a)
1310 : functionResult{std::move(fr)}, dummyArguments{std::move(args)}, attrs{a} {
1311}
1312Procedure::Procedure(DummyArguments &&args, Attrs a)
1313 : dummyArguments{std::move(args)}, attrs{a} {}
1314Procedure::~Procedure() {}
1315
1316bool Procedure::operator==(const Procedure &that) const {
1317 return attrs == that.attrs && functionResult == that.functionResult &&
1318 dummyArguments == that.dummyArguments &&
1319 cudaSubprogramAttrs == that.cudaSubprogramAttrs;
1320}
1321
1322bool Procedure::IsCompatibleWith(const Procedure &actual,
1323 bool ignoreImplicitVsExplicit, std::string *whyNot,
1324 const SpecificIntrinsic *specificIntrinsic,
1325 std::optional<std::string> *warning) const {
1326 // 15.5.2.9(1): if dummy is not pure, actual need not be.
1327 // Ditto with elemental.
1328 Attrs actualAttrs{actual.attrs};
1329 if (!attrs.test(Attr::Pure)) {
1330 actualAttrs.reset(Attr::Pure);
1331 }
1332 if (!attrs.test(Attr::Elemental) && specificIntrinsic) {
1333 actualAttrs.reset(Attr::Elemental);
1334 }
1335 Attrs differences{attrs ^ actualAttrs};
1336 differences.reset(Attr::Subroutine); // dealt with specifically later
1337 if (ignoreImplicitVsExplicit) {
1338 differences.reset(Attr::ImplicitInterface);
1339 }
1340 if (!differences.empty()) {
1341 if (whyNot) {
1342 auto sep{": "s};
1343 *whyNot = "incompatible procedure attributes";
1344 differences.IterateOverMembers([&](Attr x) {
1345 *whyNot += sep + std::string{EnumToString(x)};
1346 sep = ", ";
1347 });
1348 }
1349 } else if ((IsFunction() && actual.IsSubroutine()) ||
1350 (IsSubroutine() && actual.IsFunction())) {
1351 if (whyNot) {
1352 *whyNot =
1353 "incompatible procedures: one is a function, the other a subroutine";
1354 }
1355 } else if (functionResult && actual.functionResult &&
1356 !functionResult->IsCompatibleWith(*actual.functionResult, whyNot)) {
1357 } else if (cudaSubprogramAttrs != actual.cudaSubprogramAttrs) {
1358 if (whyNot) {
1359 *whyNot = "incompatible CUDA subprogram attributes";
1360 }
1361 } else if (dummyArguments.size() != actual.dummyArguments.size()) {
1362 if (whyNot) {
1363 *whyNot = "distinct numbers of dummy arguments";
1364 }
1365 } else {
1366 for (std::size_t j{0}; j < dummyArguments.size(); ++j) {
1367 // Subtlety: the dummy/actual distinction must be reversed for this
1368 // compatibility test in order to correctly check extended vs.
1369 // base types. Example:
1370 // subroutine s1(base); subroutine s2(extended)
1371 // procedure(s1), pointer :: p
1372 // p => s2 ! an error, s2 is more restricted, can't handle "base"
1373 std::optional<std::string> gotWarning;
1374 if (!actual.dummyArguments[j].IsCompatibleWith(
1375 dummyArguments[j], whyNot, warning ? &gotWarning : nullptr)) {
1376 if (whyNot) {
1377 *whyNot = "incompatible dummy argument #"s + std::to_string(j + 1) +
1378 ": "s + *whyNot;
1379 }
1380 return false;
1381 } else if (warning && !*warning && gotWarning) {
1382 *warning = "possibly incompatible dummy argument #"s +
1383 std::to_string(j + 1) + ": "s + std::move(*gotWarning);
1384 }
1385 }
1386 return true;
1387 }
1388 return false;
1389}
1390
1391std::optional<int> Procedure::FindPassIndex(
1392 std::optional<parser::CharBlock> name) const {
1393 int argCount{static_cast<int>(dummyArguments.size())};
1394 if (name) {
1395 for (int index{0}; index < argCount; ++index) {
1396 if (*name == dummyArguments[index].name.c_str()) {
1397 return index;
1398 }
1399 }
1400 return std::nullopt;
1401 } else if (argCount > 0) {
1402 return 0;
1403 } else {
1404 return std::nullopt;
1405 }
1406}
1407
1408bool Procedure::CanOverride(
1409 const Procedure &that, std::optional<int> passIndex) const {
1410 // A pure procedure may override an impure one (7.5.7.3(2))
1411 if ((that.attrs.test(Attr::Pure) && !attrs.test(Attr::Pure)) ||
1412 that.attrs.test(Attr::Elemental) != attrs.test(Attr::Elemental) ||
1413 functionResult != that.functionResult) {
1414 return false;
1415 }
1416 int argCount{static_cast<int>(dummyArguments.size())};
1417 if (argCount != static_cast<int>(that.dummyArguments.size())) {
1418 return false;
1419 }
1420 for (int j{0}; j < argCount; ++j) {
1421 if (passIndex && j == *passIndex) {
1422 if (!that.dummyArguments[j].IsCompatibleWith(dummyArguments[j])) {
1423 return false;
1424 }
1425 } else if (dummyArguments[j] != that.dummyArguments[j]) {
1426 return false;
1427 }
1428 }
1429 return true;
1430}
1431
1432std::optional<Procedure> Procedure::Characterize(
1433 const semantics::Symbol &symbol, FoldingContext &context) {
1434 semantics::UnorderedSymbolSet seenProcs;
1435 return CharacterizeProcedure(symbol, context, seenProcs, /*emitError=*/true);
1436}
1437
1438std::optional<Procedure> Procedure::Characterize(
1439 const ProcedureDesignator &proc, FoldingContext &context, bool emitError) {
1440 if (const auto *symbol{proc.GetSymbol()}) {
1441 semantics::UnorderedSymbolSet seenProcs;
1442 return CharacterizeProcedure(*symbol, context, seenProcs, emitError);
1443 } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) {
1444 return intrinsic->characteristics.value();
1445 } else {
1446 return std::nullopt;
1447 }
1448}
1449
1450std::optional<Procedure> Procedure::Characterize(
1451 const ProcedureRef &ref, FoldingContext &context) {
1452 if (auto callee{Characterize(ref.proc(), context, /*emitError=*/true)}) {
1453 if (callee->functionResult) {
1454 if (const Procedure *
1455 proc{callee->functionResult->IsProcedurePointer()}) {
1456 return {*proc};
1457 }
1458 }
1459 }
1460 return std::nullopt;
1461}
1462
1463std::optional<Procedure> Procedure::Characterize(
1464 const Expr<SomeType> &expr, FoldingContext &context) {
1465 if (const auto *procRef{UnwrapProcedureRef(expr)}) {
1466 return Characterize(*procRef, context);
1467 } else if (const auto *procDesignator{
1468 std::get_if<ProcedureDesignator>(&expr.u)}) {
1469 return Characterize(*procDesignator, context, /*emitError=*/true);
1470 } else if (const Symbol * symbol{UnwrapWholeSymbolOrComponentDataRef(expr)}) {
1471 return Characterize(*symbol, context);
1472 } else {
1473 context.messages().Say(
1474 "Expression '%s' is not a procedure"_err_en_US, expr.AsFortran());
1475 return std::nullopt;
1476 }
1477}
1478
1479std::optional<Procedure> Procedure::FromActuals(const ProcedureDesignator &proc,
1480 const ActualArguments &args, FoldingContext &context) {
1481 auto callee{Characterize(proc, context, /*emitError=*/true)};
1482 if (callee) {
1483 if (callee->dummyArguments.empty() &&
1484 callee->attrs.test(Procedure::Attr::ImplicitInterface)) {
1485 int j{0};
1486 for (const auto &arg : args) {
1487 ++j;
1488 if (arg) {
1489 if (auto dummy{DummyArgument::FromActual("x"s + std::to_string(j),
1490 *arg, context,
1491 /*forImplicitInterface=*/true)}) {
1492 callee->dummyArguments.emplace_back(std::move(*dummy));
1493 continue;
1494 }
1495 }
1496 callee.reset();
1497 break;
1498 }
1499 }
1500 }
1501 return callee;
1502}
1503
1504bool Procedure::CanBeCalledViaImplicitInterface(std::string *whyNot) const {
1505 if (attrs.test(Attr::Elemental)) {
1506 if (whyNot) {
1507 *whyNot = "the procedure is elemental";
1508 }
1509 return false; // 15.4.2.2(5,6)
1510 } else if (attrs.test(Attr::BindC)) {
1511 if (whyNot) {
1512 *whyNot = "the procedure is BIND(C)";
1513 }
1514 return false; // 15.4.2.2(5,6)
1515 } else if (cudaSubprogramAttrs &&
1516 *cudaSubprogramAttrs != common::CUDASubprogramAttrs::Host &&
1517 *cudaSubprogramAttrs != common::CUDASubprogramAttrs::Global) {
1518 if (whyNot) {
1519 *whyNot = "the procedure is CUDA but neither HOST nor GLOBAL";
1520 }
1521 return false;
1522 } else if (IsFunction() &&
1523 !functionResult->CanBeReturnedViaImplicitInterface(whyNot)) {
1524 return false;
1525 } else {
1526 for (const DummyArgument &arg : dummyArguments) {
1527 if (!arg.CanBePassedViaImplicitInterface(whyNot)) {
1528 return false;
1529 }
1530 }
1531 return true;
1532 }
1533}
1534
1535llvm::raw_ostream &Procedure::Dump(llvm::raw_ostream &o) const {
1536 attrs.Dump(o, EnumToString);
1537 if (functionResult) {
1538 functionResult->Dump(o << "TYPE(") << ") FUNCTION";
1539 } else if (attrs.test(Attr::Subroutine)) {
1540 o << "SUBROUTINE";
1541 } else {
1542 o << "EXTERNAL";
1543 }
1544 char sep{'('};
1545 for (const auto &dummy : dummyArguments) {
1546 dummy.Dump(o << sep);
1547 sep = ',';
1548 }
1549 o << (sep == '(' ? "()" : ")");
1550 if (cudaSubprogramAttrs) {
1551 o << " cudaSubprogramAttrs: " << common::EnumToString(*cudaSubprogramAttrs);
1552 }
1553 return o;
1554}
1555
1556// Utility class to determine if Procedures, etc. are distinguishable
1557class DistinguishUtils {
1558public:
1559 explicit DistinguishUtils(const common::LanguageFeatureControl &features)
1560 : features_{features} {}
1561
1562 // Are these procedures distinguishable for a generic name?
1563 std::optional<bool> Distinguishable(
1564 const Procedure &, const Procedure &) const;
1565 // Are these procedures distinguishable for a generic operator or assignment?
1566 std::optional<bool> DistinguishableOpOrAssign(
1567 const Procedure &, const Procedure &) const;
1568
1569private:
1570 struct CountDummyProcedures {
1571 CountDummyProcedures(const DummyArguments &args) {
1572 for (const DummyArgument &arg : args) {
1573 if (std::holds_alternative<DummyProcedure>(arg.u)) {
1574 total += 1;
1575 notOptional += !arg.IsOptional();
1576 }
1577 }
1578 }
1579 int total{0};
1580 int notOptional{0};
1581 };
1582
1583 bool AnyOptionalData(const DummyArguments &) const;
1584 bool AnyUnlimitedPolymorphicData(const DummyArguments &) const;
1585 bool Rule3Distinguishable(const Procedure &, const Procedure &) const;
1586 const DummyArgument *Rule1DistinguishingArg(
1587 const DummyArguments &, const DummyArguments &) const;
1588 int FindFirstToDistinguishByPosition(
1589 const DummyArguments &, const DummyArguments &) const;
1590 int FindLastToDistinguishByName(
1591 const DummyArguments &, const DummyArguments &) const;
1592 int CountCompatibleWith(const DummyArgument &, const DummyArguments &) const;
1593 int CountNotDistinguishableFrom(
1594 const DummyArgument &, const DummyArguments &) const;
1595 bool Distinguishable(const DummyArgument &, const DummyArgument &) const;
1596 bool Distinguishable(const DummyDataObject &, const DummyDataObject &) const;
1597 bool Distinguishable(const DummyProcedure &, const DummyProcedure &) const;
1598 bool Distinguishable(const FunctionResult &, const FunctionResult &) const;
1599 bool Distinguishable(
1600 const TypeAndShape &, const TypeAndShape &, common::IgnoreTKRSet) const;
1601 bool IsTkrCompatible(const DummyArgument &, const DummyArgument &) const;
1602 bool IsTkCompatible(const DummyDataObject &, const DummyDataObject &) const;
1603 const DummyArgument *GetAtEffectivePosition(
1604 const DummyArguments &, int) const;
1605 const DummyArgument *GetPassArg(const Procedure &) const;
1606
1607 const common::LanguageFeatureControl &features_;
1608};
1609
1610// Simpler distinguishability rules for operators and assignment
1611std::optional<bool> DistinguishUtils::DistinguishableOpOrAssign(
1612 const Procedure &proc1, const Procedure &proc2) const {
1613 if ((proc1.IsFunction() && proc2.IsSubroutine()) ||
1614 (proc1.IsSubroutine() && proc2.IsFunction())) {
1615 return true;
1616 }
1617 auto &args1{proc1.dummyArguments};
1618 auto &args2{proc2.dummyArguments};
1619 if (args1.size() != args2.size()) {
1620 return true; // C1511: distinguishable based on number of arguments
1621 }
1622 for (std::size_t i{0}; i < args1.size(); ++i) {
1623 if (Distinguishable(args1[i], args2[i])) {
1624 return true; // C1511, C1512: distinguishable based on this arg
1625 }
1626 }
1627 return false;
1628}
1629
1630std::optional<bool> DistinguishUtils::Distinguishable(
1631 const Procedure &proc1, const Procedure &proc2) const {
1632 if ((proc1.IsFunction() && proc2.IsSubroutine()) ||
1633 (proc1.IsSubroutine() && proc2.IsFunction())) {
1634 return true;
1635 }
1636 auto &args1{proc1.dummyArguments};
1637 auto &args2{proc2.dummyArguments};
1638 auto count1{CountDummyProcedures(args1)};
1639 auto count2{CountDummyProcedures(args2)};
1640 if (count1.notOptional > count2.total || count2.notOptional > count1.total) {
1641 return true; // distinguishable based on C1514 rule 2
1642 }
1643 if (Rule3Distinguishable(proc1, proc2)) {
1644 return true; // distinguishable based on C1514 rule 3
1645 }
1646 if (Rule1DistinguishingArg(args1, args2)) {
1647 return true; // distinguishable based on C1514 rule 1
1648 }
1649 int pos1{FindFirstToDistinguishByPosition(args1, args2)};
1650 int name1{FindLastToDistinguishByName(args1, args2)};
1651 if (pos1 >= 0 && pos1 <= name1) {
1652 return true; // distinguishable based on C1514 rule 4
1653 }
1654 int pos2{FindFirstToDistinguishByPosition(args2, args1)};
1655 int name2{FindLastToDistinguishByName(args2, args1)};
1656 if (pos2 >= 0 && pos2 <= name2) {
1657 return true; // distinguishable based on C1514 rule 4
1658 }
1659 if (proc1.cudaSubprogramAttrs != proc2.cudaSubprogramAttrs) {
1660 return true;
1661 }
1662 // If there are no optional or unlimited polymorphic dummy arguments,
1663 // then we know the result for sure; otherwise, it's possible for
1664 // the procedures to be unambiguous.
1665 if ((AnyOptionalData(args1) || AnyUnlimitedPolymorphicData(args1)) &&
1666 (AnyOptionalData(args2) || AnyUnlimitedPolymorphicData(args2))) {
1667 return std::nullopt; // meaning "maybe"
1668 } else {
1669 return false;
1670 }
1671}
1672
1673bool DistinguishUtils::AnyOptionalData(const DummyArguments &args) const {
1674 for (const auto &arg : args) {
1675 if (std::holds_alternative<DummyDataObject>(arg.u) && arg.IsOptional()) {
1676 return true;
1677 }
1678 }
1679 return false;
1680}
1681
1682bool DistinguishUtils::AnyUnlimitedPolymorphicData(
1683 const DummyArguments &args) const {
1684 for (const auto &arg : args) {
1685 if (const auto *object{std::get_if<DummyDataObject>(&arg.u)}) {
1686 if (object->type.type().IsUnlimitedPolymorphic()) {
1687 return true;
1688 }
1689 }
1690 }
1691 return false;
1692}
1693
1694// C1514 rule 3: Procedures are distinguishable if both have a passed-object
1695// dummy argument and those are distinguishable.
1696bool DistinguishUtils::Rule3Distinguishable(
1697 const Procedure &proc1, const Procedure &proc2) const {
1698 const DummyArgument *pass1{GetPassArg(proc1)};
1699 const DummyArgument *pass2{GetPassArg(proc2)};
1700 return pass1 && pass2 && Distinguishable(*pass1, *pass2);
1701}
1702
1703// Find a non-passed-object dummy data object in one of the argument lists
1704// that satisfies C1514 rule 1. I.e. x such that:
1705// - m is the number of dummy data objects in one that are nonoptional,
1706// are not passed-object, that x is TKR compatible with
1707// - n is the number of non-passed-object dummy data objects, in the other
1708// that are not distinguishable from x
1709// - m is greater than n
1710const DummyArgument *DistinguishUtils::Rule1DistinguishingArg(
1711 const DummyArguments &args1, const DummyArguments &args2) const {
1712 auto size1{args1.size()};
1713 auto size2{args2.size()};
1714 for (std::size_t i{0}; i < size1 + size2; ++i) {
1715 const DummyArgument &x{i < size1 ? args1[i] : args2[i - size1]};
1716 if (!x.pass && std::holds_alternative<DummyDataObject>(x.u)) {
1717 if (CountCompatibleWith(x, args1) >
1718 CountNotDistinguishableFrom(x, args2) ||
1719 CountCompatibleWith(x, args2) >
1720 CountNotDistinguishableFrom(x, args1)) {
1721 return &x;
1722 }
1723 }
1724 }
1725 return nullptr;
1726}
1727
1728// Find the index of the first nonoptional non-passed-object dummy argument
1729// in args1 at an effective position such that either:
1730// - args2 has no dummy argument at that effective position
1731// - the dummy argument at that position is distinguishable from it
1732int DistinguishUtils::FindFirstToDistinguishByPosition(
1733 const DummyArguments &args1, const DummyArguments &args2) const {
1734 int effective{0}; // position of arg1 in list, ignoring passed arg
1735 for (std::size_t i{0}; i < args1.size(); ++i) {
1736 const DummyArgument &arg1{args1.at(i)};
1737 if (!arg1.pass && !arg1.IsOptional()) {
1738 const DummyArgument *arg2{GetAtEffectivePosition(args2, effective)};
1739 if (!arg2 || Distinguishable(arg1, *arg2)) {
1740 return i;
1741 }
1742 }
1743 effective += !arg1.pass;
1744 }
1745 return -1;
1746}
1747
1748// Find the index of the last nonoptional non-passed-object dummy argument
1749// in args1 whose name is such that either:
1750// - args2 has no dummy argument with that name
1751// - the dummy argument with that name is distinguishable from it
1752int DistinguishUtils::FindLastToDistinguishByName(
1753 const DummyArguments &args1, const DummyArguments &args2) const {
1754 std::map<std::string, const DummyArgument *> nameToArg;
1755 for (const auto &arg2 : args2) {
1756 nameToArg.emplace(arg2.name, &arg2);
1757 }
1758 for (int i = args1.size() - 1; i >= 0; --i) {
1759 const DummyArgument &arg1{args1.at(i)};
1760 if (!arg1.pass && !arg1.IsOptional()) {
1761 auto it{nameToArg.find(arg1.name)};
1762 if (it == nameToArg.end() || Distinguishable(arg1, *it->second)) {
1763 return i;
1764 }
1765 }
1766 }
1767 return -1;
1768}
1769
1770// Count the dummy data objects in args that are nonoptional, are not
1771// passed-object, and that x is TKR compatible with
1772int DistinguishUtils::CountCompatibleWith(
1773 const DummyArgument &x, const DummyArguments &args) const {
1774 return llvm::count_if(args, [&](const DummyArgument &y) {
1775 return !y.pass && !y.IsOptional() && IsTkrCompatible(x, y);
1776 });
1777}
1778
1779// Return the number of dummy data objects in args that are not
1780// distinguishable from x and not passed-object.
1781int DistinguishUtils::CountNotDistinguishableFrom(
1782 const DummyArgument &x, const DummyArguments &args) const {
1783 return llvm::count_if(args, [&](const DummyArgument &y) {
1784 return !y.pass && std::holds_alternative<DummyDataObject>(y.u) &&
1785 !Distinguishable(y, x);
1786 });
1787}
1788
1789bool DistinguishUtils::Distinguishable(
1790 const DummyArgument &x, const DummyArgument &y) const {
1791 if (x.u.index() != y.u.index()) {
1792 return true; // different kind: data/proc/alt-return
1793 }
1794 return common::visit(
1795 common::visitors{
1796 [&](const DummyDataObject &z) {
1797 return Distinguishable(z, std::get<DummyDataObject>(y.u));
1798 },
1799 [&](const DummyProcedure &z) {
1800 return Distinguishable(z, std::get<DummyProcedure>(y.u));
1801 },
1802 [&](const AlternateReturn &) { return false; },
1803 },
1804 x.u);
1805}
1806
1807bool DistinguishUtils::Distinguishable(
1808 const DummyDataObject &x, const DummyDataObject &y) const {
1809 using Attr = DummyDataObject::Attr;
1810 if (Distinguishable(x.type, y.type, x.ignoreTKR | y.ignoreTKR)) {
1811 return true;
1812 } else if (x.attrs.test(Attr::Allocatable) && y.attrs.test(Attr::Pointer) &&
1813 y.intent != common::Intent::In) {
1814 return true;
1815 } else if (y.attrs.test(Attr::Allocatable) && x.attrs.test(Attr::Pointer) &&
1816 x.intent != common::Intent::In) {
1817 return true;
1818 } else if (!common::AreCompatibleCUDADataAttrs(x.cudaDataAttr, y.cudaDataAttr,
1819 x.ignoreTKR | y.ignoreTKR, nullptr,
1820 /*allowUnifiedMatchingRule=*/false,
1821 /*=isHostDeviceProcedure*/ false)) {
1822 return true;
1823 } else if (features_.IsEnabled(
1824 common::LanguageFeature::DistinguishableSpecifics) &&
1825 (x.attrs.test(Attr::Allocatable) || x.attrs.test(Attr::Pointer)) &&
1826 (y.attrs.test(Attr::Allocatable) || y.attrs.test(Attr::Pointer)) &&
1827 (x.type.type().IsUnlimitedPolymorphic() !=
1828 y.type.type().IsUnlimitedPolymorphic() ||
1829 x.type.type().IsPolymorphic() != y.type.type().IsPolymorphic())) {
1830 // Extension: Per 15.5.2.5(2), an allocatable/pointer dummy and its
1831 // corresponding actual argument must both or neither be polymorphic,
1832 // and must both or neither be unlimited polymorphic. So when exactly
1833 // one of two dummy arguments is polymorphic or unlimited polymorphic,
1834 // any actual argument that is admissible to one of them cannot also match
1835 // the other one.
1836 return true;
1837 } else {
1838 return false;
1839 }
1840}
1841
1842bool DistinguishUtils::Distinguishable(
1843 const DummyProcedure &x, const DummyProcedure &y) const {
1844 const Procedure &xProc{x.procedure.value()};
1845 const Procedure &yProc{y.procedure.value()};
1846 if (Distinguishable(xProc, yProc).value_or(false)) {
1847 return true;
1848 } else {
1849 const std::optional<FunctionResult> &xResult{xProc.functionResult};
1850 const std::optional<FunctionResult> &yResult{yProc.functionResult};
1851 return xResult ? !yResult || Distinguishable(*xResult, *yResult)
1852 : yResult.has_value();
1853 }
1854}
1855
1856bool DistinguishUtils::Distinguishable(
1857 const FunctionResult &x, const FunctionResult &y) const {
1858 if (x.u.index() != y.u.index()) {
1859 return true; // one is data object, one is procedure
1860 }
1861 if (x.cudaDataAttr != y.cudaDataAttr) {
1862 return true;
1863 }
1864 return common::visit(
1865 common::visitors{
1866 [&](const TypeAndShape &z) {
1867 return Distinguishable(
1868 z, std::get<TypeAndShape>(y.u), common::IgnoreTKRSet{});
1869 },
1870 [&](const CopyableIndirection<Procedure> &z) {
1871 return Distinguishable(z.value(),
1872 std::get<CopyableIndirection<Procedure>>(y.u).value())
1873 .value_or(false);
1874 },
1875 },
1876 x.u);
1877}
1878
1879bool DistinguishUtils::Distinguishable(const TypeAndShape &x,
1880 const TypeAndShape &y, common::IgnoreTKRSet ignoreTKR) const {
1881 if (!x.type().IsTkCompatibleWith(y.type(), ignoreTKR) &&
1882 !y.type().IsTkCompatibleWith(x.type(), ignoreTKR)) {
1883 return true;
1884 }
1885 if (ignoreTKR.test(common::IgnoreTKR::Rank)) {
1886 } else if (x.attrs().test(TypeAndShape::Attr::AssumedRank) ||
1887 y.attrs().test(TypeAndShape::Attr::AssumedRank)) {
1888 } else if (x.Rank() != y.Rank()) {
1889 return true;
1890 }
1891 return false;
1892}
1893
1894// Compatibility based on type, kind, and rank
1895
1896bool DistinguishUtils::IsTkrCompatible(
1897 const DummyArgument &x, const DummyArgument &y) const {
1898 const auto *obj1{std::get_if<DummyDataObject>(&x.u)};
1899 const auto *obj2{std::get_if<DummyDataObject>(&y.u)};
1900 return obj1 && obj2 && IsTkCompatible(*obj1, *obj2) &&
1901 (obj1->type.Rank() == obj2->type.Rank() ||
1902 obj1->type.attrs().test(TypeAndShape::Attr::AssumedRank) ||
1903 obj2->type.attrs().test(TypeAndShape::Attr::AssumedRank) ||
1904 obj1->ignoreTKR.test(common::IgnoreTKR::Rank) ||
1905 obj2->ignoreTKR.test(common::IgnoreTKR::Rank));
1906}
1907
1908bool DistinguishUtils::IsTkCompatible(
1909 const DummyDataObject &x, const DummyDataObject &y) const {
1910 return x.type.type().IsTkCompatibleWith(
1911 y.type.type(), x.ignoreTKR | y.ignoreTKR);
1912}
1913
1914// Return the argument at the given index, ignoring the passed arg
1915const DummyArgument *DistinguishUtils::GetAtEffectivePosition(
1916 const DummyArguments &args, int index) const {
1917 for (const DummyArgument &arg : args) {
1918 if (!arg.pass) {
1919 if (index == 0) {
1920 return &arg;
1921 }
1922 --index;
1923 }
1924 }
1925 return nullptr;
1926}
1927
1928// Return the passed-object dummy argument of this procedure, if any
1929const DummyArgument *DistinguishUtils::GetPassArg(const Procedure &proc) const {
1930 for (const auto &arg : proc.dummyArguments) {
1931 if (arg.pass) {
1932 return &arg;
1933 }
1934 }
1935 return nullptr;
1936}
1937
1938std::optional<bool> Distinguishable(
1939 const common::LanguageFeatureControl &features, const Procedure &x,
1940 const Procedure &y) {
1941 return DistinguishUtils{features}.Distinguishable(x, y);
1942}
1943
1944std::optional<bool> DistinguishableOpOrAssign(
1945 const common::LanguageFeatureControl &features, const Procedure &x,
1946 const Procedure &y) {
1947 return DistinguishUtils{features}.DistinguishableOpOrAssign(x, y);
1948}
1949
1950DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyArgument)
1951DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyProcedure)
1952DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(FunctionResult)
1953DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(Procedure)
1954} // namespace Fortran::evaluate::characteristics
1955
1956template class Fortran::common::Indirection<
1957 Fortran::evaluate::characteristics::Procedure, true>;
1958

Provided by KDAB

Privacy Policy
Improve your Profiling and Debugging skills
Find out more

source code of flang/lib/Evaluate/characteristics.cpp