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