1//===-- lib/Evaluate/type.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/type.h"
10#include "flang/Common/idioms.h"
11#include "flang/Common/type-kinds.h"
12#include "flang/Evaluate/expression.h"
13#include "flang/Evaluate/fold.h"
14#include "flang/Evaluate/target.h"
15#include "flang/Parser/characters.h"
16#include "flang/Semantics/scope.h"
17#include "flang/Semantics/symbol.h"
18#include "flang/Semantics/tools.h"
19#include "flang/Semantics/type.h"
20#include <algorithm>
21#include <optional>
22#include <string>
23
24// IsDescriptor() predicate: true when a symbol is implemented
25// at runtime with a descriptor.
26namespace Fortran::semantics {
27
28static bool IsDescriptor(const DeclTypeSpec *type) {
29 if (type) {
30 if (auto dynamicType{evaluate::DynamicType::From(*type)}) {
31 return dynamicType->RequiresDescriptor();
32 }
33 }
34 return false;
35}
36
37static bool IsDescriptor(const ObjectEntityDetails &details) {
38 if (IsDescriptor(details.type()) || details.IsAssumedRank()) {
39 return true;
40 }
41 for (const ShapeSpec &shapeSpec : details.shape()) {
42 if (const auto &ub{shapeSpec.ubound().GetExplicit()}) {
43 if (!IsConstantExpr(*ub)) {
44 return true;
45 }
46 } else {
47 return shapeSpec.ubound().isColon();
48 }
49 }
50 return false;
51}
52
53bool IsDescriptor(const Symbol &symbol) {
54 return common::visit(
55 common::visitors{
56 [&](const ObjectEntityDetails &d) {
57 return IsAllocatableOrPointer(symbol) || IsDescriptor(d);
58 },
59 [&](const ProcEntityDetails &d) { return false; },
60 [&](const EntityDetails &d) { return IsDescriptor(d.type()); },
61 [](const AssocEntityDetails &d) {
62 if (const auto &expr{d.expr()}) {
63 if (expr->Rank() > 0) {
64 return true;
65 }
66 if (const auto dynamicType{expr->GetType()}) {
67 if (dynamicType->RequiresDescriptor()) {
68 return true;
69 }
70 }
71 }
72 return false;
73 },
74 [](const SubprogramDetails &d) {
75 return d.isFunction() && IsDescriptor(d.result());
76 },
77 [](const UseDetails &d) { return IsDescriptor(d.symbol()); },
78 [](const HostAssocDetails &d) { return IsDescriptor(d.symbol()); },
79 [](const auto &) { return false; },
80 },
81 symbol.details());
82}
83
84bool IsPassedViaDescriptor(const Symbol &symbol) {
85 if (!IsDescriptor(symbol)) {
86 return false;
87 }
88 if (IsAllocatableOrPointer(symbol)) {
89 return true;
90 }
91 if (semantics::IsAssumedSizeArray(symbol)) {
92 return false;
93 }
94 if (const auto *object{
95 symbol.GetUltimate().detailsIf<ObjectEntityDetails>()}) {
96 if (object->isDummy()) {
97 if (object->type() &&
98 object->type()->category() == DeclTypeSpec::Character) {
99 return false;
100 }
101 bool isExplicitShape{true};
102 for (const ShapeSpec &shapeSpec : object->shape()) {
103 if (!shapeSpec.lbound().GetExplicit() ||
104 !shapeSpec.ubound().GetExplicit()) {
105 isExplicitShape = false;
106 break;
107 }
108 }
109 if (isExplicitShape) {
110 return false; // explicit shape but non-constant bounds
111 }
112 }
113 }
114 return true;
115}
116} // namespace Fortran::semantics
117
118namespace Fortran::evaluate {
119
120DynamicType::DynamicType(int k, const semantics::ParamValue &pv)
121 : category_{TypeCategory::Character}, kind_{k} {
122 CHECK(common::IsValidKindOfIntrinsicType(category_, kind_));
123 if (auto n{ToInt64(pv.GetExplicit())}) {
124 knownLength_ = *n > 0 ? *n : 0;
125 } else {
126 charLengthParamValue_ = &pv;
127 }
128}
129
130template <typename A> inline bool PointeeComparison(const A *x, const A *y) {
131 return x == y || (x && y && *x == *y);
132}
133
134bool DynamicType::operator==(const DynamicType &that) const {
135 return category_ == that.category_ && kind_ == that.kind_ &&
136 PointeeComparison(charLengthParamValue_, that.charLengthParamValue_) &&
137 knownLength().has_value() == that.knownLength().has_value() &&
138 (!knownLength() || *knownLength() == *that.knownLength()) &&
139 PointeeComparison(derived_, that.derived_);
140}
141
142std::optional<Expr<SubscriptInteger>> DynamicType::GetCharLength() const {
143 if (category_ == TypeCategory::Character) {
144 if (knownLength()) {
145 return AsExpr(Constant<SubscriptInteger>(*knownLength()));
146 } else if (charLengthParamValue_) {
147 if (auto length{charLengthParamValue_->GetExplicit()}) {
148 return ConvertToType<SubscriptInteger>(std::move(*length));
149 }
150 }
151 }
152 return std::nullopt;
153}
154
155std::size_t DynamicType::GetAlignment(
156 const TargetCharacteristics &targetCharacteristics) const {
157 if (category_ == TypeCategory::Derived) {
158 switch (GetDerivedTypeSpec().category()) {
159 SWITCH_COVERS_ALL_CASES
160 case semantics::DerivedTypeSpec::Category::DerivedType:
161 if (derived_ && derived_->scope()) {
162 return derived_->scope()->alignment().value_or(1);
163 }
164 break;
165 case semantics::DerivedTypeSpec::Category::IntrinsicVector:
166 case semantics::DerivedTypeSpec::Category::PairVector:
167 case semantics::DerivedTypeSpec::Category::QuadVector:
168 if (derived_ && derived_->scope()) {
169 return derived_->scope()->size();
170 } else {
171 common::die("Missing scope for Vector type.");
172 }
173 }
174 } else {
175 return targetCharacteristics.GetAlignment(category_, kind());
176 }
177 return 1; // needs to be after switch to dodge a bogus gcc warning
178}
179
180std::optional<Expr<SubscriptInteger>> DynamicType::MeasureSizeInBytes(
181 FoldingContext &context, bool aligned,
182 std::optional<std::int64_t> charLength) const {
183 switch (category_) {
184 case TypeCategory::Integer:
185 case TypeCategory::Unsigned:
186 case TypeCategory::Real:
187 case TypeCategory::Complex:
188 case TypeCategory::Logical:
189 return Expr<SubscriptInteger>{
190 context.targetCharacteristics().GetByteSize(category_, kind())};
191 case TypeCategory::Character:
192 if (auto len{charLength ? Expr<SubscriptInteger>{Constant<SubscriptInteger>{
193 *charLength}}
194 : GetCharLength()}) {
195 return Fold(context,
196 Expr<SubscriptInteger>{
197 context.targetCharacteristics().GetByteSize(category_, kind())} *
198 std::move(*len));
199 }
200 break;
201 case TypeCategory::Derived:
202 if (!IsPolymorphic() && derived_ && derived_->scope()) {
203 auto size{derived_->scope()->size()};
204 auto align{aligned ? derived_->scope()->alignment().value_or(0) : 0};
205 auto alignedSize{align > 0 ? ((size + align - 1) / align) * align : size};
206 return Expr<SubscriptInteger>{
207 static_cast<ConstantSubscript>(alignedSize)};
208 }
209 break;
210 }
211 return std::nullopt;
212}
213
214bool DynamicType::IsAssumedLengthCharacter() const {
215 return category_ == TypeCategory::Character && charLengthParamValue_ &&
216 charLengthParamValue_->isAssumed();
217}
218
219bool DynamicType::IsNonConstantLengthCharacter() const {
220 if (category_ != TypeCategory::Character) {
221 return false;
222 } else if (knownLength()) {
223 return false;
224 } else if (!charLengthParamValue_) {
225 return true;
226 } else if (const auto &expr{charLengthParamValue_->GetExplicit()}) {
227 return !IsConstantExpr(*expr);
228 } else {
229 return true;
230 }
231}
232
233bool DynamicType::IsTypelessIntrinsicArgument() const {
234 return category_ == TypeCategory::Integer && kind_ == TypelessKind;
235}
236
237bool DynamicType::IsLengthlessIntrinsicType() const {
238 return common::IsNumericTypeCategory(category_) ||
239 category_ == TypeCategory::Logical;
240}
241
242const semantics::DerivedTypeSpec *GetDerivedTypeSpec(
243 const std::optional<DynamicType> &type) {
244 return type ? GetDerivedTypeSpec(*type) : nullptr;
245}
246
247const semantics::DerivedTypeSpec *GetDerivedTypeSpec(const DynamicType &type) {
248 if (type.category() == TypeCategory::Derived &&
249 !type.IsUnlimitedPolymorphic()) {
250 return &type.GetDerivedTypeSpec();
251 } else {
252 return nullptr;
253 }
254}
255
256static const semantics::Symbol *FindParentComponent(
257 const semantics::DerivedTypeSpec &derived) {
258 const semantics::Symbol &typeSymbol{derived.typeSymbol()};
259 const semantics::Scope *scope{derived.scope()};
260 if (!scope) {
261 scope = typeSymbol.scope();
262 }
263 if (scope) {
264 const auto &dtDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
265 // TODO: Combine with semantics::DerivedTypeDetails::GetParentComponent
266 if (auto extends{dtDetails.GetParentComponentName()}) {
267 if (auto iter{scope->find(*extends)}; iter != scope->cend()) {
268 if (const semantics::Symbol & symbol{*iter->second};
269 symbol.test(semantics::Symbol::Flag::ParentComp)) {
270 return &symbol;
271 }
272 }
273 }
274 }
275 return nullptr;
276}
277
278const semantics::DerivedTypeSpec *GetParentTypeSpec(
279 const semantics::DerivedTypeSpec &derived) {
280 if (const semantics::Symbol * parent{FindParentComponent(derived)}) {
281 return &parent->get<semantics::ObjectEntityDetails>()
282 .type()
283 ->derivedTypeSpec();
284 } else {
285 return nullptr;
286 }
287}
288
289// Compares two derived type representations to see whether they both
290// represent the "same type" in the sense of section F'2023 7.5.2.4.
291using SetOfDerivedTypePairs =
292 std::set<std::pair<const semantics::DerivedTypeSpec *,
293 const semantics::DerivedTypeSpec *>>;
294
295static bool AreSameDerivedType(const semantics::DerivedTypeSpec &,
296 const semantics::DerivedTypeSpec &, bool ignoreTypeParameterValues,
297 bool ignoreLenParameters, bool ignoreSequence,
298 SetOfDerivedTypePairs &inProgress);
299
300// F2023 7.5.3.2
301static bool AreSameComponent(const semantics::Symbol &x,
302 const semantics::Symbol &y, bool ignoreSequence,
303 SetOfDerivedTypePairs &inProgress) {
304 if (x.attrs() != y.attrs()) {
305 return false;
306 }
307 if (x.attrs().test(semantics::Attr::PRIVATE)) {
308 return false;
309 }
310 if (x.size() && y.size()) {
311 if (x.offset() != y.offset() || x.size() != y.size()) {
312 return false;
313 }
314 }
315 const auto *xObj{x.detailsIf<semantics::ObjectEntityDetails>()};
316 const auto *yObj{y.detailsIf<semantics::ObjectEntityDetails>()};
317 const auto *xProc{x.detailsIf<semantics::ProcEntityDetails>()};
318 const auto *yProc{y.detailsIf<semantics::ProcEntityDetails>()};
319 if (!xObj != !yObj || !xProc != !yProc) {
320 return false;
321 }
322 auto xType{DynamicType::From(x)};
323 auto yType{DynamicType::From(y)};
324 if (xType && yType) {
325 if (xType->category() == TypeCategory::Derived) {
326 if (yType->category() != TypeCategory::Derived ||
327 !xType->IsUnlimitedPolymorphic() !=
328 !yType->IsUnlimitedPolymorphic() ||
329 (!xType->IsUnlimitedPolymorphic() &&
330 !AreSameDerivedType(xType->GetDerivedTypeSpec(),
331 yType->GetDerivedTypeSpec(), false, false, ignoreSequence,
332 inProgress))) {
333 return false;
334 }
335 } else if (!xType->IsTkLenCompatibleWith(*yType)) {
336 return false;
337 }
338 } else if (xType || yType || !(xProc && yProc)) {
339 return false;
340 }
341 if (xProc) {
342 // TODO: compare argument types, &c.
343 }
344 return true;
345}
346
347// TODO: These utilities were cloned out of Semantics to avoid a cyclic
348// dependency and should be repackaged into then "namespace semantics"
349// part of Evaluate/tools.cpp.
350
351static const semantics::Symbol *GetParentComponent(
352 const semantics::DerivedTypeDetails &details,
353 const semantics::Scope &scope) {
354 if (auto extends{details.GetParentComponentName()}) {
355 if (auto iter{scope.find(*extends)}; iter != scope.cend()) {
356 if (const Symbol & symbol{*iter->second};
357 symbol.test(semantics::Symbol::Flag::ParentComp)) {
358 return &symbol;
359 }
360 }
361 }
362 return nullptr;
363}
364
365static const semantics::Symbol *GetParentComponent(
366 const semantics::Symbol *symbol, const semantics::Scope &scope) {
367 if (symbol) {
368 if (const auto *dtDetails{
369 symbol->detailsIf<semantics::DerivedTypeDetails>()}) {
370 return GetParentComponent(*dtDetails, scope);
371 }
372 }
373 return nullptr;
374}
375
376static const semantics::DerivedTypeSpec *GetParentTypeSpec(
377 const semantics::Symbol *symbol, const semantics::Scope &scope) {
378 if (const Symbol * parentComponent{GetParentComponent(symbol, scope)}) {
379 return &parentComponent->get<semantics::ObjectEntityDetails>()
380 .type()
381 ->derivedTypeSpec();
382 } else {
383 return nullptr;
384 }
385}
386
387static const semantics::Scope *GetDerivedTypeParent(
388 const semantics::Scope *scope) {
389 if (scope) {
390 CHECK(scope->IsDerivedType());
391 if (const auto *parent{GetParentTypeSpec(scope->GetSymbol(), *scope)}) {
392 return parent->scope();
393 }
394 }
395 return nullptr;
396}
397
398static const semantics::Symbol *FindComponent(
399 const semantics::Scope *scope, parser::CharBlock name) {
400 if (!scope) {
401 return nullptr;
402 }
403 CHECK(scope->IsDerivedType());
404 auto found{scope->find(name)};
405 if (found != scope->end()) {
406 return &*found->second;
407 } else {
408 return FindComponent(GetDerivedTypeParent(scope), name);
409 }
410}
411
412static bool AreTypeParamCompatible(const semantics::DerivedTypeSpec &x,
413 const semantics::DerivedTypeSpec &y, bool ignoreLenParameters) {
414 const auto *xScope{x.typeSymbol().scope()};
415 const auto *yScope{y.typeSymbol().scope()};
416 for (const auto &[paramName, value] : x.parameters()) {
417 const auto *yValue{y.FindParameter(paramName)};
418 if (!yValue) {
419 return false;
420 }
421 const auto *xParm{FindComponent(xScope, paramName)};
422 const auto *yParm{FindComponent(yScope, paramName)};
423 if (xParm && yParm) {
424 const auto *xTPD{xParm->detailsIf<semantics::TypeParamDetails>()};
425 const auto *yTPD{yParm->detailsIf<semantics::TypeParamDetails>()};
426 if (xTPD && yTPD) {
427 if (xTPD->attr() != yTPD->attr()) {
428 return false;
429 }
430 if (!ignoreLenParameters ||
431 xTPD->attr() != common::TypeParamAttr::Len) {
432 auto xExpr{value.GetExplicit()};
433 auto yExpr{yValue->GetExplicit()};
434 if (xExpr && yExpr) {
435 auto xVal{ToInt64(*xExpr)};
436 auto yVal{ToInt64(*yExpr)};
437 if (xVal && yVal && *xVal != *yVal) {
438 return false;
439 }
440 }
441 }
442 }
443 }
444 }
445 for (const auto &[paramName, _] : y.parameters()) {
446 if (!x.FindParameter(paramName)) {
447 return false; // y has more parameters than x
448 }
449 }
450 return true;
451}
452
453// F2023 7.5.3.2
454static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
455 const semantics::DerivedTypeSpec &y, bool ignoreTypeParameterValues,
456 bool ignoreLenParameters, bool ignoreSequence,
457 SetOfDerivedTypePairs &inProgress) {
458 if (&x == &y) {
459 return true;
460 }
461 if (!ignoreTypeParameterValues &&
462 !AreTypeParamCompatible(x, y, ignoreLenParameters)) {
463 return false;
464 }
465 const auto &xSymbol{x.typeSymbol().GetUltimate()};
466 const auto &ySymbol{y.typeSymbol().GetUltimate()};
467 if (xSymbol == ySymbol) {
468 return true;
469 }
470 if (xSymbol.name() != ySymbol.name()) {
471 return false;
472 }
473 auto thisQuery{std::make_pair(&x, &y)};
474 if (inProgress.find(thisQuery) != inProgress.end()) {
475 return true; // recursive use of types in components
476 }
477 inProgress.insert(thisQuery);
478 const auto &xDetails{xSymbol.get<semantics::DerivedTypeDetails>()};
479 const auto &yDetails{ySymbol.get<semantics::DerivedTypeDetails>()};
480 if (xDetails.sequence() != yDetails.sequence() ||
481 xSymbol.attrs().test(semantics::Attr::BIND_C) !=
482 ySymbol.attrs().test(semantics::Attr::BIND_C)) {
483 return false;
484 }
485 if (!ignoreSequence && !(xDetails.sequence() && yDetails.sequence()) &&
486 !(xSymbol.attrs().test(semantics::Attr::BIND_C) &&
487 ySymbol.attrs().test(semantics::Attr::BIND_C))) {
488 // PGI does not enforce this requirement; all other Fortran
489 // compilers do with a hard error when violations are caught.
490 return false;
491 }
492 // Compare the component lists in their orders of declaration.
493 auto xEnd{xDetails.componentNames().cend()};
494 auto yComponentName{yDetails.componentNames().cbegin()};
495 auto yEnd{yDetails.componentNames().cend()};
496 for (auto xComponentName{xDetails.componentNames().cbegin()};
497 xComponentName != xEnd; ++xComponentName, ++yComponentName) {
498 if (yComponentName == yEnd || *xComponentName != *yComponentName ||
499 !xSymbol.scope() || !ySymbol.scope()) {
500 return false;
501 }
502 const auto xLookup{xSymbol.scope()->find(*xComponentName)};
503 const auto yLookup{ySymbol.scope()->find(*yComponentName)};
504 if (xLookup == xSymbol.scope()->end() ||
505 yLookup == ySymbol.scope()->end() ||
506 !AreSameComponent(
507 *xLookup->second, *yLookup->second, ignoreSequence, inProgress)) {
508 return false;
509 }
510 }
511 return yComponentName == yEnd;
512}
513
514bool AreSameDerivedType(
515 const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
516 SetOfDerivedTypePairs inProgress;
517 return AreSameDerivedType(x, y, false, false, false, inProgress);
518}
519
520bool AreSameDerivedTypeIgnoringTypeParameters(
521 const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
522 SetOfDerivedTypePairs inProgress;
523 return AreSameDerivedType(x, y, true, true, false, inProgress);
524}
525
526bool AreSameDerivedTypeIgnoringSequence(
527 const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
528 SetOfDerivedTypePairs inProgress;
529 return AreSameDerivedType(x, y, false, false, true, inProgress);
530}
531
532static bool AreSameDerivedType(
533 const semantics::DerivedTypeSpec *x, const semantics::DerivedTypeSpec *y) {
534 return x == y || (x && y && AreSameDerivedType(*x, *y));
535}
536
537bool DynamicType::IsEquivalentTo(const DynamicType &that) const {
538 return category_ == that.category_ && kind_ == that.kind_ &&
539 (charLengthParamValue_ == that.charLengthParamValue_ ||
540 (charLengthParamValue_ && that.charLengthParamValue_ &&
541 charLengthParamValue_->IsEquivalentInInterface(
542 *that.charLengthParamValue_))) &&
543 knownLength().has_value() == that.knownLength().has_value() &&
544 (!knownLength() || *knownLength() == *that.knownLength()) &&
545 AreSameDerivedType(derived_, that.derived_);
546}
547
548static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
549 const semantics::DerivedTypeSpec *y, bool isPolymorphic,
550 bool ignoreTypeParameterValues, bool ignoreLenTypeParameters) {
551 if (!x || !y) {
552 return false;
553 } else {
554 SetOfDerivedTypePairs inProgress;
555 if (AreSameDerivedType(*x, *y, ignoreTypeParameterValues,
556 ignoreLenTypeParameters, false, inProgress)) {
557 return true;
558 } else {
559 return isPolymorphic &&
560 AreCompatibleDerivedTypes(x, GetParentTypeSpec(*y), true,
561 ignoreTypeParameterValues, ignoreLenTypeParameters);
562 }
563 }
564}
565
566static bool AreCompatibleTypes(const DynamicType &x, const DynamicType &y,
567 bool ignoreTypeParameterValues, bool ignoreLengths) {
568 if (x.IsUnlimitedPolymorphic()) {
569 return true;
570 } else if (y.IsUnlimitedPolymorphic()) {
571 return false;
572 } else if (x.category() != y.category()) {
573 return false;
574 } else if (x.category() == TypeCategory::Character) {
575 const auto xLen{x.knownLength()};
576 const auto yLen{y.knownLength()};
577 return x.kind() == y.kind() &&
578 (ignoreLengths || !xLen || !yLen || *xLen == *yLen);
579 } else if (x.category() != TypeCategory::Derived) {
580 if (x.IsTypelessIntrinsicArgument()) {
581 return y.IsTypelessIntrinsicArgument();
582 } else {
583 return !y.IsTypelessIntrinsicArgument() && x.kind() == y.kind();
584 }
585 } else {
586 const auto *xdt{GetDerivedTypeSpec(x)};
587 const auto *ydt{GetDerivedTypeSpec(y)};
588 return AreCompatibleDerivedTypes(
589 xdt, ydt, x.IsPolymorphic(), ignoreTypeParameterValues, false);
590 }
591}
592
593// See 7.3.2.3 (5) & 15.5.2.4
594bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const {
595 return AreCompatibleTypes(*this, that, false, true);
596}
597
598bool DynamicType::IsTkCompatibleWith(
599 const DynamicType &that, common::IgnoreTKRSet ignoreTKR) const {
600 if (ignoreTKR.test(common::IgnoreTKR::Type) &&
601 (category() == TypeCategory::Derived ||
602 that.category() == TypeCategory::Derived ||
603 category() != that.category())) {
604 return true;
605 } else if (ignoreTKR.test(common::IgnoreTKR::Kind) &&
606 category() == that.category()) {
607 return true;
608 } else {
609 return AreCompatibleTypes(*this, that, false, true);
610 }
611}
612
613bool DynamicType::IsTkLenCompatibleWith(const DynamicType &that) const {
614 return AreCompatibleTypes(*this, that, false, false);
615}
616
617// 16.9.165
618std::optional<bool> DynamicType::SameTypeAs(const DynamicType &that) const {
619 bool x{AreCompatibleTypes(*this, that, true, true)};
620 bool y{AreCompatibleTypes(that, *this, true, true)};
621 if (!x && !y) {
622 return false;
623 } else if (x && y && !IsPolymorphic() && !that.IsPolymorphic()) {
624 return true;
625 } else {
626 return std::nullopt;
627 }
628}
629
630// 16.9.76
631std::optional<bool> DynamicType::ExtendsTypeOf(const DynamicType &that) const {
632 if (IsUnlimitedPolymorphic() || that.IsUnlimitedPolymorphic()) {
633 return std::nullopt; // unknown
634 }
635 const auto *thisDts{evaluate::GetDerivedTypeSpec(*this)};
636 const auto *thatDts{evaluate::GetDerivedTypeSpec(that)};
637 if (!thisDts || !thatDts) {
638 return std::nullopt;
639 } else if (!AreCompatibleDerivedTypes(thatDts, thisDts, true, true, true)) {
640 // Note that I check *thisDts, not its parent, so that EXTENDS_TYPE_OF()
641 // is .true. when they are the same type. This is technically
642 // an implementation-defined case in the standard, but every other
643 // compiler works this way.
644 if (IsPolymorphic() &&
645 AreCompatibleDerivedTypes(thisDts, thatDts, true, true, true)) {
646 // 'that' is *this or an extension of *this, and so runtime *this
647 // could be an extension of 'that'
648 return std::nullopt;
649 } else {
650 return false;
651 }
652 } else if (that.IsPolymorphic()) {
653 return std::nullopt; // unknown
654 } else {
655 return true;
656 }
657}
658
659std::optional<DynamicType> DynamicType::From(
660 const semantics::DeclTypeSpec &type) {
661 if (const auto *intrinsic{type.AsIntrinsic()}) {
662 if (auto kind{ToInt64(intrinsic->kind())}) {
663 TypeCategory category{intrinsic->category()};
664 if (common::IsValidKindOfIntrinsicType(category, *kind)) {
665 if (category == TypeCategory::Character) {
666 const auto &charType{type.characterTypeSpec()};
667 return DynamicType{static_cast<int>(*kind), charType.length()};
668 } else {
669 return DynamicType{category, static_cast<int>(*kind)};
670 }
671 }
672 }
673 } else if (const auto *derived{type.AsDerived()}) {
674 return DynamicType{
675 *derived, type.category() == semantics::DeclTypeSpec::ClassDerived};
676 } else if (type.category() == semantics::DeclTypeSpec::ClassStar) {
677 return DynamicType::UnlimitedPolymorphic();
678 } else if (type.category() == semantics::DeclTypeSpec::TypeStar) {
679 return DynamicType::AssumedType();
680 } else {
681 common::die("DynamicType::From(DeclTypeSpec): failed");
682 }
683 return std::nullopt;
684}
685
686std::optional<DynamicType> DynamicType::From(const semantics::Symbol &symbol) {
687 return From(symbol.GetType()); // Symbol -> DeclTypeSpec -> DynamicType
688}
689
690DynamicType DynamicType::ResultTypeForMultiply(const DynamicType &that) const {
691 switch (category_) {
692 case TypeCategory::Integer:
693 switch (that.category_) {
694 case TypeCategory::Integer:
695 return DynamicType{TypeCategory::Integer, std::max(kind(), that.kind())};
696 case TypeCategory::Real:
697 case TypeCategory::Complex:
698 return that;
699 default:
700 CRASH_NO_CASE;
701 }
702 break;
703 case TypeCategory::Unsigned:
704 switch (that.category_) {
705 case TypeCategory::Unsigned:
706 return DynamicType{TypeCategory::Unsigned, std::max(kind(), that.kind())};
707 default:
708 CRASH_NO_CASE;
709 }
710 break;
711 case TypeCategory::Real:
712 switch (that.category_) {
713 case TypeCategory::Integer:
714 return *this;
715 case TypeCategory::Real:
716 return DynamicType{TypeCategory::Real, std::max(kind(), that.kind())};
717 case TypeCategory::Complex:
718 return DynamicType{TypeCategory::Complex, std::max(kind(), that.kind())};
719 default:
720 CRASH_NO_CASE;
721 }
722 break;
723 case TypeCategory::Complex:
724 switch (that.category_) {
725 case TypeCategory::Integer:
726 return *this;
727 case TypeCategory::Real:
728 case TypeCategory::Complex:
729 return DynamicType{TypeCategory::Complex, std::max(kind(), that.kind())};
730 default:
731 CRASH_NO_CASE;
732 }
733 break;
734 case TypeCategory::Logical:
735 switch (that.category_) {
736 case TypeCategory::Logical:
737 return DynamicType{TypeCategory::Logical, std::max(kind(), that.kind())};
738 default:
739 CRASH_NO_CASE;
740 }
741 break;
742 default:
743 CRASH_NO_CASE;
744 }
745 return *this;
746}
747
748bool DynamicType::RequiresDescriptor() const {
749 return IsPolymorphic() || IsNonConstantLengthCharacter() ||
750 (derived_ && CountNonConstantLenParameters(*derived_) > 0);
751}
752
753bool DynamicType::HasDeferredTypeParameter() const {
754 if (derived_) {
755 for (const auto &pair : derived_->parameters()) {
756 if (pair.second.isDeferred()) {
757 return true;
758 }
759 }
760 }
761 return charLengthParamValue_ && charLengthParamValue_->isDeferred();
762}
763
764bool SomeKind<TypeCategory::Derived>::operator==(
765 const SomeKind<TypeCategory::Derived> &that) const {
766 return PointeeComparison(derivedTypeSpec_, that.derivedTypeSpec_);
767}
768
769int SelectedCharKind(const std::string &s, int defaultKind) { // F'2023 16.9.180
770 auto lower{parser::ToLowerCaseLetters(s)};
771 auto n{lower.size()};
772 while (n > 0 && lower[0] == ' ') {
773 lower.erase(0, 1);
774 --n;
775 }
776 while (n > 0 && lower[n - 1] == ' ') {
777 lower.erase(--n, 1);
778 }
779 if (lower == "ascii") {
780 return 1;
781 } else if (lower == "ucs-2") {
782 return 2;
783 } else if (lower == "iso_10646" || lower == "ucs-4") {
784 return 4;
785 } else if (lower == "default") {
786 return defaultKind;
787 } else {
788 return -1;
789 }
790}
791
792std::optional<DynamicType> ComparisonType(
793 const DynamicType &t1, const DynamicType &t2) {
794 switch (t1.category()) {
795 case TypeCategory::Integer:
796 switch (t2.category()) {
797 case TypeCategory::Integer:
798 return DynamicType{TypeCategory::Integer, std::max(t1.kind(), t2.kind())};
799 case TypeCategory::Real:
800 case TypeCategory::Complex:
801 return t2;
802 default:
803 return std::nullopt;
804 }
805 case TypeCategory::Real:
806 switch (t2.category()) {
807 case TypeCategory::Integer:
808 return t1;
809 case TypeCategory::Real:
810 case TypeCategory::Complex:
811 return DynamicType{t2.category(), std::max(t1.kind(), t2.kind())};
812 default:
813 return std::nullopt;
814 }
815 case TypeCategory::Complex:
816 switch (t2.category()) {
817 case TypeCategory::Integer:
818 return t1;
819 case TypeCategory::Real:
820 case TypeCategory::Complex:
821 return DynamicType{TypeCategory::Complex, std::max(t1.kind(), t2.kind())};
822 default:
823 return std::nullopt;
824 }
825 case TypeCategory::Character:
826 switch (t2.category()) {
827 case TypeCategory::Character:
828 return DynamicType{
829 TypeCategory::Character, std::max(t1.kind(), t2.kind())};
830 default:
831 return std::nullopt;
832 }
833 case TypeCategory::Logical:
834 switch (t2.category()) {
835 case TypeCategory::Logical:
836 return DynamicType{TypeCategory::Logical, LogicalResult::kind};
837 default:
838 return std::nullopt;
839 }
840 default:
841 return std::nullopt;
842 }
843}
844
845std::optional<bool> IsInteroperableIntrinsicType(const DynamicType &type,
846 const common::LanguageFeatureControl *features, bool checkCharLength) {
847 switch (type.category()) {
848 case TypeCategory::Integer:
849 case TypeCategory::Unsigned:
850 return true;
851 case TypeCategory::Real:
852 case TypeCategory::Complex:
853 return type.kind() >= 4 /* not a short or half float */ || !features ||
854 features->IsEnabled(common::LanguageFeature::CUDA);
855 case TypeCategory::Logical:
856 return type.kind() == 1; // C_BOOL
857 case TypeCategory::Character:
858 if (type.kind() != 1) { // C_CHAR
859 return false;
860 } else if (checkCharLength) {
861 if (type.knownLength()) {
862 return *type.knownLength() == 1;
863 } else {
864 return std::nullopt;
865 }
866 } else {
867 return true;
868 }
869 default:
870 // Derived types are tested in Semantics/check-declarations.cpp
871 return false;
872 }
873}
874
875bool IsCUDAIntrinsicType(const DynamicType &type) {
876 switch (type.category()) {
877 case TypeCategory::Integer:
878 case TypeCategory::Logical:
879 return type.kind() <= 8;
880 case TypeCategory::Real:
881 return type.kind() >= 2 && type.kind() <= 8;
882 case TypeCategory::Complex:
883 return type.kind() == 2 || type.kind() == 4 || type.kind() == 8;
884 case TypeCategory::Character:
885 return type.kind() == 1;
886 default:
887 // Derived types are tested in Semantics/check-declarations.cpp
888 return false;
889 }
890}
891
892DynamicType DynamicType::DropNonConstantCharacterLength() const {
893 if (charLengthParamValue_ && charLengthParamValue_->isExplicit()) {
894 if (std::optional<std::int64_t> len{knownLength()}) {
895 return DynamicType(kind_, *len);
896 } else {
897 return DynamicType(category_, kind_);
898 }
899 }
900 return *this;
901}
902
903} // namespace Fortran::evaluate
904

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