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