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