flang/lib/Evaluate/type.cpp

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