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