1 //===-- lib/Evaluate/type.cpp ---------------------------------------------===// 2 // 3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. 4 // See https://llvm.org/LICENSE.txt for license information. 5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 6 // 7 //===----------------------------------------------------------------------===// 8 9 #include "flang/Evaluate/type.h" 10 #include "flang/Common/idioms.h" 11 #include "flang/Evaluate/expression.h" 12 #include "flang/Evaluate/fold.h" 13 #include "flang/Evaluate/target.h" 14 #include "flang/Parser/characters.h" 15 #include "flang/Semantics/scope.h" 16 #include "flang/Semantics/symbol.h" 17 #include "flang/Semantics/tools.h" 18 #include "flang/Semantics/type.h" 19 #include <algorithm> 20 #include <optional> 21 #include <string> 22 23 // IsDescriptor() predicate: true when a symbol is implemented 24 // at runtime with a descriptor. 25 namespace Fortran::semantics { 26 27 static bool IsDescriptor(const DeclTypeSpec *type) { 28 if (type) { 29 if (auto dynamicType{evaluate::DynamicType::From(*type)}) { 30 return dynamicType->RequiresDescriptor(); 31 } 32 } 33 return false; 34 } 35 36 static bool IsDescriptor(const ObjectEntityDetails &details) { 37 if (IsDescriptor(details.type())) { 38 return true; 39 } 40 for (const ShapeSpec &shapeSpec : details.shape()) { 41 const auto &lb{shapeSpec.lbound().GetExplicit()}; 42 const auto &ub{shapeSpec.ubound().GetExplicit()}; 43 if (!lb || !ub || !IsConstantExpr(*lb) || !IsConstantExpr(*ub)) { 44 return true; 45 } 46 } 47 return false; 48 } 49 50 static bool IsDescriptor(const ProcEntityDetails &details) { 51 // A procedure pointer or dummy procedure must be & is a descriptor if 52 // and only if it requires a static link. 53 // TODO: refine this placeholder 54 return details.HasExplicitInterface(); 55 } 56 57 bool IsDescriptor(const Symbol &symbol) { 58 return common::visit( 59 common::visitors{ 60 [&](const ObjectEntityDetails &d) { 61 return IsAllocatableOrPointer(symbol) || IsDescriptor(d); 62 }, 63 [&](const ProcEntityDetails &d) { 64 return (symbol.attrs().test(Attr::POINTER) || 65 symbol.attrs().test(Attr::EXTERNAL)) && 66 IsDescriptor(d); 67 }, 68 [&](const EntityDetails &d) { return IsDescriptor(d.type()); }, 69 [](const AssocEntityDetails &d) { 70 if (const auto &expr{d.expr()}) { 71 if (expr->Rank() > 0) { 72 return true; 73 } 74 if (const auto dynamicType{expr->GetType()}) { 75 if (dynamicType->RequiresDescriptor()) { 76 return true; 77 } 78 } 79 } 80 return false; 81 }, 82 [](const SubprogramDetails &d) { 83 return d.isFunction() && IsDescriptor(d.result()); 84 }, 85 [](const UseDetails &d) { return IsDescriptor(d.symbol()); }, 86 [](const HostAssocDetails &d) { return IsDescriptor(d.symbol()); }, 87 [](const auto &) { return false; }, 88 }, 89 symbol.details()); 90 } 91 } // namespace Fortran::semantics 92 93 namespace Fortran::evaluate { 94 95 DynamicType::DynamicType(int k, const semantics::ParamValue &pv) 96 : category_{TypeCategory::Character}, kind_{k} { 97 CHECK(IsValidKindOfIntrinsicType(category_, kind_)); 98 if (auto n{ToInt64(pv.GetExplicit())}) { 99 knownLength_ = *n > 0 ? *n : 0; 100 } else { 101 charLengthParamValue_ = &pv; 102 } 103 } 104 105 template <typename A> inline bool PointeeComparison(const A *x, const A *y) { 106 return x == y || (x && y && *x == *y); 107 } 108 109 bool DynamicType::operator==(const DynamicType &that) const { 110 return category_ == that.category_ && kind_ == that.kind_ && 111 PointeeComparison(charLengthParamValue_, that.charLengthParamValue_) && 112 knownLength().has_value() == that.knownLength().has_value() && 113 (!knownLength() || *knownLength() == *that.knownLength()) && 114 PointeeComparison(derived_, that.derived_); 115 } 116 117 std::optional<Expr<SubscriptInteger>> DynamicType::GetCharLength() const { 118 if (category_ == TypeCategory::Character) { 119 if (knownLength()) { 120 return AsExpr(Constant<SubscriptInteger>(*knownLength())); 121 } else if (charLengthParamValue_) { 122 if (auto length{charLengthParamValue_->GetExplicit()}) { 123 return ConvertToType<SubscriptInteger>(std::move(*length)); 124 } 125 } 126 } 127 return std::nullopt; 128 } 129 130 std::size_t DynamicType::GetAlignment( 131 const TargetCharacteristics &targetCharacteristics) const { 132 if (category_ == TypeCategory::Derived) { 133 if (derived_ && derived_->scope()) { 134 return derived_->scope()->alignment().value_or(1); 135 } 136 } else { 137 return targetCharacteristics.GetAlignment(category_, kind_); 138 } 139 return 1; // needs to be after switch to dodge a bogus gcc warning 140 } 141 142 std::optional<Expr<SubscriptInteger>> DynamicType::MeasureSizeInBytes( 143 FoldingContext &context, bool aligned, 144 std::optional<std::int64_t> charLength) const { 145 switch (category_) { 146 case TypeCategory::Integer: 147 case TypeCategory::Real: 148 case TypeCategory::Complex: 149 case TypeCategory::Logical: 150 return Expr<SubscriptInteger>{ 151 context.targetCharacteristics().GetByteSize(category_, kind_)}; 152 case TypeCategory::Character: 153 if (auto len{charLength ? Expr<SubscriptInteger>{Constant<SubscriptInteger>{ 154 *charLength}} 155 : GetCharLength()}) { 156 return Fold(context, 157 Expr<SubscriptInteger>{ 158 context.targetCharacteristics().GetByteSize(category_, kind_)} * 159 std::move(*len)); 160 } 161 break; 162 case TypeCategory::Derived: 163 if (!IsPolymorphic() && derived_ && derived_->scope()) { 164 auto size{derived_->scope()->size()}; 165 auto align{aligned ? derived_->scope()->alignment().value_or(0) : 0}; 166 auto alignedSize{align > 0 ? ((size + align - 1) / align) * align : size}; 167 return Expr<SubscriptInteger>{ 168 static_cast<ConstantSubscript>(alignedSize)}; 169 } 170 break; 171 } 172 return std::nullopt; 173 } 174 175 bool DynamicType::IsAssumedLengthCharacter() const { 176 return category_ == TypeCategory::Character && charLengthParamValue_ && 177 charLengthParamValue_->isAssumed(); 178 } 179 180 bool DynamicType::IsNonConstantLengthCharacter() const { 181 if (category_ != TypeCategory::Character) { 182 return false; 183 } else if (knownLength()) { 184 return false; 185 } else if (!charLengthParamValue_) { 186 return true; 187 } else if (const auto &expr{charLengthParamValue_->GetExplicit()}) { 188 return !IsConstantExpr(*expr); 189 } else { 190 return true; 191 } 192 } 193 194 bool DynamicType::IsTypelessIntrinsicArgument() const { 195 return category_ == TypeCategory::Integer && kind_ == TypelessKind; 196 } 197 198 const semantics::DerivedTypeSpec *GetDerivedTypeSpec( 199 const std::optional<DynamicType> &type) { 200 return type ? GetDerivedTypeSpec(*type) : nullptr; 201 } 202 203 const semantics::DerivedTypeSpec *GetDerivedTypeSpec(const DynamicType &type) { 204 if (type.category() == TypeCategory::Derived && 205 !type.IsUnlimitedPolymorphic()) { 206 return &type.GetDerivedTypeSpec(); 207 } else { 208 return nullptr; 209 } 210 } 211 212 static const semantics::Symbol *FindParentComponent( 213 const semantics::DerivedTypeSpec &derived) { 214 const semantics::Symbol &typeSymbol{derived.typeSymbol()}; 215 const semantics::Scope *scope{derived.scope()}; 216 if (!scope) { 217 scope = typeSymbol.scope(); 218 } 219 if (scope) { 220 const auto &dtDetails{typeSymbol.get<semantics::DerivedTypeDetails>()}; 221 // TODO: Combine with semantics::DerivedTypeDetails::GetParentComponent 222 if (auto extends{dtDetails.GetParentComponentName()}) { 223 if (auto iter{scope->find(*extends)}; iter != scope->cend()) { 224 if (const semantics::Symbol & symbol{*iter->second}; 225 symbol.test(semantics::Symbol::Flag::ParentComp)) { 226 return &symbol; 227 } 228 } 229 } 230 } 231 return nullptr; 232 } 233 234 const semantics::DerivedTypeSpec *GetParentTypeSpec( 235 const semantics::DerivedTypeSpec &derived) { 236 if (const semantics::Symbol * parent{FindParentComponent(derived)}) { 237 return &parent->get<semantics::ObjectEntityDetails>() 238 .type() 239 ->derivedTypeSpec(); 240 } else { 241 return nullptr; 242 } 243 } 244 245 // Compares two derived type representations to see whether they both 246 // represent the "same type" in the sense of section 7.5.2.4. 247 using SetOfDerivedTypePairs = 248 std::set<std::pair<const semantics::DerivedTypeSpec *, 249 const semantics::DerivedTypeSpec *>>; 250 251 static bool AreSameComponent(const semantics::Symbol &x, 252 const semantics::Symbol &y, 253 SetOfDerivedTypePairs & /* inProgress - not yet used */) { 254 if (x.attrs() != y.attrs()) { 255 return false; 256 } 257 if (x.attrs().test(semantics::Attr::PRIVATE)) { 258 return false; 259 } 260 // TODO: compare types, parameters, bounds, &c. 261 return x.has<semantics::ObjectEntityDetails>() == 262 y.has<semantics::ObjectEntityDetails>(); 263 } 264 265 static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x, 266 const semantics::DerivedTypeSpec &y, SetOfDerivedTypePairs &inProgress) { 267 const auto &xSymbol{x.typeSymbol()}; 268 const auto &ySymbol{y.typeSymbol()}; 269 if (&x == &y || xSymbol == ySymbol) { 270 return true; 271 } 272 auto thisQuery{std::make_pair(&x, &y)}; 273 if (inProgress.find(thisQuery) != inProgress.end()) { 274 return true; // recursive use of types in components 275 } 276 inProgress.insert(thisQuery); 277 const auto &xDetails{xSymbol.get<semantics::DerivedTypeDetails>()}; 278 const auto &yDetails{ySymbol.get<semantics::DerivedTypeDetails>()}; 279 if (xSymbol.name() != ySymbol.name()) { 280 return false; 281 } 282 if (!(xDetails.sequence() && yDetails.sequence()) && 283 !(xSymbol.attrs().test(semantics::Attr::BIND_C) && 284 ySymbol.attrs().test(semantics::Attr::BIND_C))) { 285 // PGI does not enforce this requirement; all other Fortran 286 // processors do with a hard error when violations are caught. 287 return false; 288 } 289 // Compare the component lists in their orders of declaration. 290 auto xEnd{xDetails.componentNames().cend()}; 291 auto yComponentName{yDetails.componentNames().cbegin()}; 292 auto yEnd{yDetails.componentNames().cend()}; 293 for (auto xComponentName{xDetails.componentNames().cbegin()}; 294 xComponentName != xEnd; ++xComponentName, ++yComponentName) { 295 if (yComponentName == yEnd || *xComponentName != *yComponentName || 296 !xSymbol.scope() || !ySymbol.scope()) { 297 return false; 298 } 299 const auto xLookup{xSymbol.scope()->find(*xComponentName)}; 300 const auto yLookup{ySymbol.scope()->find(*yComponentName)}; 301 if (xLookup == xSymbol.scope()->end() || 302 yLookup == ySymbol.scope()->end() || 303 !AreSameComponent(*xLookup->second, *yLookup->second, inProgress)) { 304 return false; 305 } 306 } 307 return yComponentName == yEnd; 308 } 309 310 bool AreSameDerivedType( 311 const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) { 312 SetOfDerivedTypePairs inProgress; 313 return AreSameDerivedType(x, y, inProgress); 314 } 315 316 static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x, 317 const semantics::DerivedTypeSpec *y, bool isPolymorphic) { 318 if (!x || !y) { 319 return false; 320 } else { 321 if (AreSameDerivedType(*x, *y)) { 322 return true; 323 } else { 324 return isPolymorphic && 325 AreCompatibleDerivedTypes(x, GetParentTypeSpec(*y), true); 326 } 327 } 328 } 329 330 static bool AreCompatibleTypes(const DynamicType &x, const DynamicType &y, 331 bool ignoreTypeParameterValues, bool ignoreLengths) { 332 if (x.IsUnlimitedPolymorphic()) { 333 return true; 334 } else if (y.IsUnlimitedPolymorphic()) { 335 return false; 336 } else if (x.category() != y.category()) { 337 return false; 338 } else if (x.category() == TypeCategory::Character) { 339 const auto xLen{x.knownLength()}; 340 const auto yLen{y.knownLength()}; 341 return x.kind() == y.kind() && 342 (ignoreLengths || !xLen || !yLen || *xLen == *yLen); 343 } else if (x.category() != TypeCategory::Derived) { 344 return x.kind() == y.kind(); 345 } else { 346 const auto *xdt{GetDerivedTypeSpec(x)}; 347 const auto *ydt{GetDerivedTypeSpec(y)}; 348 return AreCompatibleDerivedTypes(xdt, ydt, x.IsPolymorphic()) && 349 (ignoreTypeParameterValues || 350 (xdt && ydt && AreTypeParamCompatible(*xdt, *ydt))); 351 } 352 } 353 354 // See 7.3.2.3 (5) & 15.5.2.4 355 bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const { 356 return AreCompatibleTypes(*this, that, false, true); 357 } 358 359 bool DynamicType::IsTkLenCompatibleWith(const DynamicType &that) const { 360 return AreCompatibleTypes(*this, that, false, false); 361 } 362 363 // 16.9.165 364 std::optional<bool> DynamicType::SameTypeAs(const DynamicType &that) const { 365 bool x{AreCompatibleTypes(*this, that, true, true)}; 366 bool y{AreCompatibleTypes(that, *this, true, true)}; 367 if (!x && !y) { 368 return false; 369 } else if (x && y && !IsPolymorphic() && !that.IsPolymorphic()) { 370 return true; 371 } else { 372 return std::nullopt; 373 } 374 } 375 376 // 16.9.76 377 std::optional<bool> DynamicType::ExtendsTypeOf(const DynamicType &that) const { 378 if (IsUnlimitedPolymorphic() || that.IsUnlimitedPolymorphic()) { 379 return std::nullopt; // unknown 380 } 381 const auto *thisDts{evaluate::GetDerivedTypeSpec(*this)}; 382 const auto *thatDts{evaluate::GetDerivedTypeSpec(that)}; 383 if (!thisDts || !thatDts) { 384 return std::nullopt; 385 } else if (!AreCompatibleDerivedTypes(thatDts, thisDts, true)) { 386 // Note that I check *thisDts, not its parent, so that EXTENDS_TYPE_OF() 387 // is .true. when they are the same type. This is technically 388 // an implementation-defined case in the standard, but every other 389 // compiler works this way. 390 if (IsPolymorphic() && AreCompatibleDerivedTypes(thisDts, thatDts, true)) { 391 // 'that' is *this or an extension of *this, and so runtime *this 392 // could be an extension of 'that' 393 return std::nullopt; 394 } else { 395 return false; 396 } 397 } else if (that.IsPolymorphic()) { 398 return std::nullopt; // unknown 399 } else { 400 return true; 401 } 402 } 403 404 std::optional<DynamicType> DynamicType::From( 405 const semantics::DeclTypeSpec &type) { 406 if (const auto *intrinsic{type.AsIntrinsic()}) { 407 if (auto kind{ToInt64(intrinsic->kind())}) { 408 TypeCategory category{intrinsic->category()}; 409 if (IsValidKindOfIntrinsicType(category, *kind)) { 410 if (category == TypeCategory::Character) { 411 const auto &charType{type.characterTypeSpec()}; 412 return DynamicType{static_cast<int>(*kind), charType.length()}; 413 } else { 414 return DynamicType{category, static_cast<int>(*kind)}; 415 } 416 } 417 } 418 } else if (const auto *derived{type.AsDerived()}) { 419 return DynamicType{ 420 *derived, type.category() == semantics::DeclTypeSpec::ClassDerived}; 421 } else if (type.category() == semantics::DeclTypeSpec::ClassStar) { 422 return DynamicType::UnlimitedPolymorphic(); 423 } else if (type.category() == semantics::DeclTypeSpec::TypeStar) { 424 return DynamicType::AssumedType(); 425 } else { 426 common::die("DynamicType::From(DeclTypeSpec): failed"); 427 } 428 return std::nullopt; 429 } 430 431 std::optional<DynamicType> DynamicType::From(const semantics::Symbol &symbol) { 432 return From(symbol.GetType()); // Symbol -> DeclTypeSpec -> DynamicType 433 } 434 435 DynamicType DynamicType::ResultTypeForMultiply(const DynamicType &that) const { 436 switch (category_) { 437 case TypeCategory::Integer: 438 switch (that.category_) { 439 case TypeCategory::Integer: 440 return DynamicType{TypeCategory::Integer, std::max(kind_, that.kind_)}; 441 case TypeCategory::Real: 442 case TypeCategory::Complex: 443 return that; 444 default: 445 CRASH_NO_CASE; 446 } 447 break; 448 case TypeCategory::Real: 449 switch (that.category_) { 450 case TypeCategory::Integer: 451 return *this; 452 case TypeCategory::Real: 453 return DynamicType{TypeCategory::Real, std::max(kind_, that.kind_)}; 454 case TypeCategory::Complex: 455 return DynamicType{TypeCategory::Complex, std::max(kind_, that.kind_)}; 456 default: 457 CRASH_NO_CASE; 458 } 459 break; 460 case TypeCategory::Complex: 461 switch (that.category_) { 462 case TypeCategory::Integer: 463 return *this; 464 case TypeCategory::Real: 465 case TypeCategory::Complex: 466 return DynamicType{TypeCategory::Complex, std::max(kind_, that.kind_)}; 467 default: 468 CRASH_NO_CASE; 469 } 470 break; 471 case TypeCategory::Logical: 472 switch (that.category_) { 473 case TypeCategory::Logical: 474 return DynamicType{TypeCategory::Logical, std::max(kind_, that.kind_)}; 475 default: 476 CRASH_NO_CASE; 477 } 478 break; 479 default: 480 CRASH_NO_CASE; 481 } 482 return *this; 483 } 484 485 bool DynamicType::RequiresDescriptor() const { 486 return IsPolymorphic() || IsNonConstantLengthCharacter() || 487 (derived_ && CountNonConstantLenParameters(*derived_) > 0); 488 } 489 490 bool DynamicType::HasDeferredTypeParameter() const { 491 if (derived_) { 492 for (const auto &pair : derived_->parameters()) { 493 if (pair.second.isDeferred()) { 494 return true; 495 } 496 } 497 } 498 return charLengthParamValue_ && charLengthParamValue_->isDeferred(); 499 } 500 501 bool SomeKind<TypeCategory::Derived>::operator==( 502 const SomeKind<TypeCategory::Derived> &that) const { 503 return PointeeComparison(derivedTypeSpec_, that.derivedTypeSpec_); 504 } 505 506 int SelectedCharKind(const std::string &s, int defaultKind) { // 16.9.168 507 auto lower{parser::ToLowerCaseLetters(s)}; 508 auto n{lower.size()}; 509 while (n > 0 && lower[0] == ' ') { 510 lower.erase(0, 1); 511 --n; 512 } 513 while (n > 0 && lower[n - 1] == ' ') { 514 lower.erase(--n, 1); 515 } 516 if (lower == "ascii") { 517 return 1; 518 } else if (lower == "ucs-2") { 519 return 2; 520 } else if (lower == "iso_10646" || lower == "ucs-4") { 521 return 4; 522 } else if (lower == "default") { 523 return defaultKind; 524 } else { 525 return -1; 526 } 527 } 528 529 std::optional<DynamicType> ComparisonType( 530 const DynamicType &t1, const DynamicType &t2) { 531 switch (t1.category()) { 532 case TypeCategory::Integer: 533 switch (t2.category()) { 534 case TypeCategory::Integer: 535 return DynamicType{TypeCategory::Integer, std::max(t1.kind(), t2.kind())}; 536 case TypeCategory::Real: 537 case TypeCategory::Complex: 538 return t2; 539 default: 540 return std::nullopt; 541 } 542 case TypeCategory::Real: 543 switch (t2.category()) { 544 case TypeCategory::Integer: 545 return t1; 546 case TypeCategory::Real: 547 case TypeCategory::Complex: 548 return DynamicType{t2.category(), std::max(t1.kind(), t2.kind())}; 549 default: 550 return std::nullopt; 551 } 552 case TypeCategory::Complex: 553 switch (t2.category()) { 554 case TypeCategory::Integer: 555 return t1; 556 case TypeCategory::Real: 557 case TypeCategory::Complex: 558 return DynamicType{TypeCategory::Complex, std::max(t1.kind(), t2.kind())}; 559 default: 560 return std::nullopt; 561 } 562 case TypeCategory::Character: 563 switch (t2.category()) { 564 case TypeCategory::Character: 565 return DynamicType{ 566 TypeCategory::Character, std::max(t1.kind(), t2.kind())}; 567 default: 568 return std::nullopt; 569 } 570 case TypeCategory::Logical: 571 switch (t2.category()) { 572 case TypeCategory::Logical: 573 return DynamicType{TypeCategory::Logical, LogicalResult::kind}; 574 default: 575 return std::nullopt; 576 } 577 default: 578 return std::nullopt; 579 } 580 } 581 582 bool IsInteroperableIntrinsicType(const DynamicType &type) { 583 switch (type.category()) { 584 case TypeCategory::Integer: 585 return true; 586 case TypeCategory::Real: 587 case TypeCategory::Complex: 588 return type.kind() >= 4; // no short or half floats 589 case TypeCategory::Logical: 590 return type.kind() == 1; // C_BOOL 591 case TypeCategory::Character: 592 return type.kind() == 1 /* C_CHAR */ && type.knownLength().value_or(0) == 1; 593 default: 594 // Derived types are tested in Semantics/check-declarations.cpp 595 return false; 596 } 597 } 598 599 } // namespace Fortran::evaluate 600