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

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