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