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())) {
  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) const {
 144   switch (category_) {
 145   case TypeCategory::Integer:
 146   case TypeCategory::Real:
 147   case TypeCategory::Complex:
 148   case TypeCategory::Logical:
 149     return Expr<SubscriptInteger>{
 150         context.targetCharacteristics().GetByteSize(category_, kind_)};
 151   case TypeCategory::Character:
 152     if (auto len{GetCharLength()}) {
 153       return Fold(context,
 154           Expr<SubscriptInteger>{
 155               context.targetCharacteristics().GetByteSize(category_, kind_)} *
 156               std::move(*len));
 157     }
 158     break;
 159   case TypeCategory::Derived:
 160     if (!IsPolymorphic() && derived_ && derived_->scope()) {
 161       auto size{derived_->scope()->size()};
 162       auto align{aligned ? derived_->scope()->alignment().value_or(0) : 0};
 163       auto alignedSize{align > 0 ? ((size + align - 1) / align) * align : size};
 164       return Expr<SubscriptInteger>{
 165           static_cast<ConstantSubscript>(alignedSize)};
 166     }
 167     break;
 168   }
 169   return std::nullopt;
 170 }
 171
 172 bool DynamicType::IsAssumedLengthCharacter() const {
 173   return category_ == TypeCategory::Character && charLengthParamValue_ &&
 174       charLengthParamValue_->isAssumed();
 175 }
 176
 177 bool DynamicType::IsNonConstantLengthCharacter() const {
 178   if (category_ != TypeCategory::Character) {
 179     return false;
 180   } else if (knownLength()) {
 181     return false;
 182   } else if (!charLengthParamValue_) {
 183     return true;
 184   } else if (const auto &expr{charLengthParamValue_->GetExplicit()}) {
 185     return !IsConstantExpr(*expr);
 186   } else {
 187     return true;
 188   }
 189 }
 190
 191 bool DynamicType::IsTypelessIntrinsicArgument() const {
 192   return category_ == TypeCategory::Integer && kind_ == TypelessKind;
 193 }
 194
 195 const semantics::DerivedTypeSpec *GetDerivedTypeSpec(
 196     const std::optional<DynamicType> &type) {
 197   return type ? GetDerivedTypeSpec(*type) : nullptr;
 198 }
 199
 200 const semantics::DerivedTypeSpec *GetDerivedTypeSpec(const DynamicType &type) {
 201   if (type.category() == TypeCategory::Derived &&
 202       !type.IsUnlimitedPolymorphic()) {
 203     return &type.GetDerivedTypeSpec();
 204   } else {
 205     return nullptr;
 206   }
 207 }
 208
 209 static const semantics::Symbol *FindParentComponent(
 210     const semantics::DerivedTypeSpec &derived) {
 211   const semantics::Symbol &typeSymbol{derived.typeSymbol()};
 212   const semantics::Scope *scope{derived.scope()};
 213   if (!scope) {
 214     scope = typeSymbol.scope();
 215   }
 216   if (scope) {
 217     const auto &dtDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
 218     // TODO: Combine with semantics::DerivedTypeDetails::GetParentComponent
 219     if (auto extends{dtDetails.GetParentComponentName()}) {
 220       if (auto iter{scope->find(*extends)}; iter != scope->cend()) {
 221         if (const semantics::Symbol & symbol{*iter->second};
 222             symbol.test(semantics::Symbol::Flag::ParentComp)) {
 223           return &symbol;
 224         }
 225       }
 226     }
 227   }
 228   return nullptr;
 229 }
 230
 231 const semantics::DerivedTypeSpec *GetParentTypeSpec(
 232     const semantics::DerivedTypeSpec &derived) {
 233   if (const semantics::Symbol * parent{FindParentComponent(derived)}) {
 234     return &parent->get<semantics::ObjectEntityDetails>()
 235                 .type()
 236                 ->derivedTypeSpec();
 237   } else {
 238     return nullptr;
 239   }
 240 }
 241
 242 // Compares two derived type representations to see whether they both
 243 // represent the "same type" in the sense of section 7.5.2.4.
 244 using SetOfDerivedTypePairs =
 245     std::set<std::pair<const semantics::DerivedTypeSpec *,
 246         const semantics::DerivedTypeSpec *>>;
 247
 248 static bool AreSameComponent(const semantics::Symbol &x,
 249     const semantics::Symbol &y,
 250     SetOfDerivedTypePairs & /* inProgress - not yet used */) {
 251   if (x.attrs() != y.attrs()) {
 252     return false;
 253   }
 254   if (x.attrs().test(semantics::Attr::PRIVATE)) {
 255     return false;
 256   }
 257   // TODO: compare types, parameters, bounds, &c.
 258   return x.has<semantics::ObjectEntityDetails>() ==
 259       y.has<semantics::ObjectEntityDetails>();
 260 }
 261
 262 static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
 263     const semantics::DerivedTypeSpec &y, SetOfDerivedTypePairs &inProgress) {
 264   const auto &xSymbol{x.typeSymbol()};
 265   const auto &ySymbol{y.typeSymbol()};
 266   if (&x == &y || xSymbol == ySymbol) {
 267     return true;
 268   }
 269   auto thisQuery{std::make_pair(&x, &y)};
 270   if (inProgress.find(thisQuery) != inProgress.end()) {
 271     return true; // recursive use of types in components
 272   }
 273   inProgress.insert(thisQuery);
 274   const auto &xDetails{xSymbol.get<semantics::DerivedTypeDetails>()};
 275   const auto &yDetails{ySymbol.get<semantics::DerivedTypeDetails>()};
 276   if (xSymbol.name() != ySymbol.name()) {
 277     return false;
 278   }
 279   if (!(xDetails.sequence() && yDetails.sequence()) &&
 280       !(xSymbol.attrs().test(semantics::Attr::BIND_C) &&
 281           ySymbol.attrs().test(semantics::Attr::BIND_C))) {
 282     // PGI does not enforce this requirement; all other Fortran
 283     // processors do with a hard error when violations are caught.
 284     return false;
 285   }
 286   // Compare the component lists in their orders of declaration.
 287   auto xEnd{xDetails.componentNames().cend()};
 288   auto yComponentName{yDetails.componentNames().cbegin()};
 289   auto yEnd{yDetails.componentNames().cend()};
 290   for (auto xComponentName{xDetails.componentNames().cbegin()};
 291        xComponentName != xEnd; ++xComponentName, ++yComponentName) {
 292     if (yComponentName == yEnd || *xComponentName != *yComponentName ||
 293         !xSymbol.scope() || !ySymbol.scope()) {
 294       return false;
 295     }
 296     const auto xLookup{xSymbol.scope()->find(*xComponentName)};
 297     const auto yLookup{ySymbol.scope()->find(*yComponentName)};
 298     if (xLookup == xSymbol.scope()->end() ||
 299         yLookup == ySymbol.scope()->end() ||
 300         !AreSameComponent(*xLookup->second, *yLookup->second, inProgress)) {
 301       return false;
 302     }
 303   }
 304   return yComponentName == yEnd;
 305 }
 306
 307 bool AreSameDerivedType(
 308     const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
 309   SetOfDerivedTypePairs inProgress;
 310   return AreSameDerivedType(x, y, inProgress);
 311 }
 312
 313 static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
 314     const semantics::DerivedTypeSpec *y, bool isPolymorphic) {
 315   if (!x || !y) {
 316     return false;
 317   } else {
 318     if (AreSameDerivedType(*x, *y)) {
 319       return true;
 320     } else {
 321       return isPolymorphic &&
 322           AreCompatibleDerivedTypes(x, GetParentTypeSpec(*y), true);
 323     }
 324   }
 325 }
 326
 327 static bool AreCompatibleTypes(const DynamicType &x, const DynamicType &y,
 328     bool ignoreTypeParameterValues, bool ignoreLengths) {
 329   if (x.IsUnlimitedPolymorphic()) {
 330     return true;
 331   } else if (y.IsUnlimitedPolymorphic()) {
 332     return false;
 333   } else if (x.category() != y.category()) {
 334     return false;
 335   } else if (x.category() == TypeCategory::Character) {
 336     const auto xLen{x.knownLength()};
 337     const auto yLen{y.knownLength()};
 338     return x.kind() == y.kind() &&
 339         (ignoreLengths || !xLen || !yLen || *xLen == *yLen);
 340   } else if (x.category() != TypeCategory::Derived) {
 341     return x.kind() == y.kind();
 342   } else {
 343     const auto *xdt{GetDerivedTypeSpec(x)};
 344     const auto *ydt{GetDerivedTypeSpec(y)};
 345     return AreCompatibleDerivedTypes(xdt, ydt, x.IsPolymorphic()) &&
 346         (ignoreTypeParameterValues ||
 347             (xdt && ydt && AreTypeParamCompatible(*xdt, *ydt)));
 348   }
 349 }
 350
 351 // See 7.3.2.3 (5) & 15.5.2.4
 352 bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const {
 353   return AreCompatibleTypes(*this, that, false, true);
 354 }
 355
 356 bool DynamicType::IsTkLenCompatibleWith(const DynamicType &that) const {
 357   return AreCompatibleTypes(*this, that, false, false);
 358 }
 359
 360 // 16.9.165
 361 std::optional<bool> DynamicType::SameTypeAs(const DynamicType &that) const {
 362   bool x{AreCompatibleTypes(*this, that, true, true)};
 363   bool y{AreCompatibleTypes(that, *this, true, true)};
 364   if (!x && !y) {
 365     return false;
 366   } else if (x && y && !IsPolymorphic() && !that.IsPolymorphic()) {
 367     return true;
 368   } else {
 369     return std::nullopt;
 370   }
 371 }
 372
 373 // 16.9.76
 374 std::optional<bool> DynamicType::ExtendsTypeOf(const DynamicType &that) const {
 375   if (IsUnlimitedPolymorphic() || that.IsUnlimitedPolymorphic()) {
 376     return std::nullopt; // unknown
 377   }
 378   const auto *thisDts{evaluate::GetDerivedTypeSpec(*this)};
 379   const auto *thatDts{evaluate::GetDerivedTypeSpec(that)};
 380   if (!thisDts || !thatDts) {
 381     return std::nullopt;
 382   } else if (!AreCompatibleDerivedTypes(thatDts, thisDts, true)) {
 383     // Note that I check *thisDts, not its parent, so that EXTENDS_TYPE_OF()
 384     // is .true. when they are the same type.  This is technically
 385     // an implementation-defined case in the standard, but every other
 386     // compiler works this way.
 387     if (IsPolymorphic() && AreCompatibleDerivedTypes(thisDts, thatDts, true)) {
 388       // 'that' is *this or an extension of *this, and so runtime *this
 389       // could be an extension of 'that'
 390       return std::nullopt;
 391     } else {
 392       return false;
 393     }
 394   } else if (that.IsPolymorphic()) {
 395     return std::nullopt; // unknown
 396   } else {
 397     return true;
 398   }
 399 }
 400
 401 std::optional<DynamicType> DynamicType::From(
 402     const semantics::DeclTypeSpec &type) {
 403   if (const auto *intrinsic{type.AsIntrinsic()}) {
 404     if (auto kind{ToInt64(intrinsic->kind())}) {
 405       TypeCategory category{intrinsic->category()};
 406       if (IsValidKindOfIntrinsicType(category, *kind)) {
 407         if (category == TypeCategory::Character) {
 408           const auto &charType{type.characterTypeSpec()};
 409           return DynamicType{static_cast<int>(*kind), charType.length()};
 410         } else {
 411           return DynamicType{category, static_cast<int>(*kind)};
 412         }
 413       }
 414     }
 415   } else if (const auto *derived{type.AsDerived()}) {
 416     return DynamicType{
 417         *derived, type.category() == semantics::DeclTypeSpec::ClassDerived};
 418   } else if (type.category() == semantics::DeclTypeSpec::ClassStar) {
 419     return DynamicType::UnlimitedPolymorphic();
 420   } else if (type.category() == semantics::DeclTypeSpec::TypeStar) {
 421     return DynamicType::AssumedType();
 422   } else {
 423     common::die("DynamicType::From(DeclTypeSpec): failed");
 424   }
 425   return std::nullopt;
 426 }
 427
 428 std::optional<DynamicType> DynamicType::From(const semantics::Symbol &symbol) {
 429   return From(symbol.GetType()); // Symbol -> DeclTypeSpec -> DynamicType
 430 }
 431
 432 DynamicType DynamicType::ResultTypeForMultiply(const DynamicType &that) const {
 433   switch (category_) {
 434   case TypeCategory::Integer:
 435     switch (that.category_) {
 436     case TypeCategory::Integer:
 437       return DynamicType{TypeCategory::Integer, std::max(kind_, that.kind_)};
 438     case TypeCategory::Real:
 439     case TypeCategory::Complex:
 440       return that;
 441     default:
 442       CRASH_NO_CASE;
 443     }
 444     break;
 445   case TypeCategory::Real:
 446     switch (that.category_) {
 447     case TypeCategory::Integer:
 448       return *this;
 449     case TypeCategory::Real:
 450       return DynamicType{TypeCategory::Real, std::max(kind_, that.kind_)};
 451     case TypeCategory::Complex:
 452       return DynamicType{TypeCategory::Complex, std::max(kind_, that.kind_)};
 453     default:
 454       CRASH_NO_CASE;
 455     }
 456     break;
 457   case TypeCategory::Complex:
 458     switch (that.category_) {
 459     case TypeCategory::Integer:
 460       return *this;
 461     case TypeCategory::Real:
 462     case TypeCategory::Complex:
 463       return DynamicType{TypeCategory::Complex, std::max(kind_, that.kind_)};
 464     default:
 465       CRASH_NO_CASE;
 466     }
 467     break;
 468   case TypeCategory::Logical:
 469     switch (that.category_) {
 470     case TypeCategory::Logical:
 471       return DynamicType{TypeCategory::Logical, std::max(kind_, that.kind_)};
 472     default:
 473       CRASH_NO_CASE;
 474     }
 475     break;
 476   default:
 477     CRASH_NO_CASE;
 478   }
 479   return *this;
 480 }
 481
 482 bool DynamicType::RequiresDescriptor() const {
 483   return IsPolymorphic() || IsNonConstantLengthCharacter() ||
 484       (derived_ && CountNonConstantLenParameters(*derived_) > 0);
 485 }
 486
 487 bool DynamicType::HasDeferredTypeParameter() const {
 488   if (derived_) {
 489     for (const auto &pair : derived_->parameters()) {
 490       if (pair.second.isDeferred()) {
 491         return true;
 492       }
 493     }
 494   }
 495   return charLengthParamValue_ && charLengthParamValue_->isDeferred();
 496 }
 497
 498 bool SomeKind<TypeCategory::Derived>::operator==(
 499     const SomeKind<TypeCategory::Derived> &that) const {
 500   return PointeeComparison(derivedTypeSpec_, that.derivedTypeSpec_);
 501 }
 502
 503 int SelectedCharKind(const std::string &s, int defaultKind) { // 16.9.168
 504   auto lower{parser::ToLowerCaseLetters(s)};
 505   auto n{lower.size()};
 506   while (n > 0 && lower[0] == ' ') {
 507     lower.erase(0, 1);
 508     --n;
 509   }
 510   while (n > 0 && lower[n - 1] == ' ') {
 511     lower.erase(--n, 1);
 512   }
 513   if (lower == "ascii") {
 514     return 1;
 515   } else if (lower == "ucs-2") {
 516     return 2;
 517   } else if (lower == "iso_10646" || lower == "ucs-4") {
 518     return 4;
 519   } else if (lower == "default") {
 520     return defaultKind;
 521   } else {
 522     return -1;
 523   }
 524 }
 525
 526 std::optional<DynamicType> ComparisonType(
 527     const DynamicType &t1, const DynamicType &t2) {
 528   switch (t1.category()) {
 529   case TypeCategory::Integer:
 530     switch (t2.category()) {
 531     case TypeCategory::Integer:
 532       return DynamicType{TypeCategory::Integer, std::max(t1.kind(), t2.kind())};
 533     case TypeCategory::Real:
 534     case TypeCategory::Complex:
 535       return t2;
 536     default:
 537       return std::nullopt;
 538     }
 539   case TypeCategory::Real:
 540     switch (t2.category()) {
 541     case TypeCategory::Integer:
 542       return t1;
 543     case TypeCategory::Real:
 544     case TypeCategory::Complex:
 545       return DynamicType{t2.category(), std::max(t1.kind(), t2.kind())};
 546     default:
 547       return std::nullopt;
 548     }
 549   case TypeCategory::Complex:
 550     switch (t2.category()) {
 551     case TypeCategory::Integer:
 552       return t1;
 553     case TypeCategory::Real:
 554     case TypeCategory::Complex:
 555       return DynamicType{TypeCategory::Complex, std::max(t1.kind(), t2.kind())};
 556     default:
 557       return std::nullopt;
 558     }
 559   case TypeCategory::Character:
 560     switch (t2.category()) {
 561     case TypeCategory::Character:
 562       return DynamicType{
 563           TypeCategory::Character, std::max(t1.kind(), t2.kind())};
 564     default:
 565       return std::nullopt;
 566     }
 567   case TypeCategory::Logical:
 568     switch (t2.category()) {
 569     case TypeCategory::Logical:
 570       return DynamicType{TypeCategory::Logical, LogicalResult::kind};
 571     default:
 572       return std::nullopt;
 573     }
 574   default:
 575     return std::nullopt;
 576   }
 577 }
 578
 579 bool IsInteroperableIntrinsicType(const DynamicType &type) {
 580   switch (type.category()) {
 581   case TypeCategory::Integer:
 582     return true;
 583   case TypeCategory::Real:
 584   case TypeCategory::Complex:
 585     return type.kind() >= 4; // no short or half floats
 586   case TypeCategory::Logical:
 587     return type.kind() == 1; // C_BOOL
 588   case TypeCategory::Character:
 589     return type.kind() == 1 /* C_CHAR */ && type.knownLength().value_or(0) == 1;
 590   default:
 591     // Derived types are tested in Semantics/check-declarations.cpp
 592     return false;
 593   }
 594 }
 595
 596 } // namespace Fortran::evaluate