950 lines · cpp
1//===-- lib/Semantics/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/Semantics/type.h"10#include "check-declarations.h"11#include "compute-offsets.h"12#include "flang/Common/type-kinds.h"13#include "flang/Evaluate/fold.h"14#include "flang/Evaluate/tools.h"15#include "flang/Evaluate/type.h"16#include "flang/Parser/characters.h"17#include "flang/Parser/parse-tree-visitor.h"18#include "flang/Semantics/scope.h"19#include "flang/Semantics/symbol.h"20#include "flang/Semantics/tools.h"21#include "llvm/Support/raw_ostream.h"22 23namespace Fortran::semantics {24 25DerivedTypeSpec::DerivedTypeSpec(SourceName name, const Symbol &typeSymbol)26 : name_{name}, originalTypeSymbol_{typeSymbol},27 typeSymbol_{typeSymbol.GetUltimate()} {28 CHECK(typeSymbol_.has<DerivedTypeDetails>());29}30DerivedTypeSpec::DerivedTypeSpec(const DerivedTypeSpec &that) = default;31DerivedTypeSpec::DerivedTypeSpec(DerivedTypeSpec &&that) = default;32 33void DerivedTypeSpec::set_scope(const Scope &scope) {34 CHECK(!scope_);35 ReplaceScope(scope);36}37void DerivedTypeSpec::ReplaceScope(const Scope &scope) {38 CHECK(scope.IsDerivedType());39 scope_ = &scope;40}41 42const Scope *DerivedTypeSpec::GetScope() const {43 return scope_ ? scope_ : typeSymbol_.scope();44}45 46void DerivedTypeSpec::AddRawParamValue(47 const parser::Keyword *keyword, ParamValue &&value) {48 CHECK(parameters_.empty());49 rawParameters_.emplace_back(keyword, std::move(value));50}51 52void DerivedTypeSpec::CookParameters(evaluate::FoldingContext &foldingContext) {53 if (cooked_) {54 return;55 }56 cooked_ = true;57 auto &messages{foldingContext.messages()};58 if (IsForwardReferenced()) {59 messages.Say(typeSymbol_.name(),60 "Derived type '%s' was used but never defined"_err_en_US,61 typeSymbol_.name());62 return;63 }64 65 // Parameters of the most deeply nested "base class" come first when the66 // derived type is an extension.67 auto parameterNames{OrderParameterNames(typeSymbol_)};68 auto nextNameIter{parameterNames.begin()};69 RawParameters raw{std::move(rawParameters_)};70 for (auto &[maybeKeyword, value] : raw) {71 SourceName name;72 common::TypeParamAttr attr{common::TypeParamAttr::Kind};73 if (maybeKeyword) {74 name = maybeKeyword->v.source;75 auto it{std::find_if(parameterNames.begin(), parameterNames.end(),76 [&](const Symbol &symbol) { return symbol.name() == name; })};77 if (it == parameterNames.end()) {78 messages.Say(name,79 "'%s' is not the name of a parameter for derived type '%s'"_err_en_US,80 name, typeSymbol_.name());81 } else {82 // Resolve the keyword's symbol83 maybeKeyword->v.symbol = const_cast<Symbol *>(&it->get());84 if (const auto *tpd{it->get().detailsIf<TypeParamDetails>()}) {85 attr = tpd->attr().value_or(attr);86 }87 }88 } else if (nextNameIter != parameterNames.end()) {89 name = nextNameIter->get().name();90 if (const auto *tpd{nextNameIter->get().detailsIf<TypeParamDetails>()}) {91 attr = tpd->attr().value_or(attr);92 }93 ++nextNameIter;94 } else {95 messages.Say(name_,96 "Too many type parameters given for derived type '%s'"_err_en_US,97 typeSymbol_.name());98 break;99 }100 if (FindParameter(name)) {101 messages.Say(name_,102 "Multiple values given for type parameter '%s'"_err_en_US, name);103 } else {104 value.set_attr(attr);105 AddParamValue(name, std::move(value));106 }107 }108}109 110void DerivedTypeSpec::EvaluateParameters(SemanticsContext &context) {111 evaluate::FoldingContext &foldingContext{context.foldingContext()};112 CookParameters(foldingContext);113 if (evaluated_) {114 return;115 }116 evaluated_ = true;117 auto &messages{foldingContext.messages()};118 for (const Symbol &symbol : OrderParameterDeclarations(typeSymbol_)) {119 SourceName name{symbol.name()};120 int parameterKind{evaluate::TypeParamInquiry::Result::kind};121 // Compute the integer kind value of the type parameter,122 // which may depend on the values of earlier ones.123 if (const auto *typeSpec{symbol.GetType()}) {124 if (const IntrinsicTypeSpec * intrinType{typeSpec->AsIntrinsic()};125 intrinType && intrinType->category() == TypeCategory::Integer) {126 auto restorer{foldingContext.WithPDTInstance(*this)};127 auto folded{Fold(foldingContext, KindExpr{intrinType->kind()})};128 if (auto k{evaluate::ToInt64(folded)}; k &&129 common::IsValidKindOfIntrinsicType(TypeCategory::Integer, *k)) {130 parameterKind = static_cast<int>(*k);131 } else {132 messages.Say(133 "Type of type parameter '%s' (%s) is not a valid kind of INTEGER"_err_en_US,134 name, intrinType->kind().AsFortran());135 }136 }137 }138 bool ok{139 symbol.get<TypeParamDetails>().attr() == common::TypeParamAttr::Len};140 if (ParamValue * paramValue{FindParameter(name)}) {141 // Explicit type parameter value expressions are not folded within142 // the scope of the derived type being instantiated, as the expressions143 // themselves are not in that scope and cannot reference its type144 // parameters.145 if (const MaybeIntExpr & expr{paramValue->GetExplicit()}) {146 evaluate::DynamicType dyType{TypeCategory::Integer, parameterKind};147 if (auto converted{evaluate::ConvertToType(dyType, SomeExpr{*expr})}) {148 SomeExpr folded{149 evaluate::Fold(foldingContext, std::move(*converted))};150 if (auto *intExpr{std::get_if<SomeIntExpr>(&folded.u)}) {151 ok = ok || evaluate::IsActuallyConstant(*intExpr);152 paramValue->SetExplicit(std::move(*intExpr));153 }154 } else if (!context.HasError(symbol)) {155 evaluate::SayWithDeclaration(messages, symbol,156 "Value of type parameter '%s' (%s) is not convertible to its type (%s)"_err_en_US,157 name, expr->AsFortran(), dyType.AsFortran());158 }159 }160 } else {161 // Default type parameter value expressions are folded within162 // the scope of the derived type being instantiated.163 const TypeParamDetails &details{symbol.get<TypeParamDetails>()};164 if (details.init() && details.attr()) {165 evaluate::DynamicType dyType{TypeCategory::Integer, parameterKind};166 if (auto converted{167 evaluate::ConvertToType(dyType, SomeExpr{*details.init()})}) {168 auto restorer{foldingContext.WithPDTInstance(*this)};169 SomeExpr folded{170 evaluate::Fold(foldingContext, std::move(*converted))};171 ok = ok || evaluate::IsActuallyConstant(folded);172 AddParamValue(name,173 ParamValue{std::move(std::get<SomeIntExpr>(folded.u)),174 details.attr().value()});175 } else {176 if (!context.HasError(symbol)) {177 evaluate::SayWithDeclaration(messages, symbol,178 "Default value of type parameter '%s' (%s) is not convertible to its type (%s)"_err_en_US,179 name, details.init()->AsFortran(), dyType.AsFortran());180 }181 }182 } else if (!context.HasError(symbol)) {183 messages.Say(name_,184 "Type parameter '%s' lacks a value and has no default"_err_en_US,185 name);186 }187 }188 if (!ok && !context.HasError(symbol)) {189 messages.Say(190 "Value of KIND type parameter '%s' must be constant"_err_en_US, name);191 }192 }193}194 195void DerivedTypeSpec::ReevaluateParameters(SemanticsContext &context) {196 evaluated_ = false;197 instantiated_ = false;198 scope_ = nullptr;199 EvaluateParameters(context);200}201 202void DerivedTypeSpec::AddParamValue(SourceName name, ParamValue &&value) {203 CHECK(cooked_);204 auto pair{parameters_.insert(std::make_pair(name, std::move(value)))};205 CHECK(pair.second); // name was not already present206}207 208bool DerivedTypeSpec::MightBeParameterized() const {209 return !cooked_ || !parameters_.empty();210}211 212bool DerivedTypeSpec::IsForwardReferenced() const {213 return typeSymbol_.get<DerivedTypeDetails>().isForwardReferenced();214}215 216std::optional<std::string> DerivedTypeSpec::ComponentWithDefaultInitialization(217 bool ignoreAllocatable, bool ignorePointer) const {218 DirectComponentIterator components{*this};219 if (auto it{std::find_if(components.begin(), components.end(),220 [ignoreAllocatable, ignorePointer](const Symbol &component) {221 return (!ignoreAllocatable && IsAllocatable(component)) ||222 (!ignorePointer && IsPointer(component)) ||223 HasDeclarationInitializer(component);224 })}) {225 return it.BuildResultDesignatorName();226 } else {227 return std::nullopt;228 }229}230 231bool DerivedTypeSpec::HasDefaultInitialization(232 bool ignoreAllocatable, bool ignorePointer) const {233 return ComponentWithDefaultInitialization(ignoreAllocatable, ignorePointer)234 .has_value();235}236 237bool DerivedTypeSpec::HasDestruction() const {238 if (!FinalsForDerivedTypeInstantiation(*this).empty()) {239 return true;240 }241 DirectComponentIterator components{*this};242 return bool{std::find_if(243 components.begin(), components.end(), [&](const Symbol &component) {244 return IsDestructible(component, &typeSymbol());245 })};246}247 248ParamValue *DerivedTypeSpec::FindParameter(SourceName target) {249 return const_cast<ParamValue *>(250 const_cast<const DerivedTypeSpec *>(this)->FindParameter(target));251}252 253static bool MatchKindParams(const Symbol &typeSymbol,254 const DerivedTypeSpec &thisSpec, const DerivedTypeSpec &thatSpec) {255 for (auto ref : typeSymbol.get<DerivedTypeDetails>().paramNameOrder()) {256 if (ref->get<TypeParamDetails>().attr() == common::TypeParamAttr::Kind) {257 const auto *thisValue{thisSpec.FindParameter(ref->name())};258 const auto *thatValue{thatSpec.FindParameter(ref->name())};259 if (!thisValue || !thatValue || *thisValue != *thatValue) {260 return false;261 }262 }263 }264 if (const DerivedTypeSpec *265 parent{typeSymbol.GetParentTypeSpec(typeSymbol.scope())}) {266 return MatchKindParams(parent->typeSymbol(), thisSpec, thatSpec);267 } else {268 return true;269 }270}271 272bool DerivedTypeSpec::MatchesOrExtends(const DerivedTypeSpec &that) const {273 const Symbol *typeSymbol{&typeSymbol_};274 while (typeSymbol != &that.typeSymbol_) {275 if (const DerivedTypeSpec *276 parent{typeSymbol->GetParentTypeSpec(typeSymbol->scope())}) {277 typeSymbol = &parent->typeSymbol_;278 } else {279 return false;280 }281 }282 return MatchKindParams(*typeSymbol, *this, that);283}284 285class InstantiateHelper {286public:287 InstantiateHelper(Scope &scope) : scope_{scope} {}288 // Instantiate components from fromScope into scope_289 void InstantiateComponents(const Scope &);290 291private:292 SemanticsContext &context() const { return scope_.context(); }293 evaluate::FoldingContext &foldingContext() {294 return context().foldingContext();295 }296 template <typename A> A Fold(A &&expr) {297 return evaluate::Fold(foldingContext(), std::move(expr));298 }299 void InstantiateComponent(const Symbol &);300 const DeclTypeSpec *InstantiateType(const Symbol &);301 const DeclTypeSpec &InstantiateIntrinsicType(302 SourceName, const DeclTypeSpec &);303 DerivedTypeSpec CreateDerivedTypeSpec(const DerivedTypeSpec &, bool);304 305 Scope &scope_;306};307 308static int PlumbPDTInstantiationDepth(const Scope *scope) {309 int depth{0};310 while (scope->IsParameterizedDerivedTypeInstantiation()) {311 ++depth;312 scope = &scope->parent();313 }314 return depth;315}316 317// Completes component derived type instantiation and initializer folding318// for a non-parameterized derived type Scope.319static void InstantiateNonPDTScope(Scope &typeScope, Scope &containingScope) {320 auto &context{containingScope.context()};321 auto &foldingContext{context.foldingContext()};322 for (auto &pair : typeScope) {323 Symbol &symbol{*pair.second};324 if (DeclTypeSpec * type{symbol.GetType()}) {325 if (DerivedTypeSpec * derived{type->AsDerived()}) {326 if (!(derived->IsForwardReferenced() &&327 IsAllocatableOrPointer(symbol))) {328 derived->Instantiate(containingScope);329 }330 }331 }332 if (!IsPointer(symbol)) {333 if (auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {334 if (MaybeExpr & init{object->init()}) {335 auto restorer{foldingContext.messages().SetLocation(symbol.name())};336 init = evaluate::NonPointerInitializationExpr(337 symbol, std::move(*init), foldingContext);338 }339 }340 }341 }342 ComputeOffsets(context, typeScope);343}344 345void DerivedTypeSpec::Instantiate(Scope &containingScope) {346 if (instantiated_) {347 return;348 }349 instantiated_ = true;350 auto &context{containingScope.context()};351 auto &foldingContext{context.foldingContext()};352 if (IsForwardReferenced()) {353 foldingContext.messages().Say(typeSymbol_.name(),354 "The derived type '%s' was forward-referenced but not defined"_err_en_US,355 typeSymbol_.name());356 context.SetError(typeSymbol_);357 return;358 }359 EvaluateParameters(context);360 const Scope &typeScope{DEREF(typeSymbol_.scope())};361 if (!MightBeParameterized()) {362 scope_ = &typeScope;363 if (!typeScope.derivedTypeSpec() || *this != *typeScope.derivedTypeSpec()) {364 Scope &mutableTypeScope{const_cast<Scope &>(typeScope)};365 mutableTypeScope.set_derivedTypeSpec(*this);366 InstantiateNonPDTScope(mutableTypeScope, containingScope);367 }368 return;369 }370 // New PDT instantiation. Create a new scope and populate it371 // with components that have been specialized for this set of372 // parameters.373 Scope &newScope{containingScope.MakeScope(Scope::Kind::DerivedType)};374 newScope.set_derivedTypeSpec(*this);375 ReplaceScope(newScope);376 auto restorer{foldingContext.WithPDTInstance(*this)};377 std::string desc{typeSymbol_.name().ToString()};378 char sep{'('};379 for (const Symbol &symbol : OrderParameterDeclarations(typeSymbol_)) {380 const SourceName &name{symbol.name()};381 if (typeScope.find(symbol.name()) != typeScope.end()) {382 // This type parameter belongs to the derived type itself, not to383 // one of its ancestors. Put the type parameter expression value,384 // when there is one, into the new scope as the initialization value385 // for the parameter. And when there is no explicit value, add an386 // uninitialized type parameter to forestall use of any default.387 if (ParamValue * paramValue{FindParameter(name)}) {388 const TypeParamDetails &details{symbol.get<TypeParamDetails>()};389 TypeParamDetails instanceDetails{};390 if (details.attr()) {391 paramValue->set_attr(*details.attr());392 instanceDetails.set_attr(*details.attr());393 }394 desc += sep;395 desc += name.ToString();396 desc += '=';397 sep = ',';398 if (MaybeIntExpr expr{paramValue->GetExplicit()}) {399 desc += expr->AsFortran();400 instanceDetails.set_init(401 std::move(DEREF(evaluate::UnwrapExpr<SomeIntExpr>(*expr))));402 if (auto dyType{expr->GetType()}) {403 instanceDetails.set_type(newScope.MakeNumericType(404 TypeCategory::Integer, KindExpr{dyType->kind()}));405 }406 }407 if (!instanceDetails.type()) {408 if (const DeclTypeSpec * type{details.type()}) {409 instanceDetails.set_type(*type);410 }411 }412 if (!instanceDetails.init()) {413 desc += '*';414 }415 newScope.try_emplace(name, std::move(instanceDetails));416 }417 }418 }419 parser::Message *contextMessage{nullptr};420 if (sep != '(') {421 desc += ')';422 contextMessage = new parser::Message{foldingContext.messages().at(),423 "instantiation of parameterized derived type '%s'"_en_US, desc};424 if (auto outer{containingScope.instantiationContext()}) {425 contextMessage->SetContext(outer.get());426 }427 newScope.set_instantiationContext(contextMessage);428 }429 // Instantiate nearly every non-parameter symbol from the original derived430 // type's scope into the new instance.431 auto restorer2{foldingContext.messages().SetContext(contextMessage)};432 if (PlumbPDTInstantiationDepth(&containingScope) > 100) {433 foldingContext.messages().Say(434 "Too many recursive parameterized derived type instantiations"_err_en_US);435 } else {436 InstantiateHelper{newScope}.InstantiateComponents(typeScope);437 }438}439 440void InstantiateHelper::InstantiateComponents(const Scope &fromScope) {441 // Instantiate symbols in declaration order; this ensures that442 // parent components and type parameters of ancestor types exist443 // by the time that they're needed.444 for (SymbolRef ref : fromScope.GetSymbols()) {445 InstantiateComponent(*ref);446 }447 ComputeOffsets(context(), scope_);448}449 450// Walks a parsed expression to prepare it for (re)analysis;451// clears out the typedExpr analysis results and re-resolves452// symbol table pointers of type parameters.453class ResetHelper {454public:455 explicit ResetHelper(Scope &scope) : scope_{scope} {}456 457 template <typename A> bool Pre(const A &) { return true; }458 459 template <typename A> void Post(const A &x) {460 if constexpr (parser::HasTypedExpr<A>()) {461 x.typedExpr.Reset();462 }463 }464 465 void Post(const parser::Name &name) {466 if (name.symbol && name.symbol->has<TypeParamDetails>()) {467 name.symbol = scope_.FindComponent(name.source);468 }469 }470 471private:472 Scope &scope_;473};474 475void InstantiateHelper::InstantiateComponent(const Symbol &oldSymbol) {476 auto pair{scope_.try_emplace(477 oldSymbol.name(), oldSymbol.attrs(), common::Clone(oldSymbol.details()))};478 Symbol &newSymbol{*pair.first->second};479 if (!pair.second) {480 // Symbol was already present in the scope, which can only happen481 // in the case of type parameters.482 CHECK(oldSymbol.has<TypeParamDetails>());483 return;484 }485 newSymbol.flags() = oldSymbol.flags();486 if (auto *details{newSymbol.detailsIf<ObjectEntityDetails>()}) {487 if (const DeclTypeSpec * newType{InstantiateType(newSymbol)}) {488 details->ReplaceType(*newType);489 }490 for (ShapeSpec &dim : details->shape()) {491 if (dim.lbound().isExplicit()) {492 dim.lbound().SetExplicit(Fold(std::move(dim.lbound().GetExplicit())));493 }494 if (dim.ubound().isExplicit()) {495 dim.ubound().SetExplicit(Fold(std::move(dim.ubound().GetExplicit())));496 }497 }498 for (ShapeSpec &dim : details->coshape()) {499 if (dim.lbound().isExplicit()) {500 dim.lbound().SetExplicit(Fold(std::move(dim.lbound().GetExplicit())));501 }502 if (dim.ubound().isExplicit()) {503 dim.ubound().SetExplicit(Fold(std::move(dim.ubound().GetExplicit())));504 }505 }506 if (const auto *parsedExpr{details->unanalyzedPDTComponentInit()}) {507 // Analyze the parsed expression in this PDT instantiation context.508 ResetHelper resetter{scope_};509 parser::Walk(*parsedExpr, resetter);510 auto restorer{foldingContext().messages().SetLocation(newSymbol.name())};511 details->set_init(evaluate::Fold(512 foldingContext(), AnalyzeExpr(context(), *parsedExpr)));513 details->set_unanalyzedPDTComponentInit(nullptr);514 // Remove analysis results to prevent unparsing or other use of515 // instantiation-specific expressions.516 parser::Walk(*parsedExpr, resetter);517 }518 if (MaybeExpr & init{details->init()}) {519 // Non-pointer components with default initializers are520 // processed now so that those default initializers can be used521 // in PARAMETER structure constructors.522 auto restorer{foldingContext().messages().SetLocation(newSymbol.name())};523 init = IsPointer(newSymbol)524 ? Fold(std::move(*init))525 : evaluate::NonPointerInitializationExpr(526 newSymbol, std::move(*init), foldingContext());527 }528 } else if (auto *procDetails{newSymbol.detailsIf<ProcEntityDetails>()}) {529 // We have a procedure pointer. Instantiate its return type530 if (const DeclTypeSpec * returnType{InstantiateType(newSymbol)}) {531 if (!procDetails->procInterface()) {532 procDetails->ReplaceType(*returnType);533 }534 }535 }536}537 538const DeclTypeSpec *InstantiateHelper::InstantiateType(const Symbol &symbol) {539 const DeclTypeSpec *type{symbol.GetType()};540 if (!type) {541 return nullptr; // error has occurred542 } else if (const DerivedTypeSpec * spec{type->AsDerived()}) {543 return &FindOrInstantiateDerivedType(scope_,544 CreateDerivedTypeSpec(*spec, symbol.test(Symbol::Flag::ParentComp)),545 type->category());546 } else if (type->AsIntrinsic()) {547 return &InstantiateIntrinsicType(symbol.name(), *type);548 } else if (type->category() == DeclTypeSpec::ClassStar) {549 return type;550 } else {551 common::die("InstantiateType: %s", type->AsFortran().c_str());552 }553}554 555/// Fold explicit length parameters of character components when the explicit556/// expression is a constant expression (if it only depends on KIND parameters).557/// Do not fold `character(len=pdt_length)`, even if the length parameter is558/// constant in the pdt instantiation, in order to avoid losing the information559/// that the character component is automatic (and must be a descriptor).560static ParamValue FoldCharacterLength(evaluate::FoldingContext &foldingContext,561 const CharacterTypeSpec &characterSpec) {562 if (const auto &len{characterSpec.length().GetExplicit()}) {563 if (evaluate::IsConstantExpr(*len)) {564 return ParamValue{evaluate::Fold(foldingContext, common::Clone(*len)),565 common::TypeParamAttr::Len};566 }567 }568 return characterSpec.length();569}570 571// Apply type parameter values to an intrinsic type spec.572const DeclTypeSpec &InstantiateHelper::InstantiateIntrinsicType(573 SourceName symbolName, const DeclTypeSpec &spec) {574 const parser::Expr *originalKindExpr{nullptr};575 if (const DerivedTypeSpec *derived{scope_.derivedTypeSpec()}) {576 if (const auto *details{derived->originalTypeSymbol()577 .GetUltimate()578 .detailsIf<DerivedTypeDetails>()}) {579 const auto &originalKindMap{details->originalKindParameterMap()};580 if (auto iter{originalKindMap.find(symbolName)};581 iter != originalKindMap.end()) {582 originalKindExpr = iter->second;583 }584 }585 }586 const IntrinsicTypeSpec &intrinsic{DEREF(spec.AsIntrinsic())};587 if (spec.category() != DeclTypeSpec::Character && !originalKindExpr &&588 evaluate::IsActuallyConstant(intrinsic.kind())) {589 return spec; // KIND is already a known constant590 }591 // The expression was not originally constant, but now it must be so592 // in the context of a parameterized derived type instantiation.593 std::optional<KindExpr> kindExpr;594 if (originalKindExpr) {595 ResetHelper resetter{scope_};596 parser::Walk(*originalKindExpr, resetter);597 auto restorer{foldingContext().messages().DiscardMessages()};598 if (MaybeExpr analyzed{AnalyzeExpr(scope_.context(), *originalKindExpr)}) {599 if (auto *intExpr{evaluate::UnwrapExpr<SomeIntExpr>(*analyzed)}) {600 kindExpr = evaluate::ConvertToType<evaluate::SubscriptInteger>(601 std::move(*intExpr));602 }603 }604 }605 if (!kindExpr) {606 kindExpr = KindExpr{intrinsic.kind()};607 CHECK(kindExpr.has_value());608 }609 KindExpr folded{Fold(std::move(*kindExpr))};610 int kind{context().GetDefaultKind(intrinsic.category())};611 if (auto value{evaluate::ToInt64(folded)}) {612 if (foldingContext().targetCharacteristics().IsTypeEnabled(613 intrinsic.category(), *value)) {614 kind = *value;615 } else {616 foldingContext().messages().Say(symbolName,617 "KIND parameter value (%jd) of intrinsic type %s did not resolve to a supported value"_err_en_US,618 *value,619 parser::ToUpperCaseLetters(EnumToString(intrinsic.category())));620 }621 } else {622 std::string exprString;623 llvm::raw_string_ostream sstream(exprString);624 folded.AsFortran(sstream);625 foldingContext().messages().Say(symbolName,626 "KIND parameter expression (%s) of intrinsic type %s did not resolve to a constant value"_err_en_US,627 exprString,628 parser::ToUpperCaseLetters(EnumToString(intrinsic.category())));629 }630 switch (spec.category()) {631 case DeclTypeSpec::Numeric:632 return scope_.MakeNumericType(intrinsic.category(), KindExpr{kind});633 case DeclTypeSpec::Logical:634 return scope_.MakeLogicalType(KindExpr{kind});635 case DeclTypeSpec::Character:636 return scope_.MakeCharacterType(637 FoldCharacterLength(foldingContext(), spec.characterTypeSpec()),638 KindExpr{kind});639 default:640 CRASH_NO_CASE;641 }642}643 644DerivedTypeSpec InstantiateHelper::CreateDerivedTypeSpec(645 const DerivedTypeSpec &spec, bool isParentComp) {646 DerivedTypeSpec result{spec};647 result.CookParameters(foldingContext()); // enables AddParamValue()648 if (isParentComp) {649 // Forward any explicit type parameter values from the650 // derived type spec under instantiation that define type parameters651 // of the parent component to the derived type spec of the652 // parent component.653 const DerivedTypeSpec &instanceSpec{DEREF(foldingContext().pdtInstance())};654 for (const auto &[name, value] : instanceSpec.parameters()) {655 if (scope_.find(name) == scope_.end()) {656 result.AddParamValue(name, ParamValue{value});657 }658 }659 }660 return result;661}662 663std::string DerivedTypeSpec::VectorTypeAsFortran() const {664 std::string buf;665 llvm::raw_string_ostream ss{buf};666 667 switch (category()) {668 SWITCH_COVERS_ALL_CASES669 case (Fortran::semantics::DerivedTypeSpec::Category::IntrinsicVector): {670 int64_t vecElemKind;671 int64_t vecElemCategory;672 673 for (const auto &pair : parameters()) {674 if (pair.first == "element_category") {675 vecElemCategory =676 Fortran::evaluate::ToInt64(pair.second.GetExplicit()).value_or(-1);677 } else if (pair.first == "element_kind") {678 vecElemKind =679 Fortran::evaluate::ToInt64(pair.second.GetExplicit()).value_or(0);680 }681 }682 683 assert((vecElemCategory >= 0 &&684 static_cast<size_t>(vecElemCategory) <685 Fortran::common::VectorElementCategory_enumSize) &&686 "Vector element type is not specified");687 assert(vecElemKind && "Vector element kind is not specified");688 689 ss << "vector(";690 switch (static_cast<common::VectorElementCategory>(vecElemCategory)) {691 SWITCH_COVERS_ALL_CASES692 case common::VectorElementCategory::Integer:693 ss << "integer(" << vecElemKind << ")";694 break;695 case common::VectorElementCategory::Unsigned:696 ss << "unsigned(" << vecElemKind << ")";697 break;698 case common::VectorElementCategory::Real:699 ss << "real(" << vecElemKind << ")";700 break;701 }702 ss << ")";703 break;704 }705 case (Fortran::semantics::DerivedTypeSpec::Category::PairVector):706 ss << "__vector_pair";707 break;708 case (Fortran::semantics::DerivedTypeSpec::Category::QuadVector):709 ss << "__vector_quad";710 break;711 case (Fortran::semantics::DerivedTypeSpec::Category::DerivedType):712 Fortran::common::die("Vector element type not implemented");713 }714 return buf;715}716 717std::string DerivedTypeSpec::AsFortran() const {718 std::string buf;719 llvm::raw_string_ostream ss{buf};720 ss << originalTypeSymbol_.name();721 if (!rawParameters_.empty()) {722 CHECK(parameters_.empty());723 ss << '(';724 bool first = true;725 for (const auto &[maybeKeyword, value] : rawParameters_) {726 if (first) {727 first = false;728 } else {729 ss << ',';730 }731 if (maybeKeyword) {732 ss << maybeKeyword->v.source.ToString() << '=';733 }734 ss << value.AsFortran();735 }736 ss << ')';737 } else if (!parameters_.empty()) {738 ss << '(';739 bool first = true;740 for (const auto &[name, value] : parameters_) {741 if (first) {742 first = false;743 } else {744 ss << ',';745 }746 ss << name.ToString() << '=' << value.AsFortran();747 }748 ss << ')';749 }750 return buf;751}752 753llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const DerivedTypeSpec &x) {754 return o << x.AsFortran();755}756 757Bound::Bound(common::ConstantSubscript bound) : expr_{bound} {}758 759llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const Bound &x) {760 if (x.isStar()) {761 o << '*';762 } else if (x.isColon()) {763 o << ':';764 } else if (x.expr_) {765 x.expr_->AsFortran(o);766 } else {767 o << "<no-expr>";768 }769 return o;770}771 772llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const ShapeSpec &x) {773 if (x.lb_.isStar()) {774 CHECK(x.ub_.isStar());775 o << "..";776 } else {777 if (!x.lb_.isColon()) {778 o << x.lb_;779 }780 o << ':';781 if (!x.ub_.isColon()) {782 o << x.ub_;783 }784 }785 return o;786}787 788llvm::raw_ostream &operator<<(789 llvm::raw_ostream &os, const ArraySpec &arraySpec) {790 char sep{'('};791 for (auto &shape : arraySpec) {792 os << sep << shape;793 sep = ',';794 }795 if (sep == ',') {796 os << ')';797 }798 return os;799}800 801ParamValue::ParamValue(MaybeIntExpr &&expr, common::TypeParamAttr attr)802 : attr_{attr}, expr_{std::move(expr)} {}803ParamValue::ParamValue(SomeIntExpr &&expr, common::TypeParamAttr attr)804 : attr_{attr}, expr_{std::move(expr)} {}805ParamValue::ParamValue(806 common::ConstantSubscript value, common::TypeParamAttr attr)807 : ParamValue(SomeIntExpr{evaluate::Expr<evaluate::SubscriptInteger>{value}},808 attr) {}809 810void ParamValue::SetExplicit(SomeIntExpr &&x) {811 category_ = Category::Explicit;812 expr_ = std::move(x);813}814 815std::string ParamValue::AsFortran() const {816 switch (category_) {817 SWITCH_COVERS_ALL_CASES818 case Category::Assumed:819 return "*";820 case Category::Deferred:821 return ":";822 case Category::Explicit:823 if (expr_) {824 std::string buf;825 llvm::raw_string_ostream ss{buf};826 expr_->AsFortran(ss);827 return buf;828 } else {829 return "";830 }831 }832}833 834llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const ParamValue &x) {835 return o << x.AsFortran();836}837 838IntrinsicTypeSpec::IntrinsicTypeSpec(TypeCategory category, KindExpr &&kind)839 : category_{category}, kind_{std::move(kind)} {840 CHECK(category != TypeCategory::Derived);841}842 843static std::string KindAsFortran(const KindExpr &kind) {844 std::string buf;845 llvm::raw_string_ostream ss{buf};846 if (auto k{evaluate::ToInt64(kind)}) {847 ss << *k; // emit unsuffixed kind code848 } else {849 kind.AsFortran(ss);850 }851 return buf;852}853 854std::string IntrinsicTypeSpec::AsFortran() const {855 return parser::ToUpperCaseLetters(common::EnumToString(category_)) + '(' +856 KindAsFortran(kind_) + ')';857}858 859llvm::raw_ostream &operator<<(860 llvm::raw_ostream &os, const IntrinsicTypeSpec &x) {861 return os << x.AsFortran();862}863 864std::string CharacterTypeSpec::AsFortran() const {865 return "CHARACTER(" + length_.AsFortran() + ',' + KindAsFortran(kind()) + ')';866}867 868llvm::raw_ostream &operator<<(869 llvm::raw_ostream &os, const CharacterTypeSpec &x) {870 return os << x.AsFortran();871}872 873DeclTypeSpec::DeclTypeSpec(NumericTypeSpec &&typeSpec)874 : category_{Numeric}, typeSpec_{std::move(typeSpec)} {}875DeclTypeSpec::DeclTypeSpec(LogicalTypeSpec &&typeSpec)876 : category_{Logical}, typeSpec_{std::move(typeSpec)} {}877DeclTypeSpec::DeclTypeSpec(const CharacterTypeSpec &typeSpec)878 : category_{Character}, typeSpec_{typeSpec} {}879DeclTypeSpec::DeclTypeSpec(CharacterTypeSpec &&typeSpec)880 : category_{Character}, typeSpec_{std::move(typeSpec)} {}881DeclTypeSpec::DeclTypeSpec(Category category, const DerivedTypeSpec &typeSpec)882 : category_{category}, typeSpec_{typeSpec} {883 CHECK(category == TypeDerived || category == ClassDerived);884}885DeclTypeSpec::DeclTypeSpec(Category category, DerivedTypeSpec &&typeSpec)886 : category_{category}, typeSpec_{std::move(typeSpec)} {887 CHECK(category == TypeDerived || category == ClassDerived);888}889DeclTypeSpec::DeclTypeSpec(Category category) : category_{category} {890 CHECK(category == TypeStar || category == ClassStar);891}892bool DeclTypeSpec::IsNumeric(TypeCategory tc) const {893 return category_ == Numeric && numericTypeSpec().category() == tc;894}895bool DeclTypeSpec::IsSequenceType() const {896 if (const DerivedTypeSpec * derivedType{AsDerived()}) {897 const auto *typeDetails{898 derivedType->typeSymbol().detailsIf<DerivedTypeDetails>()};899 return typeDetails && typeDetails->sequence();900 }901 return false;902}903 904const NumericTypeSpec &DeclTypeSpec::numericTypeSpec() const {905 CHECK(category_ == Numeric);906 return std::get<NumericTypeSpec>(typeSpec_);907}908const LogicalTypeSpec &DeclTypeSpec::logicalTypeSpec() const {909 CHECK(category_ == Logical);910 return std::get<LogicalTypeSpec>(typeSpec_);911}912bool DeclTypeSpec::operator==(const DeclTypeSpec &that) const {913 return category_ == that.category_ && typeSpec_ == that.typeSpec_;914}915 916std::string DeclTypeSpec::AsFortran() const {917 switch (category_) {918 SWITCH_COVERS_ALL_CASES919 case Numeric:920 return numericTypeSpec().AsFortran();921 case Logical:922 return logicalTypeSpec().AsFortran();923 case Character:924 return characterTypeSpec().AsFortran();925 case TypeDerived:926 if (derivedTypeSpec()927 .typeSymbol()928 .get<DerivedTypeDetails>()929 .isDECStructure()) {930 return "RECORD" + derivedTypeSpec().typeSymbol().name().ToString();931 } else if (derivedTypeSpec().IsVectorType()) {932 return derivedTypeSpec().VectorTypeAsFortran();933 } else {934 return "TYPE(" + derivedTypeSpec().AsFortran() + ')';935 }936 case ClassDerived:937 return "CLASS(" + derivedTypeSpec().AsFortran() + ')';938 case TypeStar:939 return "TYPE(*)";940 case ClassStar:941 return "CLASS(*)";942 }943}944 945llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const DeclTypeSpec &x) {946 return o << x.AsFortran();947}948 949} // namespace Fortran::semantics950