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