xref: /llvm-project/flang/lib/Evaluate/type.cpp (revision d15491e90c5bf1891f64ce15a712659c9570c861) 
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     if (derived_ && derived_->scope()) {
156       return derived_->scope()->alignment().value_or(1);
157     }
158   } else {
159     return targetCharacteristics.GetAlignment(category_, kind_);
160   }
161   return 1; // needs to be after switch to dodge a bogus gcc warning
162 }
163 
164 std::optional<Expr<SubscriptInteger>> DynamicType::MeasureSizeInBytes(
165     FoldingContext &context, bool aligned,
166     std::optional<std::int64_t> charLength) const {
167   switch (category_) {
168   case TypeCategory::Integer:
169   case TypeCategory::Real:
170   case TypeCategory::Complex:
171   case TypeCategory::Logical:
172     return Expr<SubscriptInteger>{
173         context.targetCharacteristics().GetByteSize(category_, kind_)};
174   case TypeCategory::Character:
175     if (auto len{charLength ? Expr<SubscriptInteger>{Constant<SubscriptInteger>{
176                                   *charLength}}
177                             : GetCharLength()}) {
178       return Fold(context,
179           Expr<SubscriptInteger>{
180               context.targetCharacteristics().GetByteSize(category_, kind_)} *
181               std::move(*len));
182     }
183     break;
184   case TypeCategory::Derived:
185     if (!IsPolymorphic() && derived_ && derived_->scope()) {
186       auto size{derived_->scope()->size()};
187       auto align{aligned ? derived_->scope()->alignment().value_or(0) : 0};
188       auto alignedSize{align > 0 ? ((size + align - 1) / align) * align : size};
189       return Expr<SubscriptInteger>{
190           static_cast<ConstantSubscript>(alignedSize)};
191     }
192     break;
193   }
194   return std::nullopt;
195 }
196 
197 bool DynamicType::IsAssumedLengthCharacter() const {
198   return category_ == TypeCategory::Character && charLengthParamValue_ &&
199       charLengthParamValue_->isAssumed();
200 }
201 
202 bool DynamicType::IsNonConstantLengthCharacter() const {
203   if (category_ != TypeCategory::Character) {
204     return false;
205   } else if (knownLength()) {
206     return false;
207   } else if (!charLengthParamValue_) {
208     return true;
209   } else if (const auto &expr{charLengthParamValue_->GetExplicit()}) {
210     return !IsConstantExpr(*expr);
211   } else {
212     return true;
213   }
214 }
215 
216 bool DynamicType::IsTypelessIntrinsicArgument() const {
217   return category_ == TypeCategory::Integer && kind_ == TypelessKind;
218 }
219 
220 const semantics::DerivedTypeSpec *GetDerivedTypeSpec(
221     const std::optional<DynamicType> &type) {
222   return type ? GetDerivedTypeSpec(*type) : nullptr;
223 }
224 
225 const semantics::DerivedTypeSpec *GetDerivedTypeSpec(const DynamicType &type) {
226   if (type.category() == TypeCategory::Derived &&
227       !type.IsUnlimitedPolymorphic()) {
228     return &type.GetDerivedTypeSpec();
229   } else {
230     return nullptr;
231   }
232 }
233 
234 static const semantics::Symbol *FindParentComponent(
235     const semantics::DerivedTypeSpec &derived) {
236   const semantics::Symbol &typeSymbol{derived.typeSymbol()};
237   const semantics::Scope *scope{derived.scope()};
238   if (!scope) {
239     scope = typeSymbol.scope();
240   }
241   if (scope) {
242     const auto &dtDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
243     // TODO: Combine with semantics::DerivedTypeDetails::GetParentComponent
244     if (auto extends{dtDetails.GetParentComponentName()}) {
245       if (auto iter{scope->find(*extends)}; iter != scope->cend()) {
246         if (const semantics::Symbol & symbol{*iter->second};
247             symbol.test(semantics::Symbol::Flag::ParentComp)) {
248           return &symbol;
249         }
250       }
251     }
252   }
253   return nullptr;
254 }
255 
256 const semantics::DerivedTypeSpec *GetParentTypeSpec(
257     const semantics::DerivedTypeSpec &derived) {
258   if (const semantics::Symbol * parent{FindParentComponent(derived)}) {
259     return &parent->get<semantics::ObjectEntityDetails>()
260                 .type()
261                 ->derivedTypeSpec();
262   } else {
263     return nullptr;
264   }
265 }
266 
267 // Compares two derived type representations to see whether they both
268 // represent the "same type" in the sense of section 7.5.2.4.
269 using SetOfDerivedTypePairs =
270     std::set<std::pair<const semantics::DerivedTypeSpec *,
271         const semantics::DerivedTypeSpec *>>;
272 
273 static bool AreSameComponent(const semantics::Symbol &x,
274     const semantics::Symbol &y,
275     SetOfDerivedTypePairs & /* inProgress - not yet used */) {
276   if (x.attrs() != y.attrs()) {
277     return false;
278   }
279   if (x.attrs().test(semantics::Attr::PRIVATE)) {
280     return false;
281   }
282   // TODO: compare types, parameters, bounds, &c.
283   return x.has<semantics::ObjectEntityDetails>() ==
284       y.has<semantics::ObjectEntityDetails>();
285 }
286 
287 // TODO: These utilities were cloned out of Semantics to avoid a cyclic
288 // dependency and should be repackaged into then "namespace semantics"
289 // part of Evaluate/tools.cpp.
290 
291 static const semantics::Symbol *GetParentComponent(
292     const semantics::DerivedTypeDetails &details,
293     const semantics::Scope &scope) {
294   if (auto extends{details.GetParentComponentName()}) {
295     if (auto iter{scope.find(*extends)}; iter != scope.cend()) {
296       if (const Symbol & symbol{*iter->second};
297           symbol.test(semantics::Symbol::Flag::ParentComp)) {
298         return &symbol;
299       }
300     }
301   }
302   return nullptr;
303 }
304 
305 static const semantics::Symbol *GetParentComponent(
306     const semantics::Symbol *symbol, const semantics::Scope &scope) {
307   if (symbol) {
308     if (const auto *dtDetails{
309             symbol->detailsIf<semantics::DerivedTypeDetails>()}) {
310       return GetParentComponent(*dtDetails, scope);
311     }
312   }
313   return nullptr;
314 }
315 
316 static const semantics::DerivedTypeSpec *GetParentTypeSpec(
317     const semantics::Symbol *symbol, const semantics::Scope &scope) {
318   if (const Symbol * parentComponent{GetParentComponent(symbol, scope)}) {
319     return &parentComponent->get<semantics::ObjectEntityDetails>()
320                 .type()
321                 ->derivedTypeSpec();
322   } else {
323     return nullptr;
324   }
325 }
326 
327 static const semantics::Scope *GetDerivedTypeParent(
328     const semantics::Scope *scope) {
329   if (scope) {
330     CHECK(scope->IsDerivedType());
331     if (const auto *parent{GetParentTypeSpec(scope->GetSymbol(), *scope)}) {
332       return parent->scope();
333     }
334   }
335   return nullptr;
336 }
337 
338 static const semantics::Symbol *FindComponent(
339     const semantics::Scope *scope, parser::CharBlock name) {
340   if (!scope) {
341     return nullptr;
342   }
343   CHECK(scope->IsDerivedType());
344   auto found{scope->find(name)};
345   if (found != scope->end()) {
346     return &*found->second;
347   } else {
348     return FindComponent(GetDerivedTypeParent(scope), name);
349   }
350 }
351 
352 static bool AreTypeParamCompatible(const semantics::DerivedTypeSpec &x,
353     const semantics::DerivedTypeSpec &y, bool ignoreLenParameters) {
354   const auto *xScope{x.typeSymbol().scope()};
355   const auto *yScope{y.typeSymbol().scope()};
356   for (const auto &[paramName, value] : x.parameters()) {
357     const auto *yValue{y.FindParameter(paramName)};
358     if (!yValue) {
359       return false;
360     }
361     const auto *xParm{FindComponent(xScope, paramName)};
362     const auto *yParm{FindComponent(yScope, paramName)};
363     if (xParm && yParm) {
364       const auto *xTPD{xParm->detailsIf<semantics::TypeParamDetails>()};
365       const auto *yTPD{yParm->detailsIf<semantics::TypeParamDetails>()};
366       if (xTPD && yTPD) {
367         if (xTPD->attr() != yTPD->attr()) {
368           return false;
369         }
370         if (!ignoreLenParameters ||
371             xTPD->attr() != common::TypeParamAttr::Len) {
372           auto xExpr{value.GetExplicit()};
373           auto yExpr{yValue->GetExplicit()};
374           if (xExpr && yExpr) {
375             auto xVal{ToInt64(*xExpr)};
376             auto yVal{ToInt64(*yExpr)};
377             if (xVal && yVal && *xVal != *yVal) {
378               return false;
379             }
380           }
381         }
382       }
383     }
384   }
385   for (const auto &[paramName, _] : y.parameters()) {
386     if (!x.FindParameter(paramName)) {
387       return false; // y has more parameters than x
388     }
389   }
390   return true;
391 }
392 
393 static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
394     const semantics::DerivedTypeSpec &y, bool ignoreTypeParameterValues,
395     bool ignoreLenParameters, SetOfDerivedTypePairs &inProgress) {
396   if (&x == &y) {
397     return true;
398   }
399   if (!ignoreTypeParameterValues &&
400       !AreTypeParamCompatible(x, y, ignoreLenParameters)) {
401     return false;
402   }
403   const auto &xSymbol{x.typeSymbol()};
404   const auto &ySymbol{y.typeSymbol()};
405   if (xSymbol == ySymbol) {
406     return true;
407   }
408   if (xSymbol.name() != ySymbol.name()) {
409     return false;
410   }
411   auto thisQuery{std::make_pair(&x, &y)};
412   if (inProgress.find(thisQuery) != inProgress.end()) {
413     return true; // recursive use of types in components
414   }
415   inProgress.insert(thisQuery);
416   const auto &xDetails{xSymbol.get<semantics::DerivedTypeDetails>()};
417   const auto &yDetails{ySymbol.get<semantics::DerivedTypeDetails>()};
418   if (!(xDetails.sequence() && yDetails.sequence()) &&
419       !(xSymbol.attrs().test(semantics::Attr::BIND_C) &&
420           ySymbol.attrs().test(semantics::Attr::BIND_C))) {
421     // PGI does not enforce this requirement; all other Fortran
422     // processors do with a hard error when violations are caught.
423     return false;
424   }
425   // Compare the component lists in their orders of declaration.
426   auto xEnd{xDetails.componentNames().cend()};
427   auto yComponentName{yDetails.componentNames().cbegin()};
428   auto yEnd{yDetails.componentNames().cend()};
429   for (auto xComponentName{xDetails.componentNames().cbegin()};
430        xComponentName != xEnd; ++xComponentName, ++yComponentName) {
431     if (yComponentName == yEnd || *xComponentName != *yComponentName ||
432         !xSymbol.scope() || !ySymbol.scope()) {
433       return false;
434     }
435     const auto xLookup{xSymbol.scope()->find(*xComponentName)};
436     const auto yLookup{ySymbol.scope()->find(*yComponentName)};
437     if (xLookup == xSymbol.scope()->end() ||
438         yLookup == ySymbol.scope()->end() ||
439         !AreSameComponent(*xLookup->second, *yLookup->second, inProgress)) {
440       return false;
441     }
442   }
443   return yComponentName == yEnd;
444 }
445 
446 bool AreSameDerivedType(
447     const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
448   SetOfDerivedTypePairs inProgress;
449   return AreSameDerivedType(x, y, false, false, inProgress);
450 }
451 
452 static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
453     const semantics::DerivedTypeSpec *y, bool isPolymorphic,
454     bool ignoreTypeParameterValues, bool ignoreLenTypeParameters) {
455   if (!x || !y) {
456     return false;
457   } else {
458     SetOfDerivedTypePairs inProgress;
459     if (AreSameDerivedType(*x, *y, ignoreTypeParameterValues,
460             ignoreLenTypeParameters, inProgress)) {
461       return true;
462     } else {
463       return isPolymorphic &&
464           AreCompatibleDerivedTypes(x, GetParentTypeSpec(*y), true,
465               ignoreTypeParameterValues, ignoreLenTypeParameters);
466     }
467   }
468 }
469 
470 static bool AreCompatibleTypes(const DynamicType &x, const DynamicType &y,
471     bool ignoreTypeParameterValues, bool ignoreLengths) {
472   if (x.IsUnlimitedPolymorphic()) {
473     return true;
474   } else if (y.IsUnlimitedPolymorphic()) {
475     return false;
476   } else if (x.category() != y.category()) {
477     return false;
478   } else if (x.category() == TypeCategory::Character) {
479     const auto xLen{x.knownLength()};
480     const auto yLen{y.knownLength()};
481     return x.kind() == y.kind() &&
482         (ignoreLengths || !xLen || !yLen || *xLen == *yLen);
483   } else if (x.category() != TypeCategory::Derived) {
484     return x.kind() == y.kind();
485   } else {
486     const auto *xdt{GetDerivedTypeSpec(x)};
487     const auto *ydt{GetDerivedTypeSpec(y)};
488     return AreCompatibleDerivedTypes(
489         xdt, ydt, x.IsPolymorphic(), ignoreTypeParameterValues, false);
490   }
491 }
492 
493 // See 7.3.2.3 (5) & 15.5.2.4
494 bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const {
495   return AreCompatibleTypes(*this, that, false, true);
496 }
497 
498 bool DynamicType::IsTkCompatibleWith(
499     const DynamicType &that, common::IgnoreTKRSet ignoreTKR) const {
500   if (ignoreTKR.test(common::IgnoreTKR::Type) &&
501       (category() == TypeCategory::Derived ||
502           that.category() == TypeCategory::Derived ||
503           category() != that.category())) {
504     return true;
505   } else if (ignoreTKR.test(common::IgnoreTKR::Kind) &&
506       category() == that.category()) {
507     return true;
508   } else {
509     return AreCompatibleTypes(*this, that, false, true);
510   }
511 }
512 
513 bool DynamicType::IsTkLenCompatibleWith(const DynamicType &that) const {
514   return AreCompatibleTypes(*this, that, false, false);
515 }
516 
517 // 16.9.165
518 std::optional<bool> DynamicType::SameTypeAs(const DynamicType &that) const {
519   bool x{AreCompatibleTypes(*this, that, true, true)};
520   bool y{AreCompatibleTypes(that, *this, true, true)};
521   if (!x && !y) {
522     return false;
523   } else if (x && y && !IsPolymorphic() && !that.IsPolymorphic()) {
524     return true;
525   } else {
526     return std::nullopt;
527   }
528 }
529 
530 // 16.9.76
531 std::optional<bool> DynamicType::ExtendsTypeOf(const DynamicType &that) const {
532   if (IsUnlimitedPolymorphic() || that.IsUnlimitedPolymorphic()) {
533     return std::nullopt; // unknown
534   }
535   const auto *thisDts{evaluate::GetDerivedTypeSpec(*this)};
536   const auto *thatDts{evaluate::GetDerivedTypeSpec(that)};
537   if (!thisDts || !thatDts) {
538     return std::nullopt;
539   } else if (!AreCompatibleDerivedTypes(thatDts, thisDts, true, true, true)) {
540     // Note that I check *thisDts, not its parent, so that EXTENDS_TYPE_OF()
541     // is .true. when they are the same type.  This is technically
542     // an implementation-defined case in the standard, but every other
543     // compiler works this way.
544     if (IsPolymorphic() &&
545         AreCompatibleDerivedTypes(thisDts, thatDts, true, true, true)) {
546       // 'that' is *this or an extension of *this, and so runtime *this
547       // could be an extension of 'that'
548       return std::nullopt;
549     } else {
550       return false;
551     }
552   } else if (that.IsPolymorphic()) {
553     return std::nullopt; // unknown
554   } else {
555     return true;
556   }
557 }
558 
559 std::optional<DynamicType> DynamicType::From(
560     const semantics::DeclTypeSpec &type) {
561   if (const auto *intrinsic{type.AsIntrinsic()}) {
562     if (auto kind{ToInt64(intrinsic->kind())}) {
563       TypeCategory category{intrinsic->category()};
564       if (IsValidKindOfIntrinsicType(category, *kind)) {
565         if (category == TypeCategory::Character) {
566           const auto &charType{type.characterTypeSpec()};
567           return DynamicType{static_cast<int>(*kind), charType.length()};
568         } else {
569           return DynamicType{category, static_cast<int>(*kind)};
570         }
571       }
572     }
573   } else if (const auto *derived{type.AsDerived()}) {
574     return DynamicType{
575         *derived, type.category() == semantics::DeclTypeSpec::ClassDerived};
576   } else if (type.category() == semantics::DeclTypeSpec::ClassStar) {
577     return DynamicType::UnlimitedPolymorphic();
578   } else if (type.category() == semantics::DeclTypeSpec::TypeStar) {
579     return DynamicType::AssumedType();
580   } else {
581     common::die("DynamicType::From(DeclTypeSpec): failed");
582   }
583   return std::nullopt;
584 }
585 
586 std::optional<DynamicType> DynamicType::From(const semantics::Symbol &symbol) {
587   return From(symbol.GetType()); // Symbol -> DeclTypeSpec -> DynamicType
588 }
589 
590 DynamicType DynamicType::ResultTypeForMultiply(const DynamicType &that) const {
591   switch (category_) {
592   case TypeCategory::Integer:
593     switch (that.category_) {
594     case TypeCategory::Integer:
595       return DynamicType{TypeCategory::Integer, std::max(kind_, that.kind_)};
596     case TypeCategory::Real:
597     case TypeCategory::Complex:
598       return that;
599     default:
600       CRASH_NO_CASE;
601     }
602     break;
603   case TypeCategory::Real:
604     switch (that.category_) {
605     case TypeCategory::Integer:
606       return *this;
607     case TypeCategory::Real:
608       return DynamicType{TypeCategory::Real, std::max(kind_, that.kind_)};
609     case TypeCategory::Complex:
610       return DynamicType{TypeCategory::Complex, std::max(kind_, that.kind_)};
611     default:
612       CRASH_NO_CASE;
613     }
614     break;
615   case TypeCategory::Complex:
616     switch (that.category_) {
617     case TypeCategory::Integer:
618       return *this;
619     case TypeCategory::Real:
620     case TypeCategory::Complex:
621       return DynamicType{TypeCategory::Complex, std::max(kind_, that.kind_)};
622     default:
623       CRASH_NO_CASE;
624     }
625     break;
626   case TypeCategory::Logical:
627     switch (that.category_) {
628     case TypeCategory::Logical:
629       return DynamicType{TypeCategory::Logical, std::max(kind_, that.kind_)};
630     default:
631       CRASH_NO_CASE;
632     }
633     break;
634   default:
635     CRASH_NO_CASE;
636   }
637   return *this;
638 }
639 
640 bool DynamicType::RequiresDescriptor() const {
641   return IsPolymorphic() || IsNonConstantLengthCharacter() ||
642       (derived_ && CountNonConstantLenParameters(*derived_) > 0);
643 }
644 
645 bool DynamicType::HasDeferredTypeParameter() const {
646   if (derived_) {
647     for (const auto &pair : derived_->parameters()) {
648       if (pair.second.isDeferred()) {
649         return true;
650       }
651     }
652   }
653   return charLengthParamValue_ && charLengthParamValue_->isDeferred();
654 }
655 
656 bool SomeKind<TypeCategory::Derived>::operator==(
657     const SomeKind<TypeCategory::Derived> &that) const {
658   return PointeeComparison(derivedTypeSpec_, that.derivedTypeSpec_);
659 }
660 
661 int SelectedCharKind(const std::string &s, int defaultKind) { // 16.9.168
662   auto lower{parser::ToLowerCaseLetters(s)};
663   auto n{lower.size()};
664   while (n > 0 && lower[0] == ' ') {
665     lower.erase(0, 1);
666     --n;
667   }
668   while (n > 0 && lower[n - 1] == ' ') {
669     lower.erase(--n, 1);
670   }
671   if (lower == "ascii") {
672     return 1;
673   } else if (lower == "ucs-2") {
674     return 2;
675   } else if (lower == "iso_10646" || lower == "ucs-4") {
676     return 4;
677   } else if (lower == "default") {
678     return defaultKind;
679   } else {
680     return -1;
681   }
682 }
683 
684 std::optional<DynamicType> ComparisonType(
685     const DynamicType &t1, const DynamicType &t2) {
686   switch (t1.category()) {
687   case TypeCategory::Integer:
688     switch (t2.category()) {
689     case TypeCategory::Integer:
690       return DynamicType{TypeCategory::Integer, std::max(t1.kind(), t2.kind())};
691     case TypeCategory::Real:
692     case TypeCategory::Complex:
693       return t2;
694     default:
695       return std::nullopt;
696     }
697   case TypeCategory::Real:
698     switch (t2.category()) {
699     case TypeCategory::Integer:
700       return t1;
701     case TypeCategory::Real:
702     case TypeCategory::Complex:
703       return DynamicType{t2.category(), std::max(t1.kind(), t2.kind())};
704     default:
705       return std::nullopt;
706     }
707   case TypeCategory::Complex:
708     switch (t2.category()) {
709     case TypeCategory::Integer:
710       return t1;
711     case TypeCategory::Real:
712     case TypeCategory::Complex:
713       return DynamicType{TypeCategory::Complex, std::max(t1.kind(), t2.kind())};
714     default:
715       return std::nullopt;
716     }
717   case TypeCategory::Character:
718     switch (t2.category()) {
719     case TypeCategory::Character:
720       return DynamicType{
721           TypeCategory::Character, std::max(t1.kind(), t2.kind())};
722     default:
723       return std::nullopt;
724     }
725   case TypeCategory::Logical:
726     switch (t2.category()) {
727     case TypeCategory::Logical:
728       return DynamicType{TypeCategory::Logical, LogicalResult::kind};
729     default:
730       return std::nullopt;
731     }
732   default:
733     return std::nullopt;
734   }
735 }
736 
737 bool IsInteroperableIntrinsicType(const DynamicType &type) {
738   switch (type.category()) {
739   case TypeCategory::Integer:
740     return true;
741   case TypeCategory::Real:
742   case TypeCategory::Complex:
743     return type.kind() >= 4; // no short or half floats
744   case TypeCategory::Logical:
745     return type.kind() == 1; // C_BOOL
746   case TypeCategory::Character:
747     return type.kind() == 1 /* C_CHAR */ && type.knownLength().value_or(0) == 1;
748   default:
749     // Derived types are tested in Semantics/check-declarations.cpp
750     return false;
751   }
752 }
753 
754 } // namespace Fortran::evaluate
755