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-exception 6 // 7 //===----------------------------------------------------------------------===// 8 9 #include "flang/Semantics/type.h" 10 #include "check-declarations.h" 11 #include "compute-offsets.h" 12 #include "flang/Evaluate/fold.h" 13 #include "flang/Evaluate/tools.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 "llvm/Support/raw_ostream.h" 19 20 namespace Fortran::semantics { 21 22 DerivedTypeSpec::DerivedTypeSpec(SourceName name, const Symbol &typeSymbol) 23 : name_{name}, typeSymbol_{typeSymbol} { 24 CHECK(typeSymbol.has<DerivedTypeDetails>()); 25 } 26 DerivedTypeSpec::DerivedTypeSpec(const DerivedTypeSpec &that) = default; 27 DerivedTypeSpec::DerivedTypeSpec(DerivedTypeSpec &&that) = default; 28 29 void DerivedTypeSpec::set_scope(const Scope &scope) { 30 CHECK(!scope_); 31 ReplaceScope(scope); 32 } 33 void DerivedTypeSpec::ReplaceScope(const Scope &scope) { 34 CHECK(scope.IsDerivedType()); 35 scope_ = &scope; 36 } 37 38 void DerivedTypeSpec::AddRawParamValue( 39 const std::optional<parser::Keyword> &keyword, ParamValue &&value) { 40 CHECK(parameters_.empty()); 41 rawParameters_.emplace_back(keyword ? &*keyword : nullptr, std::move(value)); 42 } 43 44 void DerivedTypeSpec::CookParameters(evaluate::FoldingContext &foldingContext) { 45 if (cooked_) { 46 return; 47 } 48 cooked_ = true; 49 auto &messages{foldingContext.messages()}; 50 if (IsForwardReferenced()) { 51 messages.Say(typeSymbol_.name(), 52 "Derived type '%s' was used but never defined"_err_en_US, 53 typeSymbol_.name()); 54 return; 55 } 56 57 // Parameters of the most deeply nested "base class" come first when the 58 // derived type is an extension. 59 auto parameterNames{OrderParameterNames(typeSymbol_)}; 60 auto parameterDecls{OrderParameterDeclarations(typeSymbol_)}; 61 auto nextNameIter{parameterNames.begin()}; 62 RawParameters raw{std::move(rawParameters_)}; 63 for (auto &[maybeKeyword, value] : raw) { 64 SourceName name; 65 common::TypeParamAttr attr{common::TypeParamAttr::Kind}; 66 if (maybeKeyword) { 67 name = maybeKeyword->v.source; 68 auto it{std::find_if(parameterDecls.begin(), parameterDecls.end(), 69 [&](const Symbol &symbol) { return symbol.name() == name; })}; 70 if (it == parameterDecls.end()) { 71 messages.Say(name, 72 "'%s' is not the name of a parameter for derived type '%s'"_err_en_US, 73 name, typeSymbol_.name()); 74 } else { 75 // Resolve the keyword's symbol 76 maybeKeyword->v.symbol = const_cast<Symbol *>(&it->get()); 77 attr = it->get().get<TypeParamDetails>().attr(); 78 } 79 } else if (nextNameIter != parameterNames.end()) { 80 name = *nextNameIter++; 81 auto it{std::find_if(parameterDecls.begin(), parameterDecls.end(), 82 [&](const Symbol &symbol) { return symbol.name() == name; })}; 83 if (it == parameterDecls.end()) { 84 break; 85 } 86 attr = it->get().get<TypeParamDetails>().attr(); 87 } else { 88 messages.Say(name_, 89 "Too many type parameters given for derived type '%s'"_err_en_US, 90 typeSymbol_.name()); 91 break; 92 } 93 if (FindParameter(name)) { 94 messages.Say(name_, 95 "Multiple values given for type parameter '%s'"_err_en_US, name); 96 } else { 97 value.set_attr(attr); 98 AddParamValue(name, std::move(value)); 99 } 100 } 101 } 102 103 void DerivedTypeSpec::EvaluateParameters(SemanticsContext &context) { 104 evaluate::FoldingContext &foldingContext{context.foldingContext()}; 105 CookParameters(foldingContext); 106 if (evaluated_) { 107 return; 108 } 109 evaluated_ = true; 110 auto &messages{foldingContext.messages()}; 111 112 // Fold the explicit type parameter value expressions first. Do not 113 // fold them within the scope of the derived type being instantiated; 114 // these expressions cannot use its type parameters. Convert the values 115 // of the expressions to the declared types of the type parameters. 116 auto parameterDecls{OrderParameterDeclarations(typeSymbol_)}; 117 for (const Symbol &symbol : parameterDecls) { 118 const SourceName &name{symbol.name()}; 119 if (ParamValue * paramValue{FindParameter(name)}) { 120 if (const MaybeIntExpr & expr{paramValue->GetExplicit()}) { 121 if (auto converted{evaluate::ConvertToType(symbol, SomeExpr{*expr})}) { 122 SomeExpr folded{ 123 evaluate::Fold(foldingContext, std::move(*converted))}; 124 if (auto *intExpr{std::get_if<SomeIntExpr>(&folded.u)}) { 125 paramValue->SetExplicit(std::move(*intExpr)); 126 continue; 127 } 128 } 129 if (!context.HasError(symbol)) { 130 evaluate::SayWithDeclaration(messages, symbol, 131 "Value of type parameter '%s' (%s) is not convertible to its" 132 " type"_err_en_US, 133 name, expr->AsFortran()); 134 } 135 } 136 } 137 } 138 139 // Default initialization expressions for the derived type's parameters 140 // may reference other parameters so long as the declaration precedes the 141 // use in the expression (10.1.12). This is not necessarily the same 142 // order as "type parameter order" (7.5.3.2). 143 // Type parameter default value expressions are folded in declaration order 144 // within the scope of the derived type so that the values of earlier type 145 // parameters are available for use in the default initialization 146 // expressions of later parameters. 147 auto restorer{foldingContext.WithPDTInstance(*this)}; 148 for (const Symbol &symbol : parameterDecls) { 149 const SourceName &name{symbol.name()}; 150 if (!FindParameter(name)) { 151 const TypeParamDetails &details{symbol.get<TypeParamDetails>()}; 152 if (details.init()) { 153 auto expr{evaluate::Fold(foldingContext, SomeExpr{*details.init()})}; 154 AddParamValue(name, 155 ParamValue{ 156 std::move(std::get<SomeIntExpr>(expr.u)), details.attr()}); 157 } else if (!context.HasError(symbol)) { 158 messages.Say(name_, 159 "Type parameter '%s' lacks a value and has no default"_err_en_US, 160 name); 161 } 162 } 163 } 164 } 165 166 void DerivedTypeSpec::AddParamValue(SourceName name, ParamValue &&value) { 167 CHECK(cooked_); 168 auto pair{parameters_.insert(std::make_pair(name, std::move(value)))}; 169 CHECK(pair.second); // name was not already present 170 } 171 172 bool DerivedTypeSpec::MightBeParameterized() const { 173 return !cooked_ || !parameters_.empty(); 174 } 175 176 bool DerivedTypeSpec::IsForwardReferenced() const { 177 return typeSymbol_.get<DerivedTypeDetails>().isForwardReferenced(); 178 } 179 180 bool DerivedTypeSpec::HasDefaultInitialization(bool ignoreAllocatable) const { 181 DirectComponentIterator components{*this}; 182 return bool{std::find_if( 183 components.begin(), components.end(), [&](const Symbol &component) { 184 return IsInitialized(component, true, ignoreAllocatable); 185 })}; 186 } 187 188 bool DerivedTypeSpec::HasDestruction() const { 189 if (!typeSymbol().get<DerivedTypeDetails>().finals().empty()) { 190 return true; 191 } 192 DirectComponentIterator components{*this}; 193 return bool{std::find_if( 194 components.begin(), components.end(), [&](const Symbol &component) { 195 return IsDestructible(component, &typeSymbol()); 196 })}; 197 } 198 199 ParamValue *DerivedTypeSpec::FindParameter(SourceName target) { 200 return const_cast<ParamValue *>( 201 const_cast<const DerivedTypeSpec *>(this)->FindParameter(target)); 202 } 203 204 class InstantiateHelper { 205 public: 206 InstantiateHelper(Scope &scope) : scope_{scope} {} 207 // Instantiate components from fromScope into scope_ 208 void InstantiateComponents(const Scope &); 209 210 private: 211 SemanticsContext &context() const { return scope_.context(); } 212 evaluate::FoldingContext &foldingContext() { 213 return context().foldingContext(); 214 } 215 template <typename A> A Fold(A &&expr) { 216 return evaluate::Fold(foldingContext(), std::move(expr)); 217 } 218 void InstantiateComponent(const Symbol &); 219 const DeclTypeSpec *InstantiateType(const Symbol &); 220 const DeclTypeSpec &InstantiateIntrinsicType( 221 SourceName, const DeclTypeSpec &); 222 DerivedTypeSpec CreateDerivedTypeSpec(const DerivedTypeSpec &, bool); 223 224 Scope &scope_; 225 }; 226 227 static int PlumbPDTInstantiationDepth(const Scope *scope) { 228 int depth{0}; 229 while (scope->IsParameterizedDerivedTypeInstantiation()) { 230 ++depth; 231 scope = &scope->parent(); 232 } 233 return depth; 234 } 235 236 // Completes component derived type instantiation and initializer folding 237 // for a non-parameterized derived type Scope. 238 static void InstantiateNonPDTScope(Scope &typeScope, Scope &containingScope) { 239 auto &context{containingScope.context()}; 240 auto &foldingContext{context.foldingContext()}; 241 for (auto &pair : typeScope) { 242 Symbol &symbol{*pair.second}; 243 if (DeclTypeSpec * type{symbol.GetType()}) { 244 if (DerivedTypeSpec * derived{type->AsDerived()}) { 245 if (!(derived->IsForwardReferenced() && 246 IsAllocatableOrPointer(symbol))) { 247 derived->Instantiate(containingScope); 248 } 249 } 250 } 251 if (!IsPointer(symbol)) { 252 if (auto *object{symbol.detailsIf<ObjectEntityDetails>()}) { 253 if (MaybeExpr & init{object->init()}) { 254 auto restorer{foldingContext.messages().SetLocation(symbol.name())}; 255 init = evaluate::NonPointerInitializationExpr( 256 symbol, std::move(*init), foldingContext); 257 } 258 } 259 } 260 } 261 ComputeOffsets(context, typeScope); 262 } 263 264 void DerivedTypeSpec::Instantiate(Scope &containingScope) { 265 if (instantiated_) { 266 return; 267 } 268 instantiated_ = true; 269 auto &context{containingScope.context()}; 270 auto &foldingContext{context.foldingContext()}; 271 if (IsForwardReferenced()) { 272 foldingContext.messages().Say(typeSymbol_.name(), 273 "The derived type '%s' was forward-referenced but not defined"_err_en_US, 274 typeSymbol_.name()); 275 context.SetError(typeSymbol_); 276 return; 277 } 278 EvaluateParameters(context); 279 const Scope &typeScope{DEREF(typeSymbol_.scope())}; 280 if (!MightBeParameterized()) { 281 scope_ = &typeScope; 282 if (typeScope.derivedTypeSpec()) { 283 CHECK(*this == *typeScope.derivedTypeSpec()); 284 } else { 285 Scope &mutableTypeScope{const_cast<Scope &>(typeScope)}; 286 mutableTypeScope.set_derivedTypeSpec(*this); 287 InstantiateNonPDTScope(mutableTypeScope, containingScope); 288 } 289 return; 290 } 291 // New PDT instantiation. Create a new scope and populate it 292 // with components that have been specialized for this set of 293 // parameters. 294 Scope &newScope{containingScope.MakeScope(Scope::Kind::DerivedType)}; 295 newScope.set_derivedTypeSpec(*this); 296 ReplaceScope(newScope); 297 auto restorer{foldingContext.WithPDTInstance(*this)}; 298 std::string desc{typeSymbol_.name().ToString()}; 299 char sep{'('}; 300 for (const Symbol &symbol : OrderParameterDeclarations(typeSymbol_)) { 301 const SourceName &name{symbol.name()}; 302 if (typeScope.find(symbol.name()) != typeScope.end()) { 303 // This type parameter belongs to the derived type itself, not to 304 // one of its ancestors. Put the type parameter expression value 305 // into the new scope as the initialization value for the parameter. 306 if (ParamValue * paramValue{FindParameter(name)}) { 307 const TypeParamDetails &details{symbol.get<TypeParamDetails>()}; 308 paramValue->set_attr(details.attr()); 309 if (MaybeIntExpr expr{paramValue->GetExplicit()}) { 310 if (auto folded{evaluate::NonPointerInitializationExpr(symbol, 311 SomeExpr{std::move(*expr)}, foldingContext, &newScope)}) { 312 desc += sep; 313 desc += name.ToString(); 314 desc += '='; 315 desc += folded->AsFortran(); 316 sep = ','; 317 TypeParamDetails instanceDetails{details.attr()}; 318 if (const DeclTypeSpec * type{details.type()}) { 319 instanceDetails.set_type(*type); 320 } 321 instanceDetails.set_init( 322 std::move(DEREF(evaluate::UnwrapExpr<SomeIntExpr>(*folded)))); 323 newScope.try_emplace(name, std::move(instanceDetails)); 324 } 325 } 326 } 327 } 328 } 329 parser::Message *contextMessage{nullptr}; 330 if (sep != '(') { 331 desc += ')'; 332 contextMessage = new parser::Message{foldingContext.messages().at(), 333 "instantiation of parameterized derived type '%s'"_en_US, desc}; 334 if (auto outer{containingScope.instantiationContext()}) { 335 contextMessage->SetContext(outer.get()); 336 } 337 newScope.set_instantiationContext(contextMessage); 338 } 339 // Instantiate every non-parameter symbol from the original derived 340 // type's scope into the new instance. 341 newScope.AddSourceRange(typeScope.sourceRange()); 342 auto restorer2{foldingContext.messages().SetContext(contextMessage)}; 343 if (PlumbPDTInstantiationDepth(&containingScope) > 100) { 344 foldingContext.messages().Say( 345 "Too many recursive parameterized derived type instantiations"_err_en_US); 346 } else { 347 InstantiateHelper{newScope}.InstantiateComponents(typeScope); 348 } 349 } 350 351 void InstantiateHelper::InstantiateComponents(const Scope &fromScope) { 352 for (const auto &pair : fromScope) { 353 InstantiateComponent(*pair.second); 354 } 355 ComputeOffsets(context(), scope_); 356 } 357 358 void InstantiateHelper::InstantiateComponent(const Symbol &oldSymbol) { 359 auto pair{scope_.try_emplace( 360 oldSymbol.name(), oldSymbol.attrs(), common::Clone(oldSymbol.details()))}; 361 Symbol &newSymbol{*pair.first->second}; 362 if (!pair.second) { 363 // Symbol was already present in the scope, which can only happen 364 // in the case of type parameters. 365 CHECK(oldSymbol.has<TypeParamDetails>()); 366 return; 367 } 368 newSymbol.flags() = oldSymbol.flags(); 369 if (auto *details{newSymbol.detailsIf<ObjectEntityDetails>()}) { 370 if (const DeclTypeSpec * newType{InstantiateType(newSymbol)}) { 371 details->ReplaceType(*newType); 372 } 373 for (ShapeSpec &dim : details->shape()) { 374 if (dim.lbound().isExplicit()) { 375 dim.lbound().SetExplicit(Fold(std::move(dim.lbound().GetExplicit()))); 376 } 377 if (dim.ubound().isExplicit()) { 378 dim.ubound().SetExplicit(Fold(std::move(dim.ubound().GetExplicit()))); 379 } 380 } 381 for (ShapeSpec &dim : details->coshape()) { 382 if (dim.lbound().isExplicit()) { 383 dim.lbound().SetExplicit(Fold(std::move(dim.lbound().GetExplicit()))); 384 } 385 if (dim.ubound().isExplicit()) { 386 dim.ubound().SetExplicit(Fold(std::move(dim.ubound().GetExplicit()))); 387 } 388 } 389 if (MaybeExpr & init{details->init()}) { 390 // Non-pointer components with default initializers are 391 // processed now so that those default initializers can be used 392 // in PARAMETER structure constructors. 393 auto restorer{foldingContext().messages().SetLocation(newSymbol.name())}; 394 init = IsPointer(newSymbol) 395 ? Fold(std::move(*init)) 396 : evaluate::NonPointerInitializationExpr( 397 newSymbol, std::move(*init), foldingContext()); 398 } 399 } else if (auto *procDetails{newSymbol.detailsIf<ProcEntityDetails>()}) { 400 // We have a procedure pointer. Instantiate its return type 401 if (const DeclTypeSpec * returnType{InstantiateType(newSymbol)}) { 402 ProcInterface &interface{procDetails->interface()}; 403 if (!interface.symbol()) { 404 // Don't change the type for interfaces based on symbols 405 interface.set_type(*returnType); 406 } 407 } 408 } 409 } 410 411 const DeclTypeSpec *InstantiateHelper::InstantiateType(const Symbol &symbol) { 412 const DeclTypeSpec *type{symbol.GetType()}; 413 if (!type) { 414 return nullptr; // error has occurred 415 } else if (const DerivedTypeSpec * spec{type->AsDerived()}) { 416 return &FindOrInstantiateDerivedType(scope_, 417 CreateDerivedTypeSpec(*spec, symbol.test(Symbol::Flag::ParentComp)), 418 type->category()); 419 } else if (type->AsIntrinsic()) { 420 return &InstantiateIntrinsicType(symbol.name(), *type); 421 } else if (type->category() == DeclTypeSpec::ClassStar) { 422 return type; 423 } else { 424 common::die("InstantiateType: %s", type->AsFortran().c_str()); 425 } 426 } 427 428 /// Fold explicit length parameters of character components when the explicit 429 /// expression is a constant expression (if it only depends on KIND parameters). 430 /// Do not fold `character(len=pdt_length)`, even if the length parameter is 431 /// constant in the pdt instantiation, in order to avoid losing the information 432 /// that the character component is automatic (and must be a descriptor). 433 static ParamValue FoldCharacterLength(evaluate::FoldingContext &foldingContext, 434 const CharacterTypeSpec &characterSpec) { 435 if (const auto &len{characterSpec.length().GetExplicit()}) { 436 if (evaluate::IsConstantExpr(*len)) { 437 return ParamValue{evaluate::Fold(foldingContext, common::Clone(*len)), 438 common::TypeParamAttr::Len}; 439 } 440 } 441 return characterSpec.length(); 442 } 443 444 // Apply type parameter values to an intrinsic type spec. 445 const DeclTypeSpec &InstantiateHelper::InstantiateIntrinsicType( 446 SourceName symbolName, const DeclTypeSpec &spec) { 447 const IntrinsicTypeSpec &intrinsic{DEREF(spec.AsIntrinsic())}; 448 if (spec.category() != DeclTypeSpec::Character && 449 evaluate::IsActuallyConstant(intrinsic.kind())) { 450 return spec; // KIND is already a known constant 451 } 452 // The expression was not originally constant, but now it must be so 453 // in the context of a parameterized derived type instantiation. 454 KindExpr copy{Fold(common::Clone(intrinsic.kind()))}; 455 int kind{context().GetDefaultKind(intrinsic.category())}; 456 if (auto value{evaluate::ToInt64(copy)}) { 457 if (evaluate::IsValidKindOfIntrinsicType(intrinsic.category(), *value)) { 458 kind = *value; 459 } else { 460 foldingContext().messages().Say(symbolName, 461 "KIND parameter value (%jd) of intrinsic type %s " 462 "did not resolve to a supported value"_err_en_US, 463 *value, 464 parser::ToUpperCaseLetters(EnumToString(intrinsic.category()))); 465 } 466 } 467 switch (spec.category()) { 468 case DeclTypeSpec::Numeric: 469 return scope_.MakeNumericType(intrinsic.category(), KindExpr{kind}); 470 case DeclTypeSpec::Logical: 471 return scope_.MakeLogicalType(KindExpr{kind}); 472 case DeclTypeSpec::Character: 473 return scope_.MakeCharacterType( 474 FoldCharacterLength(foldingContext(), spec.characterTypeSpec()), 475 KindExpr{kind}); 476 default: 477 CRASH_NO_CASE; 478 } 479 } 480 481 DerivedTypeSpec InstantiateHelper::CreateDerivedTypeSpec( 482 const DerivedTypeSpec &spec, bool isParentComp) { 483 DerivedTypeSpec result{spec}; 484 result.CookParameters(foldingContext()); // enables AddParamValue() 485 if (isParentComp) { 486 // Forward any explicit type parameter values from the 487 // derived type spec under instantiation that define type parameters 488 // of the parent component to the derived type spec of the 489 // parent component. 490 const DerivedTypeSpec &instanceSpec{DEREF(foldingContext().pdtInstance())}; 491 for (const auto &[name, value] : instanceSpec.parameters()) { 492 if (scope_.find(name) == scope_.end()) { 493 result.AddParamValue(name, ParamValue{value}); 494 } 495 } 496 } 497 return result; 498 } 499 500 std::string DerivedTypeSpec::AsFortran() const { 501 std::string buf; 502 llvm::raw_string_ostream ss{buf}; 503 ss << name_; 504 if (!rawParameters_.empty()) { 505 CHECK(parameters_.empty()); 506 ss << '('; 507 bool first = true; 508 for (const auto &[maybeKeyword, value] : rawParameters_) { 509 if (first) { 510 first = false; 511 } else { 512 ss << ','; 513 } 514 if (maybeKeyword) { 515 ss << maybeKeyword->v.source.ToString() << '='; 516 } 517 ss << value.AsFortran(); 518 } 519 ss << ')'; 520 } else if (!parameters_.empty()) { 521 ss << '('; 522 bool first = true; 523 for (const auto &[name, value] : parameters_) { 524 if (first) { 525 first = false; 526 } else { 527 ss << ','; 528 } 529 ss << name.ToString() << '=' << value.AsFortran(); 530 } 531 ss << ')'; 532 } 533 return ss.str(); 534 } 535 536 llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const DerivedTypeSpec &x) { 537 return o << x.AsFortran(); 538 } 539 540 Bound::Bound(common::ConstantSubscript bound) : expr_{bound} {} 541 542 llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const Bound &x) { 543 if (x.isStar()) { 544 o << '*'; 545 } else if (x.isColon()) { 546 o << ':'; 547 } else if (x.expr_) { 548 x.expr_->AsFortran(o); 549 } else { 550 o << "<no-expr>"; 551 } 552 return o; 553 } 554 555 llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const ShapeSpec &x) { 556 if (x.lb_.isStar()) { 557 CHECK(x.ub_.isStar()); 558 o << ".."; 559 } else { 560 if (!x.lb_.isColon()) { 561 o << x.lb_; 562 } 563 o << ':'; 564 if (!x.ub_.isColon()) { 565 o << x.ub_; 566 } 567 } 568 return o; 569 } 570 571 llvm::raw_ostream &operator<<( 572 llvm::raw_ostream &os, const ArraySpec &arraySpec) { 573 char sep{'('}; 574 for (auto &shape : arraySpec) { 575 os << sep << shape; 576 sep = ','; 577 } 578 if (sep == ',') { 579 os << ')'; 580 } 581 return os; 582 } 583 584 ParamValue::ParamValue(MaybeIntExpr &&expr, common::TypeParamAttr attr) 585 : attr_{attr}, expr_{std::move(expr)} {} 586 ParamValue::ParamValue(SomeIntExpr &&expr, common::TypeParamAttr attr) 587 : attr_{attr}, expr_{std::move(expr)} {} 588 ParamValue::ParamValue( 589 common::ConstantSubscript value, common::TypeParamAttr attr) 590 : ParamValue(SomeIntExpr{evaluate::Expr<evaluate::SubscriptInteger>{value}}, 591 attr) {} 592 593 void ParamValue::SetExplicit(SomeIntExpr &&x) { 594 category_ = Category::Explicit; 595 expr_ = std::move(x); 596 } 597 598 std::string ParamValue::AsFortran() const { 599 switch (category_) { 600 SWITCH_COVERS_ALL_CASES 601 case Category::Assumed: 602 return "*"; 603 case Category::Deferred: 604 return ":"; 605 case Category::Explicit: 606 if (expr_) { 607 std::string buf; 608 llvm::raw_string_ostream ss{buf}; 609 expr_->AsFortran(ss); 610 return ss.str(); 611 } else { 612 return ""; 613 } 614 } 615 } 616 617 llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const ParamValue &x) { 618 return o << x.AsFortran(); 619 } 620 621 IntrinsicTypeSpec::IntrinsicTypeSpec(TypeCategory category, KindExpr &&kind) 622 : category_{category}, kind_{std::move(kind)} { 623 CHECK(category != TypeCategory::Derived); 624 } 625 626 static std::string KindAsFortran(const KindExpr &kind) { 627 std::string buf; 628 llvm::raw_string_ostream ss{buf}; 629 if (auto k{evaluate::ToInt64(kind)}) { 630 ss << *k; // emit unsuffixed kind code 631 } else { 632 kind.AsFortran(ss); 633 } 634 return ss.str(); 635 } 636 637 std::string IntrinsicTypeSpec::AsFortran() const { 638 return parser::ToUpperCaseLetters(common::EnumToString(category_)) + '(' + 639 KindAsFortran(kind_) + ')'; 640 } 641 642 llvm::raw_ostream &operator<<( 643 llvm::raw_ostream &os, const IntrinsicTypeSpec &x) { 644 return os << x.AsFortran(); 645 } 646 647 std::string CharacterTypeSpec::AsFortran() const { 648 return "CHARACTER(" + length_.AsFortran() + ',' + KindAsFortran(kind()) + ')'; 649 } 650 651 llvm::raw_ostream &operator<<( 652 llvm::raw_ostream &os, const CharacterTypeSpec &x) { 653 return os << x.AsFortran(); 654 } 655 656 DeclTypeSpec::DeclTypeSpec(NumericTypeSpec &&typeSpec) 657 : category_{Numeric}, typeSpec_{std::move(typeSpec)} {} 658 DeclTypeSpec::DeclTypeSpec(LogicalTypeSpec &&typeSpec) 659 : category_{Logical}, typeSpec_{std::move(typeSpec)} {} 660 DeclTypeSpec::DeclTypeSpec(const CharacterTypeSpec &typeSpec) 661 : category_{Character}, typeSpec_{typeSpec} {} 662 DeclTypeSpec::DeclTypeSpec(CharacterTypeSpec &&typeSpec) 663 : category_{Character}, typeSpec_{std::move(typeSpec)} {} 664 DeclTypeSpec::DeclTypeSpec(Category category, const DerivedTypeSpec &typeSpec) 665 : category_{category}, typeSpec_{typeSpec} { 666 CHECK(category == TypeDerived || category == ClassDerived); 667 } 668 DeclTypeSpec::DeclTypeSpec(Category category, DerivedTypeSpec &&typeSpec) 669 : category_{category}, typeSpec_{std::move(typeSpec)} { 670 CHECK(category == TypeDerived || category == ClassDerived); 671 } 672 DeclTypeSpec::DeclTypeSpec(Category category) : category_{category} { 673 CHECK(category == TypeStar || category == ClassStar); 674 } 675 bool DeclTypeSpec::IsNumeric(TypeCategory tc) const { 676 return category_ == Numeric && numericTypeSpec().category() == tc; 677 } 678 bool DeclTypeSpec::IsSequenceType() const { 679 if (const DerivedTypeSpec * derivedType{AsDerived()}) { 680 const auto *typeDetails{ 681 derivedType->typeSymbol().detailsIf<DerivedTypeDetails>()}; 682 return typeDetails && typeDetails->sequence(); 683 } 684 return false; 685 } 686 687 const NumericTypeSpec &DeclTypeSpec::numericTypeSpec() const { 688 CHECK(category_ == Numeric); 689 return std::get<NumericTypeSpec>(typeSpec_); 690 } 691 const LogicalTypeSpec &DeclTypeSpec::logicalTypeSpec() const { 692 CHECK(category_ == Logical); 693 return std::get<LogicalTypeSpec>(typeSpec_); 694 } 695 bool DeclTypeSpec::operator==(const DeclTypeSpec &that) const { 696 return category_ == that.category_ && typeSpec_ == that.typeSpec_; 697 } 698 699 std::string DeclTypeSpec::AsFortran() const { 700 switch (category_) { 701 SWITCH_COVERS_ALL_CASES 702 case Numeric: 703 return numericTypeSpec().AsFortran(); 704 case Logical: 705 return logicalTypeSpec().AsFortran(); 706 case Character: 707 return characterTypeSpec().AsFortran(); 708 case TypeDerived: 709 if (derivedTypeSpec() 710 .typeSymbol() 711 .get<DerivedTypeDetails>() 712 .isDECStructure()) { 713 return "RECORD" + derivedTypeSpec().typeSymbol().name().ToString(); 714 } else { 715 return "TYPE(" + derivedTypeSpec().AsFortran() + ')'; 716 } 717 case ClassDerived: 718 return "CLASS(" + derivedTypeSpec().AsFortran() + ')'; 719 case TypeStar: 720 return "TYPE(*)"; 721 case ClassStar: 722 return "CLASS(*)"; 723 } 724 } 725 726 llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const DeclTypeSpec &x) { 727 return o << x.AsFortran(); 728 } 729 730 void ProcInterface::set_symbol(const Symbol &symbol) { 731 CHECK(!type_); 732 symbol_ = &symbol; 733 } 734 void ProcInterface::set_type(const DeclTypeSpec &type) { 735 CHECK(!symbol_); 736 type_ = &type; 737 } 738 739 } // namespace Fortran::semantics 740