1545 lines · cpp
1//===-- lib/Semantics/runtime-type-info.cpp ---------------------*- C++ -*-===//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/runtime-type-info.h"10#include "mod-file.h"11#include "flang/Evaluate/fold-designator.h"12#include "flang/Evaluate/fold.h"13#include "flang/Evaluate/tools.h"14#include "flang/Evaluate/type.h"15#include "flang/Optimizer/Support/InternalNames.h"16#include "flang/Semantics/scope.h"17#include "flang/Semantics/tools.h"18#include <functional>19#include <list>20#include <map>21#include <string>22 23// The symbols added by this code to various scopes in the program include:24// .b.TYPE.NAME - Bounds values for an array component25// .c.TYPE - TYPE(Component) descriptions for TYPE26// .di.TYPE.NAME - Data initialization for a component27// .dp.TYPE.NAME - Data pointer initialization for a component28// .dt.TYPE - TYPE(DerivedType) description for TYPE29// .kp.TYPE - KIND type parameter values for TYPE30// .lpk.TYPE - Integer kinds of LEN type parameter values31// .lv.TYPE.NAME - LEN type parameter values for a component's type32// .n.NAME - Character representation of a name33// .p.TYPE - TYPE(ProcPtrComponent) descriptions for TYPE34// .s.TYPE - TYPE(SpecialBinding) bindings for TYPE35// .v.TYPE - TYPE(Binding) bindings for TYPE36 37namespace Fortran::semantics {38 39static int FindLenParameterIndex(40 const SymbolVector ¶meters, const Symbol &symbol) {41 int lenIndex{0};42 for (SymbolRef ref : parameters) {43 if (&*ref == &symbol) {44 return lenIndex;45 }46 if (auto attr{ref->get<TypeParamDetails>().attr()};47 attr && *attr == common::TypeParamAttr::Len) {48 ++lenIndex;49 }50 }51 DIE("Length type parameter not found in parameter order");52 return -1;53}54 55class RuntimeTableBuilder {56public:57 RuntimeTableBuilder(SemanticsContext &, RuntimeDerivedTypeTables &);58 void DescribeTypes(Scope &scope, bool inSchemata);59 60private:61 const Symbol *DescribeType(Scope &, bool wantUninstantiatedPDT);62 const Symbol &GetSchemaSymbol(const char *) const;63 const DeclTypeSpec &GetSchema(const char *) const;64 SomeExpr GetEnumValue(const char *) const;65 Symbol &CreateObject(const std::string &, const DeclTypeSpec &, Scope &);66 // The names of created symbols are saved in and owned by the67 // RuntimeDerivedTypeTables instance returned by68 // BuildRuntimeDerivedTypeTables() so that references to those names remain69 // valid for lowering.70 SourceName SaveObjectName(const std::string &);71 SomeExpr SaveNameAsPointerTarget(Scope &, const std::string &);72 const SymbolVector *GetTypeParameters(const Symbol &);73 evaluate::StructureConstructor DescribeComponent(const Symbol &,74 const ObjectEntityDetails &, Scope &, Scope &,75 const std::string &distinctName, const SymbolVector *parameters);76 evaluate::StructureConstructor DescribeComponent(77 const Symbol &, const ProcEntityDetails &, Scope &);78 bool InitializeDataPointer(evaluate::StructureConstructorValues &,79 const Symbol &symbol, const ObjectEntityDetails &object, Scope &scope,80 Scope &dtScope, const std::string &distinctName);81 evaluate::StructureConstructor PackageIntValue(82 const SomeExpr &genre, std::int64_t = 0) const;83 SomeExpr PackageIntValueExpr(const SomeExpr &genre, std::int64_t = 0) const;84 std::vector<evaluate::StructureConstructor> DescribeBindings(85 const Scope &dtScope, Scope &, const SymbolVector &bindings);86 std::map<int, evaluate::StructureConstructor> DescribeSpecialGenerics(87 const Scope &dtScope, const Scope &thisScope, const DerivedTypeSpec *,88 const SymbolVector &bindings) const;89 void DescribeSpecialGeneric(const GenericDetails &,90 std::map<int, evaluate::StructureConstructor> &, const Scope &,91 const DerivedTypeSpec *, const SymbolVector &bindings) const;92 void DescribeSpecialProc(std::map<int, evaluate::StructureConstructor> &,93 const Symbol &specificOrBinding, bool isAssignment, bool isFinal,94 std::optional<common::DefinedIo>, const Scope *, const DerivedTypeSpec *,95 const SymbolVector *bindings) const;96 void IncorporateDefinedIoGenericInterfaces(97 std::map<int, evaluate::StructureConstructor> &, common::DefinedIo,98 const Scope *, const DerivedTypeSpec *);99 100 // Instantiated for ParamValue and Bound101 template <typename A>102 evaluate::StructureConstructor GetValue(103 const A &x, const SymbolVector *parameters) {104 if (x.isExplicit()) {105 return GetValue(x.GetExplicit(), parameters);106 } else {107 return PackageIntValue(deferredEnum_);108 }109 }110 111 // Specialization for optional<Expr<SomeInteger and SubscriptInteger>>112 template <typename T>113 evaluate::StructureConstructor GetValue(114 const std::optional<evaluate::Expr<T>> &expr,115 const SymbolVector *parameters) {116 if (auto constValue{evaluate::ToInt64(expr)}) {117 return PackageIntValue(explicitEnum_, *constValue);118 }119 if (expr) {120 if (parameters) {121 if (const Symbol * lenParam{evaluate::ExtractBareLenParameter(*expr)}) {122 return PackageIntValue(123 lenParameterEnum_, FindLenParameterIndex(*parameters, *lenParam));124 }125 }126 // TODO: Replace a specification expression requiring actual operations127 // with a reference to a new anonymous LEN type parameter whose default128 // value captures the expression. This replacement must take place when129 // the type is declared so that the new LEN type parameters appear in130 // all instantiations and structure constructors.131 context_.Say(location_,132 "derived type specification expression '%s' that is neither constant nor a length type parameter"_todo_en_US,133 expr->AsFortran());134 }135 return PackageIntValue(deferredEnum_);136 }137 138 SemanticsContext &context_;139 RuntimeDerivedTypeTables &tables_;140 std::map<const Symbol *, SymbolVector> orderedTypeParameters_;141 142 const DeclTypeSpec &derivedTypeSchema_; // TYPE(DerivedType)143 const DeclTypeSpec &componentSchema_; // TYPE(Component)144 const DeclTypeSpec &procPtrSchema_; // TYPE(ProcPtrComponent)145 const DeclTypeSpec &valueSchema_; // TYPE(Value)146 const DeclTypeSpec &bindingSchema_; // TYPE(Binding)147 const DeclTypeSpec &specialSchema_; // TYPE(SpecialBinding)148 SomeExpr deferredEnum_; // Value::Genre::Deferred149 SomeExpr explicitEnum_; // Value::Genre::Explicit150 SomeExpr lenParameterEnum_; // Value::Genre::LenParameter151 SomeExpr scalarAssignmentEnum_; // SpecialBinding::Which::ScalarAssignment152 SomeExpr153 elementalAssignmentEnum_; // SpecialBinding::Which::ElementalAssignment154 SomeExpr readFormattedEnum_; // SpecialBinding::Which::ReadFormatted155 SomeExpr readUnformattedEnum_; // SpecialBinding::Which::ReadUnformatted156 SomeExpr writeFormattedEnum_; // SpecialBinding::Which::WriteFormatted157 SomeExpr writeUnformattedEnum_; // SpecialBinding::Which::WriteUnformatted158 SomeExpr elementalFinalEnum_; // SpecialBinding::Which::ElementalFinal159 SomeExpr assumedRankFinalEnum_; // SpecialBinding::Which::AssumedRankFinal160 SomeExpr scalarFinalEnum_; // SpecialBinding::Which::ScalarFinal161 parser::CharBlock location_;162 std::set<const Scope *> ignoreScopes_;163};164 165RuntimeTableBuilder::RuntimeTableBuilder(166 SemanticsContext &c, RuntimeDerivedTypeTables &t)167 : context_{c}, tables_{t}, derivedTypeSchema_{GetSchema("derivedtype")},168 componentSchema_{GetSchema("component")},169 procPtrSchema_{GetSchema("procptrcomponent")},170 valueSchema_{GetSchema("value")},171 bindingSchema_{GetSchema(bindingDescCompName)},172 specialSchema_{GetSchema("specialbinding")},173 deferredEnum_{GetEnumValue("deferred")},174 explicitEnum_{GetEnumValue("explicit")},175 lenParameterEnum_{GetEnumValue("lenparameter")},176 scalarAssignmentEnum_{GetEnumValue("scalarassignment")},177 elementalAssignmentEnum_{GetEnumValue("elementalassignment")},178 readFormattedEnum_{GetEnumValue("readformatted")},179 readUnformattedEnum_{GetEnumValue("readunformatted")},180 writeFormattedEnum_{GetEnumValue("writeformatted")},181 writeUnformattedEnum_{GetEnumValue("writeunformatted")},182 elementalFinalEnum_{GetEnumValue("elementalfinal")},183 assumedRankFinalEnum_{GetEnumValue("assumedrankfinal")},184 scalarFinalEnum_{GetEnumValue("scalarfinal")} {185 ignoreScopes_.insert(tables_.schemata);186}187 188static void SetReadOnlyCompilerCreatedFlags(Symbol &symbol) {189 symbol.set(Symbol::Flag::CompilerCreated);190 // Runtime type info symbols may have types that are incompatible with the191 // PARAMETER attribute (the main issue is that they may be TARGET, and normal192 // Fortran parameters cannot be TARGETs).193 if (symbol.has<semantics::ObjectEntityDetails>() ||194 symbol.has<semantics::ProcEntityDetails>()) {195 symbol.set(Symbol::Flag::ReadOnly);196 }197}198 199// Save an arbitrarily shaped array constant of some derived type200// as an initialized data object in a scope.201static SomeExpr SaveDerivedPointerTarget(Scope &scope, SourceName name,202 std::vector<evaluate::StructureConstructor> &&x,203 evaluate::ConstantSubscripts &&shape) {204 if (x.empty()) {205 return SomeExpr{evaluate::NullPointer{}};206 } else {207 auto dyType{x.front().GetType()};208 const auto &derivedType{dyType.GetDerivedTypeSpec()};209 ObjectEntityDetails object;210 DeclTypeSpec typeSpec{DeclTypeSpec::TypeDerived, derivedType};211 if (const DeclTypeSpec * spec{scope.FindType(typeSpec)}) {212 object.set_type(*spec);213 } else {214 object.set_type(scope.MakeDerivedType(215 DeclTypeSpec::TypeDerived, common::Clone(derivedType)));216 }217 if (!shape.empty()) {218 ArraySpec arraySpec;219 for (auto n : shape) {220 arraySpec.push_back(ShapeSpec::MakeExplicit(Bound{0}, Bound{n - 1}));221 }222 object.set_shape(arraySpec);223 }224 object.set_init(225 evaluate::AsGenericExpr(evaluate::Constant<evaluate::SomeDerived>{226 derivedType, std::move(x), std::move(shape)}));227 Symbol &symbol{*scope228 .try_emplace(name, Attrs{Attr::TARGET, Attr::SAVE},229 std::move(object))230 .first->second};231 SetReadOnlyCompilerCreatedFlags(symbol);232 return evaluate::AsGenericExpr(233 evaluate::Designator<evaluate::SomeDerived>{symbol});234 }235}236 237void RuntimeTableBuilder::DescribeTypes(Scope &scope, bool inSchemata) {238 inSchemata |= ignoreScopes_.find(&scope) != ignoreScopes_.end();239 if (scope.IsDerivedType()) {240 if (!inSchemata) { // don't loop trying to describe a schema241 DescribeType(scope, /*wantUninstantiatedPDT=*/false);242 }243 } else {244 scope.InstantiateDerivedTypes();245 }246 for (Scope &child : scope.children()) {247 DescribeTypes(child, inSchemata);248 }249}250 251// Returns derived type instantiation's parameters in declaration order252const SymbolVector *RuntimeTableBuilder::GetTypeParameters(253 const Symbol &symbol) {254 auto iter{orderedTypeParameters_.find(&symbol)};255 if (iter != orderedTypeParameters_.end()) {256 return &iter->second;257 } else {258 return &orderedTypeParameters_259 .emplace(&symbol, OrderParameterDeclarations(symbol))260 .first->second;261 }262}263 264static Scope &GetContainingNonDerivedScope(Scope &scope) {265 Scope *p{&scope};266 while (p->IsDerivedType()) {267 p = &p->parent();268 }269 return *p;270}271 272static const Symbol &GetSchemaField(273 const DerivedTypeSpec &derived, const std::string &name) {274 const Scope &scope{275 DEREF(derived.scope() ? derived.scope() : derived.typeSymbol().scope())};276 auto iter{scope.find(SourceName(name))};277 CHECK(iter != scope.end());278 return *iter->second;279}280 281static const Symbol &GetSchemaField(282 const DeclTypeSpec &derived, const std::string &name) {283 return GetSchemaField(DEREF(derived.AsDerived()), name);284}285 286static evaluate::StructureConstructorValues &AddValue(287 evaluate::StructureConstructorValues &values, const DeclTypeSpec &spec,288 const std::string &name, SomeExpr &&x) {289 values.emplace(GetSchemaField(spec, name), std::move(x));290 return values;291}292 293static evaluate::StructureConstructorValues &AddValue(294 evaluate::StructureConstructorValues &values, const DeclTypeSpec &spec,295 const std::string &name, const SomeExpr &x) {296 values.emplace(GetSchemaField(spec, name), x);297 return values;298}299 300static SomeExpr IntToExpr(std::int64_t n) {301 return evaluate::AsGenericExpr(evaluate::ExtentExpr{n});302}303 304static evaluate::StructureConstructor Structure(305 const DeclTypeSpec &spec, evaluate::StructureConstructorValues &&values) {306 return {DEREF(spec.AsDerived()), std::move(values)};307}308 309static SomeExpr StructureExpr(evaluate::StructureConstructor &&x) {310 return SomeExpr{evaluate::Expr<evaluate::SomeDerived>{std::move(x)}};311}312 313static int GetIntegerKind(const Symbol &symbol, bool canBeUninstantiated) {314 auto dyType{evaluate::DynamicType::From(symbol)};315 CHECK((dyType && dyType->category() == TypeCategory::Integer) ||316 symbol.owner().context().HasError(symbol) || canBeUninstantiated);317 return dyType && dyType->category() == TypeCategory::Integer318 ? dyType->kind()319 : symbol.owner().context().GetDefaultKind(TypeCategory::Integer);320}321 322// Save a rank-1 array constant of some numeric type as an323// initialized data object in a scope.324template <typename T>325static SomeExpr SaveNumericPointerTarget(326 Scope &scope, SourceName name, std::vector<typename T::Scalar> &&x) {327 if (x.empty()) {328 return SomeExpr{evaluate::NullPointer{}};329 } else {330 ObjectEntityDetails object;331 if (const auto *spec{scope.FindType(332 DeclTypeSpec{NumericTypeSpec{T::category, KindExpr{T::kind}}})}) {333 object.set_type(*spec);334 } else {335 object.set_type(scope.MakeNumericType(T::category, KindExpr{T::kind}));336 }337 auto elements{static_cast<evaluate::ConstantSubscript>(x.size())};338 ArraySpec arraySpec;339 arraySpec.push_back(ShapeSpec::MakeExplicit(Bound{0}, Bound{elements - 1}));340 object.set_shape(arraySpec);341 object.set_init(evaluate::AsGenericExpr(evaluate::Constant<T>{342 std::move(x), evaluate::ConstantSubscripts{elements}}));343 Symbol &symbol{*scope344 .try_emplace(name, Attrs{Attr::TARGET, Attr::SAVE},345 std::move(object))346 .first->second};347 SetReadOnlyCompilerCreatedFlags(symbol);348 return evaluate::AsGenericExpr(349 evaluate::Expr<T>{evaluate::Designator<T>{symbol}});350 }351}352 353static SomeExpr SaveObjectInit(354 Scope &scope, SourceName name, const ObjectEntityDetails &object) {355 Symbol &symbol{*scope356 .try_emplace(name, Attrs{Attr::TARGET, Attr::SAVE},357 ObjectEntityDetails{object})358 .first->second};359 CHECK(symbol.get<ObjectEntityDetails>().init().has_value());360 SetReadOnlyCompilerCreatedFlags(symbol);361 return evaluate::AsGenericExpr(362 evaluate::Designator<evaluate::SomeDerived>{symbol});363}364 365template <int KIND> static SomeExpr IntExpr(std::int64_t n) {366 return evaluate::AsGenericExpr(367 evaluate::Constant<evaluate::Type<TypeCategory::Integer, KIND>>{n});368}369 370static std::optional<std::string> GetSuffixIfTypeKindParameters(371 const DerivedTypeSpec &derivedTypeSpec, const SymbolVector *parameters) {372 if (parameters) {373 std::optional<std::string> suffix;374 for (SymbolRef ref : *parameters) {375 const auto &tpd{ref->get<TypeParamDetails>()};376 if (tpd.attr() && *tpd.attr() == common::TypeParamAttr::Kind) {377 if (const auto *pv{derivedTypeSpec.FindParameter(ref->name())}) {378 if (pv->GetExplicit()) {379 if (auto instantiatedValue{evaluate::ToInt64(*pv->GetExplicit())}) {380 if (suffix.has_value()) {381 *suffix +=382 (fir::kNameSeparator + llvm::Twine(*instantiatedValue))383 .str();384 } else {385 suffix = (fir::kNameSeparator + llvm::Twine(*instantiatedValue))386 .str();387 }388 }389 }390 }391 }392 }393 return suffix;394 }395 return std::nullopt;396}397 398const Symbol *RuntimeTableBuilder::DescribeType(399 Scope &dtScope, bool wantUninstantiatedPDT) {400 if (const Symbol * info{dtScope.runtimeDerivedTypeDescription()}) {401 return info;402 }403 const DerivedTypeSpec *derivedTypeSpec{dtScope.derivedTypeSpec()};404 if (!derivedTypeSpec && !dtScope.IsDerivedTypeWithKindParameter() &&405 dtScope.symbol()) {406 // This derived type was declared (obviously, there's a Scope) but never407 // used in this compilation (no instantiated DerivedTypeSpec points here).408 // Create a DerivedTypeSpec now for it so that ComponentIterator409 // will work. This covers the case of a derived type that's declared in410 // a module but used only by clients and submodules, enabling the411 // run-time "no initialization needed here" flag to work.412 DerivedTypeSpec derived{dtScope.symbol()->name(), *dtScope.symbol()};413 if (const SymbolVector *414 lenParameters{GetTypeParameters(*dtScope.symbol())}) {415 // Create dummy deferred values for the length parameters so that the416 // DerivedTypeSpec is complete and can be used in helpers.417 for (SymbolRef lenParam : *lenParameters) {418 (void)lenParam;419 derived.AddRawParamValue(420 nullptr, ParamValue::Deferred(common::TypeParamAttr::Len));421 }422 derived.CookParameters(context_.foldingContext());423 }424 DeclTypeSpec &decl{425 dtScope.MakeDerivedType(DeclTypeSpec::TypeDerived, std::move(derived))};426 derivedTypeSpec = &decl.derivedTypeSpec();427 }428 const Symbol *dtSymbol{429 derivedTypeSpec ? &derivedTypeSpec->typeSymbol() : dtScope.symbol()};430 if (!dtSymbol) {431 return nullptr;432 }433 auto locationRestorer{common::ScopedSet(location_, dtSymbol->name())};434 // Check for an existing description that can be imported from a USE'd module435 std::string typeName{dtSymbol->name().ToString()};436 if (typeName.empty() ||437 (typeName.front() == '.' && !context_.IsTempName(typeName))) {438 return nullptr;439 }440 bool isPDTDefinitionWithKindParameters{441 !derivedTypeSpec && dtScope.IsDerivedTypeWithKindParameter()};442 bool isPDTInstantiation{derivedTypeSpec && &dtScope != dtSymbol->scope()};443 const SymbolVector *parameters{GetTypeParameters(*dtSymbol)};444 std::string distinctName{typeName};445 if (isPDTInstantiation) {446 // Only create new type descriptions for different kind parameter values.447 // Type with different length parameters/same kind parameters can all448 // share the same type description available in the current scope.449 if (auto suffix{450 GetSuffixIfTypeKindParameters(*derivedTypeSpec, parameters)}) {451 distinctName += *suffix;452 }453 } else if (isPDTDefinitionWithKindParameters && !wantUninstantiatedPDT) {454 return nullptr;455 }456 std::string dtDescName{(fir::kTypeDescriptorSeparator + distinctName).str()};457 Scope *dtSymbolScope{const_cast<Scope *>(dtSymbol->scope())};458 Scope &scope{459 GetContainingNonDerivedScope(dtSymbolScope ? *dtSymbolScope : dtScope)};460 if (const auto it{scope.find(SourceName{dtDescName})}; it != scope.end()) {461 dtScope.set_runtimeDerivedTypeDescription(*it->second);462 return &*it->second;463 }464 465 // Create a new description object before populating it so that mutual466 // references will work as pointer targets.467 Symbol &dtObject{CreateObject(dtDescName, derivedTypeSchema_, scope)};468 dtScope.set_runtimeDerivedTypeDescription(dtObject);469 evaluate::StructureConstructorValues dtValues;470 AddValue(dtValues, derivedTypeSchema_, "name"s,471 SaveNameAsPointerTarget(scope, typeName));472 if (!isPDTDefinitionWithKindParameters) {473 auto sizeInBytes{static_cast<common::ConstantSubscript>(dtScope.size())};474 if (auto alignment{dtScope.alignment().value_or(0)}) {475 sizeInBytes += alignment - 1;476 sizeInBytes /= alignment;477 sizeInBytes *= alignment;478 }479 AddValue(480 dtValues, derivedTypeSchema_, "sizeinbytes"s, IntToExpr(sizeInBytes));481 }482 if (const Symbol *483 uninstDescObject{isPDTInstantiation484 ? DescribeType(DEREF(const_cast<Scope *>(dtSymbol->scope())),485 /*wantUninstantiatedPDT=*/true)486 : nullptr}) {487 AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s,488 evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{489 evaluate::Designator<evaluate::SomeDerived>{490 DEREF(uninstDescObject)}}));491 } else {492 AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s,493 SomeExpr{evaluate::NullPointer{}});494 }495 using Int8 = evaluate::Type<TypeCategory::Integer, 8>;496 using Int1 = evaluate::Type<TypeCategory::Integer, 1>;497 std::vector<Int8::Scalar> kinds;498 std::vector<Int1::Scalar> lenKinds;499 if (parameters) {500 // Package the derived type's parameters in declaration order for501 // each category of parameter. KIND= type parameters are described502 // by their instantiated (or default) values, while LEN= type503 // parameters are described by their INTEGER kinds.504 for (SymbolRef ref : *parameters) {505 if (const auto *inst{dtScope.FindComponent(ref->name())}) {506 const auto &tpd{inst->get<TypeParamDetails>()};507 if (tpd.attr() && *tpd.attr() == common::TypeParamAttr::Kind) {508 auto value{evaluate::ToInt64(tpd.init()).value_or(0)};509 if (derivedTypeSpec) {510 if (const auto *pv{derivedTypeSpec->FindParameter(inst->name())}) {511 if (pv->GetExplicit()) {512 if (auto instantiatedValue{513 evaluate::ToInt64(*pv->GetExplicit())}) {514 value = *instantiatedValue;515 }516 }517 }518 }519 kinds.emplace_back(value);520 } else { // LEN= parameter521 lenKinds.emplace_back(522 GetIntegerKind(*inst, isPDTDefinitionWithKindParameters));523 }524 }525 }526 }527 AddValue(dtValues, derivedTypeSchema_, "kindparameter"s,528 SaveNumericPointerTarget<Int8>(scope,529 SaveObjectName((fir::kKindParameterSeparator + distinctName).str()),530 std::move(kinds)));531 AddValue(dtValues, derivedTypeSchema_, "lenparameterkind"s,532 SaveNumericPointerTarget<Int1>(scope,533 SaveObjectName((fir::kLenKindSeparator + distinctName).str()),534 std::move(lenKinds)));535 // Traverse the components of the derived type536 if (!isPDTDefinitionWithKindParameters) {537 std::vector<const Symbol *> dataComponentSymbols;538 std::vector<evaluate::StructureConstructor> procPtrComponents;539 for (const auto &pair : dtScope) {540 const Symbol &symbol{*pair.second};541 auto locationRestorer{common::ScopedSet(location_, symbol.name())};542 common::visit(543 common::visitors{544 [&](const TypeParamDetails &) {545 // already handled above in declaration order546 },547 [&](const ObjectEntityDetails &) {548 dataComponentSymbols.push_back(&symbol);549 },550 [&](const ProcEntityDetails &proc) {551 if (IsProcedurePointer(symbol)) {552 procPtrComponents.emplace_back(553 DescribeComponent(symbol, proc, scope));554 }555 },556 [&](const ProcBindingDetails &) { // handled in a later pass557 },558 [&](const GenericDetails &) { // ditto559 },560 [&](const auto &) {561 common::die(562 "unexpected details on symbol '%s' in derived type scope",563 symbol.name().ToString().c_str());564 },565 },566 symbol.details());567 }568 // Sort the data component symbols by offset before emitting them, placing569 // the parent component first if any.570 std::sort(dataComponentSymbols.begin(), dataComponentSymbols.end(),571 [](const Symbol *x, const Symbol *y) {572 return x->test(Symbol::Flag::ParentComp) || x->offset() < y->offset();573 });574 std::vector<evaluate::StructureConstructor> dataComponents;575 for (const Symbol *symbol : dataComponentSymbols) {576 auto locationRestorer{common::ScopedSet(location_, symbol->name())};577 dataComponents.emplace_back(578 DescribeComponent(*symbol, symbol->get<ObjectEntityDetails>(), scope,579 dtScope, distinctName, parameters));580 }581 AddValue(dtValues, derivedTypeSchema_, "component"s,582 SaveDerivedPointerTarget(scope,583 SaveObjectName((fir::kComponentSeparator + distinctName).str()),584 std::move(dataComponents),585 evaluate::ConstantSubscripts{586 static_cast<evaluate::ConstantSubscript>(587 dataComponents.size())}));588 AddValue(dtValues, derivedTypeSchema_, "procptr"s,589 SaveDerivedPointerTarget(scope,590 SaveObjectName((fir::kProcPtrSeparator + distinctName).str()),591 std::move(procPtrComponents),592 evaluate::ConstantSubscripts{593 static_cast<evaluate::ConstantSubscript>(594 procPtrComponents.size())}));595 // Compile the "vtable" of type-bound procedure bindings596 std::uint32_t specialBitSet{0};597 if (!dtSymbol->attrs().test(Attr::ABSTRACT)) {598 SymbolVector boundProcedures{CollectBindings(dtScope)};599 std::vector<evaluate::StructureConstructor> bindings{600 DescribeBindings(dtScope, scope, boundProcedures)};601 AddValue(dtValues, derivedTypeSchema_, bindingDescCompName,602 SaveDerivedPointerTarget(scope,603 SaveObjectName(604 (fir::kBindingTableSeparator + distinctName).str()),605 std::move(bindings),606 evaluate::ConstantSubscripts{607 static_cast<evaluate::ConstantSubscript>(bindings.size())}));608 // Describe "special" bindings to defined assignments, FINAL subroutines,609 // and defined derived type I/O subroutines. Defined assignments and I/O610 // subroutines override any parent bindings, but FINAL subroutines do not611 // (the runtime will call all of them).612 std::map<int, evaluate::StructureConstructor> specials{613 DescribeSpecialGenerics(614 dtScope, dtScope, derivedTypeSpec, boundProcedures)};615 if (derivedTypeSpec) {616 for (const Symbol &symbol :617 FinalsForDerivedTypeInstantiation(*derivedTypeSpec)) {618 DescribeSpecialProc(specials, symbol, /*isAssignment-*/ false,619 /*isFinal=*/true, std::nullopt, nullptr, derivedTypeSpec,620 &boundProcedures);621 }622 IncorporateDefinedIoGenericInterfaces(specials,623 common::DefinedIo::ReadFormatted, &scope, derivedTypeSpec);624 IncorporateDefinedIoGenericInterfaces(specials,625 common::DefinedIo::ReadUnformatted, &scope, derivedTypeSpec);626 IncorporateDefinedIoGenericInterfaces(specials,627 common::DefinedIo::WriteFormatted, &scope, derivedTypeSpec);628 IncorporateDefinedIoGenericInterfaces(specials,629 common::DefinedIo::WriteUnformatted, &scope, derivedTypeSpec);630 }631 // Pack the special procedure bindings in ascending order of their "which"632 // code values, and compile a little-endian bit-set of those codes for633 // use in O(1) look-up at run time.634 std::vector<evaluate::StructureConstructor> sortedSpecials;635 for (auto &pair : specials) {636 auto bit{std::uint32_t{1} << pair.first};637 CHECK(!(specialBitSet & bit));638 specialBitSet |= bit;639 sortedSpecials.emplace_back(std::move(pair.second));640 }641 AddValue(dtValues, derivedTypeSchema_, "special"s,642 SaveDerivedPointerTarget(scope,643 SaveObjectName(644 (fir::kSpecialBindingSeparator + distinctName).str()),645 std::move(sortedSpecials),646 evaluate::ConstantSubscripts{647 static_cast<evaluate::ConstantSubscript>(specials.size())}));648 }649 AddValue(dtValues, derivedTypeSchema_, "specialbitset"s,650 IntExpr<4>(specialBitSet));651 // Note the presence/absence of a parent component652 AddValue(dtValues, derivedTypeSchema_, "hasparent"s,653 IntExpr<1>(dtScope.GetDerivedTypeParent() != nullptr));654 // To avoid wasting run time attempting to initialize derived type655 // instances without any initialized components, analyze the type656 // and set a flag if there's nothing to do for it at run time.657 AddValue(dtValues, derivedTypeSchema_, "noinitializationneeded"s,658 IntExpr<1>(derivedTypeSpec &&659 !derivedTypeSpec->HasDefaultInitialization(false, false)));660 // Similarly, a flag to short-circuit destruction when not needed.661 AddValue(dtValues, derivedTypeSchema_, "nodestructionneeded"s,662 IntExpr<1>(derivedTypeSpec && !derivedTypeSpec->HasDestruction()));663 // Similarly, a flag to short-circuit finalization when not needed.664 AddValue(dtValues, derivedTypeSchema_, "nofinalizationneeded"s,665 IntExpr<1>(666 derivedTypeSpec && !MayRequireFinalization(*derivedTypeSpec)));667 // Similarly, a flag to enable optimized runtime assignment.668 AddValue(dtValues, derivedTypeSchema_, "nodefinedassignment"s,669 IntExpr<1>(670 derivedTypeSpec && !MayHaveDefinedAssignment(*derivedTypeSpec)));671 }672 dtObject.get<ObjectEntityDetails>().set_init(MaybeExpr{673 StructureExpr(Structure(derivedTypeSchema_, std::move(dtValues)))});674 return &dtObject;675}676 677static const Symbol &GetSymbol(const Scope &schemata, SourceName name) {678 auto iter{schemata.find(name)};679 CHECK(iter != schemata.end());680 const Symbol &symbol{*iter->second};681 return symbol;682}683 684const Symbol &RuntimeTableBuilder::GetSchemaSymbol(const char *name) const {685 return GetSymbol(686 DEREF(tables_.schemata), SourceName{name, std::strlen(name)});687}688 689const DeclTypeSpec &RuntimeTableBuilder::GetSchema(690 const char *schemaName) const {691 Scope &schemata{DEREF(tables_.schemata)};692 SourceName name{schemaName, std::strlen(schemaName)};693 const Symbol &symbol{GetSymbol(schemata, name)};694 CHECK(symbol.has<DerivedTypeDetails>());695 CHECK(symbol.scope());696 CHECK(symbol.scope()->IsDerivedType());697 const DeclTypeSpec *spec{nullptr};698 if (symbol.scope()->derivedTypeSpec()) {699 DeclTypeSpec typeSpec{700 DeclTypeSpec::TypeDerived, *symbol.scope()->derivedTypeSpec()};701 spec = schemata.FindType(typeSpec);702 }703 if (!spec) {704 DeclTypeSpec typeSpec{705 DeclTypeSpec::TypeDerived, DerivedTypeSpec{name, symbol}};706 spec = schemata.FindType(typeSpec);707 }708 if (!spec) {709 spec = &schemata.MakeDerivedType(710 DeclTypeSpec::TypeDerived, DerivedTypeSpec{name, symbol});711 }712 CHECK(spec->AsDerived());713 return *spec;714}715 716SomeExpr RuntimeTableBuilder::GetEnumValue(const char *name) const {717 const Symbol &symbol{GetSchemaSymbol(name)};718 auto value{evaluate::ToInt64(symbol.get<ObjectEntityDetails>().init())};719 CHECK(value.has_value());720 return IntExpr<1>(*value);721}722 723Symbol &RuntimeTableBuilder::CreateObject(724 const std::string &name, const DeclTypeSpec &type, Scope &scope) {725 ObjectEntityDetails object;726 object.set_type(type);727 auto pair{scope.try_emplace(SaveObjectName(name),728 Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))};729 CHECK(pair.second);730 Symbol &result{*pair.first->second};731 SetReadOnlyCompilerCreatedFlags(result);732 return result;733}734 735SourceName RuntimeTableBuilder::SaveObjectName(const std::string &name) {736 return *tables_.names.insert(name).first;737}738 739SomeExpr RuntimeTableBuilder::SaveNameAsPointerTarget(740 Scope &scope, const std::string &name) {741 CHECK(!name.empty());742 CHECK(name.front() != '.' || context_.IsTempName(name));743 ObjectEntityDetails object;744 auto len{static_cast<common::ConstantSubscript>(name.size())};745 if (const auto *spec{scope.FindType(DeclTypeSpec{CharacterTypeSpec{746 ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1}}})}) {747 object.set_type(*spec);748 } else {749 object.set_type(scope.MakeCharacterType(750 ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1}));751 }752 using evaluate::Ascii;753 using AsciiExpr = evaluate::Expr<Ascii>;754 object.set_init(evaluate::AsGenericExpr(AsciiExpr{name}));755 Symbol &symbol{756 *scope757 .try_emplace(758 SaveObjectName((fir::kNameStringSeparator + name).str()),759 Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))760 .first->second};761 SetReadOnlyCompilerCreatedFlags(symbol);762 return evaluate::AsGenericExpr(763 AsciiExpr{evaluate::Designator<Ascii>{symbol}});764}765 766evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(767 const Symbol &symbol, const ObjectEntityDetails &object, Scope &scope,768 Scope &dtScope, const std::string &distinctName,769 const SymbolVector *parameters) {770 evaluate::StructureConstructorValues values;771 auto &foldingContext{context_.foldingContext()};772 auto typeAndShape{evaluate::characteristics::TypeAndShape::Characterize(773 symbol, foldingContext)};774 bool isDevice{object.cudaDataAttr() &&775 *object.cudaDataAttr() == common::CUDADataAttr::Device};776 CHECK(typeAndShape.has_value());777 auto dyType{typeAndShape->type()};778 int rank{typeAndShape->Rank()};779 AddValue(values, componentSchema_, "name"s,780 SaveNameAsPointerTarget(scope, symbol.name().ToString()));781 AddValue(values, componentSchema_, "category"s,782 IntExpr<1>(static_cast<int>(dyType.category())));783 if (dyType.IsUnlimitedPolymorphic() ||784 dyType.category() == TypeCategory::Derived) {785 AddValue(values, componentSchema_, "kind"s, IntExpr<1>(0));786 } else {787 AddValue(values, componentSchema_, "kind"s, IntExpr<1>(dyType.kind()));788 }789 AddValue(values, componentSchema_, "offset"s, IntExpr<8>(symbol.offset()));790 // CHARACTER length791 auto len{typeAndShape->LEN()};792 if (const semantics::DerivedTypeSpec *793 pdtInstance{dtScope.derivedTypeSpec()}) {794 auto restorer{foldingContext.WithPDTInstance(*pdtInstance)};795 len = Fold(foldingContext, std::move(len));796 }797 if (dyType.category() == TypeCategory::Character && len) {798 // Ignore IDIM(x) (represented as MAX(0, x))799 if (const auto *clamped{evaluate::UnwrapExpr<800 evaluate::Extremum<evaluate::SubscriptInteger>>(*len)}) {801 if (clamped->ordering == evaluate::Ordering::Greater &&802 clamped->left() == evaluate::Expr<evaluate::SubscriptInteger>{0}) {803 len = common::Clone(clamped->right());804 }805 }806 AddValue(values, componentSchema_, "characterlen"s,807 evaluate::AsGenericExpr(GetValue(len, parameters)));808 } else {809 AddValue(values, componentSchema_, "characterlen"s,810 PackageIntValueExpr(deferredEnum_));811 }812 // Describe component's derived type813 std::vector<evaluate::StructureConstructor> lenParams;814 if (dyType.category() == TypeCategory::Derived &&815 !dyType.IsUnlimitedPolymorphic()) {816 const DerivedTypeSpec &spec{dyType.GetDerivedTypeSpec()};817 Scope *derivedScope{const_cast<Scope *>(818 spec.scope() ? spec.scope() : spec.typeSymbol().scope())};819 if (const Symbol *820 derivedDescription{DescribeType(821 DEREF(derivedScope), /*wantUninstantiatedPDT=*/false)}) {822 AddValue(values, componentSchema_, "derived"s,823 evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{824 evaluate::Designator<evaluate::SomeDerived>{825 DEREF(derivedDescription)}}));826 // Package values of LEN parameters, if any827 if (const SymbolVector *828 specParams{GetTypeParameters(spec.typeSymbol())}) {829 for (SymbolRef ref : *specParams) {830 const auto &tpd{ref->get<TypeParamDetails>()};831 if (tpd.attr() && *tpd.attr() == common::TypeParamAttr::Len) {832 if (const ParamValue *833 paramValue{spec.FindParameter(ref->name())}) {834 lenParams.emplace_back(GetValue(*paramValue, parameters));835 } else {836 lenParams.emplace_back(GetValue(tpd.init(), parameters));837 }838 }839 }840 }841 }842 } else {843 // Subtle: a category of Derived with a null derived type pointer844 // signifies CLASS(*)845 AddValue(values, componentSchema_, "derived"s,846 SomeExpr{evaluate::NullPointer{}});847 }848 // LEN type parameter values for the component's type849 if (!lenParams.empty()) {850 AddValue(values, componentSchema_, "lenvalue"s,851 SaveDerivedPointerTarget(scope,852 SaveObjectName((fir::kLenParameterSeparator + distinctName +853 fir::kNameSeparator + symbol.name().ToString())854 .str()),855 std::move(lenParams),856 evaluate::ConstantSubscripts{857 static_cast<evaluate::ConstantSubscript>(lenParams.size())}));858 } else {859 AddValue(values, componentSchema_, "lenvalue"s,860 SomeExpr{evaluate::NullPointer{}});861 }862 // Shape information863 AddValue(values, componentSchema_, "rank"s, IntExpr<1>(rank));864 if (rank > 0 && !IsAllocatable(symbol) && !IsPointer(symbol)) {865 std::vector<evaluate::StructureConstructor> bounds;866 evaluate::NamedEntity entity{symbol};867 for (int j{0}; j < rank; ++j) {868 bounds.emplace_back(869 GetValue(std::make_optional(870 evaluate::GetRawLowerBound(foldingContext, entity, j)),871 parameters));872 bounds.emplace_back(GetValue(873 evaluate::GetRawUpperBound(foldingContext, entity, j), parameters));874 }875 AddValue(values, componentSchema_, "bounds"s,876 SaveDerivedPointerTarget(scope,877 SaveObjectName((fir::kBoundsSeparator + distinctName +878 fir::kNameSeparator + symbol.name().ToString())879 .str()),880 std::move(bounds), evaluate::ConstantSubscripts{2, rank}));881 } else {882 AddValue(883 values, componentSchema_, "bounds"s, SomeExpr{evaluate::NullPointer{}});884 }885 // Default component initialization886 bool hasDataInit{false};887 if (IsAllocatable(symbol)) {888 if (isDevice) {889 AddValue(values, componentSchema_, "genre"s,890 GetEnumValue("allocatabledevice"));891 } else {892 AddValue(values, componentSchema_, "genre"s, GetEnumValue("allocatable"));893 }894 } else if (IsPointer(symbol)) {895 if (isDevice) {896 AddValue(897 values, componentSchema_, "genre"s, GetEnumValue("pointerdevice"));898 } else {899 AddValue(values, componentSchema_, "genre"s, GetEnumValue("pointer"));900 }901 hasDataInit = InitializeDataPointer(902 values, symbol, object, scope, dtScope, distinctName);903 } else if (IsAutomatic(symbol)) {904 AddValue(values, componentSchema_, "genre"s, GetEnumValue("automatic"));905 } else {906 AddValue(values, componentSchema_, "genre"s, GetEnumValue("data"));907 hasDataInit = object.init().has_value();908 if (hasDataInit) {909 AddValue(values, componentSchema_, "initialization"s,910 SaveObjectInit(scope,911 SaveObjectName((fir::kComponentInitSeparator + distinctName +912 fir::kNameSeparator + symbol.name().ToString())913 .str()),914 object));915 }916 }917 if (!hasDataInit) {918 AddValue(values, componentSchema_, "initialization"s,919 SomeExpr{evaluate::NullPointer{}});920 }921 return {DEREF(componentSchema_.AsDerived()), std::move(values)};922}923 924evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(925 const Symbol &symbol, const ProcEntityDetails &proc, Scope &scope) {926 evaluate::StructureConstructorValues values;927 AddValue(values, procPtrSchema_, "name"s,928 SaveNameAsPointerTarget(scope, symbol.name().ToString()));929 AddValue(values, procPtrSchema_, "offset"s, IntExpr<8>(symbol.offset()));930 if (auto init{proc.init()}; init && *init) {931 AddValue(values, procPtrSchema_, "initialization"s,932 SomeExpr{evaluate::ProcedureDesignator{**init}});933 } else {934 AddValue(values, procPtrSchema_, "initialization"s,935 SomeExpr{evaluate::NullPointer{}});936 }937 return {DEREF(procPtrSchema_.AsDerived()), std::move(values)};938}939 940// Create a static pointer object with the same initialization941// from whence the runtime can memcpy() the data pointer942// component initialization.943// Creates and interconnects the symbols, scopes, and types for944// TYPE :: ptrDt945// type, POINTER :: name946// END TYPE947// TYPE(ptrDt), TARGET, SAVE :: ptrInit = ptrDt(designator)948// and then initializes the original component by setting949// initialization = ptrInit950// which takes the address of ptrInit because the type is C_PTR.951// This technique of wrapping the data pointer component into952// a derived type instance disables any reason for lowering to953// attempt to dereference the RHS of an initializer, thereby954// allowing the runtime to actually perform the initialization955// by means of a simple memcpy() of the wrapped descriptor in956// ptrInit to the data pointer component being initialized.957bool RuntimeTableBuilder::InitializeDataPointer(958 evaluate::StructureConstructorValues &values, const Symbol &symbol,959 const ObjectEntityDetails &object, Scope &scope, Scope &dtScope,960 const std::string &distinctName) {961 if (object.init().has_value()) {962 SourceName ptrDtName{SaveObjectName((fir::kDataPtrInitSeparator +963 distinctName + fir::kNameSeparator + symbol.name().ToString())964 .str())};965 Symbol &ptrDtSym{966 *scope.try_emplace(ptrDtName, Attrs{}, UnknownDetails{}).first->second};967 SetReadOnlyCompilerCreatedFlags(ptrDtSym);968 Scope &ptrDtScope{scope.MakeScope(Scope::Kind::DerivedType, &ptrDtSym)};969 ignoreScopes_.insert(&ptrDtScope);970 ObjectEntityDetails ptrDtObj;971 ptrDtObj.set_type(DEREF(object.type()));972 ptrDtObj.set_shape(object.shape());973 Symbol &ptrDtComp{*ptrDtScope974 .try_emplace(symbol.name(), Attrs{Attr::POINTER},975 std::move(ptrDtObj))976 .first->second};977 DerivedTypeDetails ptrDtDetails;978 ptrDtDetails.add_component(ptrDtComp);979 ptrDtSym.set_details(std::move(ptrDtDetails));980 ptrDtSym.set_scope(&ptrDtScope);981 DeclTypeSpec &ptrDtDeclType{982 scope.MakeDerivedType(DeclTypeSpec::Category::TypeDerived,983 DerivedTypeSpec{ptrDtName, ptrDtSym})};984 DerivedTypeSpec &ptrDtDerived{DEREF(ptrDtDeclType.AsDerived())};985 ptrDtDerived.set_scope(ptrDtScope);986 ptrDtDerived.CookParameters(context_.foldingContext());987 ptrDtDerived.Instantiate(scope);988 ObjectEntityDetails ptrInitObj;989 ptrInitObj.set_type(ptrDtDeclType);990 evaluate::StructureConstructorValues ptrInitValues;991 AddValue(992 ptrInitValues, ptrDtDeclType, symbol.name().ToString(), *object.init());993 ptrInitObj.set_init(evaluate::AsGenericExpr(994 Structure(ptrDtDeclType, std::move(ptrInitValues))));995 AddValue(values, componentSchema_, "initialization"s,996 SaveObjectInit(scope,997 SaveObjectName((fir::kComponentInitSeparator + distinctName +998 fir::kNameSeparator + symbol.name().ToString())999 .str()),1000 ptrInitObj));1001 return true;1002 } else {1003 return false;1004 }1005}1006 1007evaluate::StructureConstructor RuntimeTableBuilder::PackageIntValue(1008 const SomeExpr &genre, std::int64_t n) const {1009 evaluate::StructureConstructorValues xs;1010 AddValue(xs, valueSchema_, "genre"s, genre);1011 AddValue(xs, valueSchema_, "value"s, IntToExpr(n));1012 return Structure(valueSchema_, std::move(xs));1013}1014 1015SomeExpr RuntimeTableBuilder::PackageIntValueExpr(1016 const SomeExpr &genre, std::int64_t n) const {1017 return StructureExpr(PackageIntValue(genre, n));1018}1019 1020SymbolVector CollectBindings(const Scope &dtScope) {1021 SymbolVector result;1022 std::map<SourceName, Symbol *> localBindings;1023 // Collect local bindings1024 for (auto pair : dtScope) {1025 Symbol &symbol{const_cast<Symbol &>(*pair.second)};1026 if (auto *binding{symbol.detailsIf<ProcBindingDetails>()}) {1027 localBindings.emplace(symbol.name(), &symbol);1028 binding->set_numPrivatesNotOverridden(0);1029 }1030 }1031 if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) {1032 result = CollectBindings(*parentScope);1033 // Apply overrides from the local bindings of the extended type1034 for (auto iter{result.begin()}; iter != result.end(); ++iter) {1035 const Symbol &symbol{**iter};1036 auto overriderIter{localBindings.find(symbol.name())};1037 if (overriderIter != localBindings.end()) {1038 Symbol &overrider{*overriderIter->second};1039 if (symbol.attrs().test(Attr::PRIVATE) &&1040 !symbol.attrs().test(Attr::DEFERRED) &&1041 FindModuleContaining(symbol.owner()) !=1042 FindModuleContaining(dtScope)) {1043 // Don't override inaccessible PRIVATE bindings, unless1044 // they are deferred1045 auto &binding{overrider.get<ProcBindingDetails>()};1046 binding.set_numPrivatesNotOverridden(1047 binding.numPrivatesNotOverridden() + 1);1048 } else {1049 *iter = overrider;1050 localBindings.erase(overriderIter);1051 }1052 }1053 }1054 }1055 // Add remaining (non-overriding) local bindings in name order to the result1056 for (auto pair : localBindings) {1057 result.push_back(*pair.second);1058 }1059 return result;1060}1061 1062std::vector<evaluate::StructureConstructor>1063RuntimeTableBuilder::DescribeBindings(1064 const Scope &dtScope, Scope &scope, const SymbolVector &bindings) {1065 std::vector<evaluate::StructureConstructor> result;1066 for (const Symbol &symbol : bindings) {1067 evaluate::StructureConstructorValues values;1068 AddValue(values, bindingSchema_, procCompName,1069 SomeExpr{evaluate::ProcedureDesignator{1070 symbol.get<ProcBindingDetails>().symbol()}});1071 AddValue(values, bindingSchema_, "name"s,1072 SaveNameAsPointerTarget(scope, symbol.name().ToString()));1073 result.emplace_back(DEREF(bindingSchema_.AsDerived()), std::move(values));1074 }1075 return result;1076}1077 1078std::map<int, evaluate::StructureConstructor>1079RuntimeTableBuilder::DescribeSpecialGenerics(const Scope &dtScope,1080 const Scope &thisScope, const DerivedTypeSpec *derivedTypeSpec,1081 const SymbolVector &bindings) const {1082 std::map<int, evaluate::StructureConstructor> specials;1083 if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) {1084 specials = DescribeSpecialGenerics(1085 *parentScope, thisScope, derivedTypeSpec, bindings);1086 }1087 for (const auto &pair : dtScope) {1088 const Symbol &symbol{*pair.second};1089 if (const auto *generic{symbol.detailsIf<GenericDetails>()}) {1090 DescribeSpecialGeneric(1091 *generic, specials, thisScope, derivedTypeSpec, bindings);1092 }1093 }1094 return specials;1095}1096 1097void RuntimeTableBuilder::DescribeSpecialGeneric(const GenericDetails &generic,1098 std::map<int, evaluate::StructureConstructor> &specials,1099 const Scope &dtScope, const DerivedTypeSpec *derivedTypeSpec,1100 const SymbolVector &bindings) const {1101 common::visit(1102 common::visitors{1103 [&](const GenericKind::OtherKind &k) {1104 if (k == GenericKind::OtherKind::Assignment) {1105 for (const Symbol &specific : generic.specificProcs()) {1106 DescribeSpecialProc(specials, specific, /*isAssignment=*/true,1107 /*isFinal=*/false, std::nullopt, &dtScope, derivedTypeSpec,1108 &bindings);1109 }1110 }1111 },1112 [&](const common::DefinedIo &io) {1113 switch (io) {1114 case common::DefinedIo::ReadFormatted:1115 case common::DefinedIo::ReadUnformatted:1116 case common::DefinedIo::WriteFormatted:1117 case common::DefinedIo::WriteUnformatted:1118 for (const Symbol &specific : generic.specificProcs()) {1119 DescribeSpecialProc(specials, specific, /*isAssignment=*/false,1120 /*isFinal=*/false, io, &dtScope, derivedTypeSpec,1121 &bindings);1122 }1123 break;1124 }1125 },1126 [](const auto &) {},1127 },1128 generic.kind().u);1129}1130 1131void RuntimeTableBuilder::DescribeSpecialProc(1132 std::map<int, evaluate::StructureConstructor> &specials,1133 const Symbol &specificOrBinding, bool isAssignment, bool isFinal,1134 std::optional<common::DefinedIo> io, const Scope *dtScope,1135 const DerivedTypeSpec *derivedTypeSpec,1136 const SymbolVector *bindings) const {1137 const auto *binding{specificOrBinding.detailsIf<ProcBindingDetails>()};1138 if (binding && dtScope) { // use most recent override1139 binding = &DEREF(dtScope->FindComponent(specificOrBinding.name()))1140 .get<ProcBindingDetails>();1141 }1142 const Symbol &specific{*(binding ? &binding->symbol() : &specificOrBinding)};1143 if (auto proc{evaluate::characteristics::Procedure::Characterize(1144 specific, context_.foldingContext())}) {1145 std::uint8_t isArgDescriptorSet{0};1146 bool specialCaseFlag{0};1147 int argThatMightBeDescriptor{0};1148 MaybeExpr which;1149 if (isAssignment) {1150 // Only type-bound asst's with compatible types on both dummy arguments1151 // are germane to the runtime, which needs only these to implement1152 // component assignment as part of intrinsic assignment.1153 // Non-type-bound generic INTERFACEs and assignments from incompatible1154 // types must not be used for component intrinsic assignment.1155 if (!binding) {1156 return;1157 }1158 CHECK(proc->dummyArguments.size() == 2);1159 const auto t1{1160 DEREF(std::get_if<evaluate::characteristics::DummyDataObject>(1161 &proc->dummyArguments[0].u))1162 .type.type()};1163 const auto t2{1164 DEREF(std::get_if<evaluate::characteristics::DummyDataObject>(1165 &proc->dummyArguments[1].u))1166 .type.type()};1167 if (t1.category() != TypeCategory::Derived ||1168 t2.category() != TypeCategory::Derived ||1169 t1.IsUnlimitedPolymorphic() || t2.IsUnlimitedPolymorphic()) {1170 return;1171 }1172 if (!derivedTypeSpec ||1173 !derivedTypeSpec->MatchesOrExtends(t1.GetDerivedTypeSpec()) ||1174 !derivedTypeSpec->MatchesOrExtends(t2.GetDerivedTypeSpec())) {1175 return;1176 }1177 which = proc->IsElemental() ? elementalAssignmentEnum_1178 : scalarAssignmentEnum_;1179 if (binding->passName() &&1180 *binding->passName() == proc->dummyArguments[1].name) {1181 argThatMightBeDescriptor = 1;1182 isArgDescriptorSet |= 2;1183 } else {1184 argThatMightBeDescriptor = 2; // the non-passed-object argument1185 isArgDescriptorSet |= 1;1186 }1187 } else if (isFinal) {1188 CHECK(binding == nullptr); // FINALs are not bindings1189 CHECK(proc->dummyArguments.size() == 1);1190 if (proc->IsElemental()) {1191 which = elementalFinalEnum_;1192 } else {1193 const auto &dummyData{1194 std::get<evaluate::characteristics::DummyDataObject>(1195 proc->dummyArguments.at(0).u)};1196 const auto &typeAndShape{dummyData.type};1197 if (typeAndShape.attrs().test(1198 evaluate::characteristics::TypeAndShape::Attr::AssumedRank)) {1199 which = assumedRankFinalEnum_;1200 isArgDescriptorSet |= 1;1201 } else {1202 which = scalarFinalEnum_;1203 if (int rank{typeAndShape.Rank()}; rank > 0) {1204 which = IntExpr<1>(ToInt64(which).value() + rank);1205 if (dummyData.IsPassedByDescriptor(proc->IsBindC())) {1206 argThatMightBeDescriptor = 1;1207 }1208 if (!typeAndShape.attrs().test(evaluate::characteristics::1209 TypeAndShape::Attr::AssumedShape) ||1210 dummyData.attrs.test(evaluate::characteristics::1211 DummyDataObject::Attr::Contiguous)) {1212 specialCaseFlag = true;1213 }1214 }1215 }1216 }1217 } else { // defined derived type I/O1218 CHECK(proc->dummyArguments.size() >= 4);1219 const auto *ddo{std::get_if<evaluate::characteristics::DummyDataObject>(1220 &proc->dummyArguments[0].u)};1221 if (!ddo) {1222 return;1223 }1224 if (derivedTypeSpec &&1225 !ddo->type.type().IsTkCompatibleWith(1226 evaluate::DynamicType{*derivedTypeSpec})) {1227 // Defined I/O specific procedure is not for this derived type.1228 return;1229 }1230 if (ddo->type.type().IsPolymorphic()) {1231 argThatMightBeDescriptor = 1;1232 }1233 switch (io.value()) {1234 case common::DefinedIo::ReadFormatted:1235 which = readFormattedEnum_;1236 break;1237 case common::DefinedIo::ReadUnformatted:1238 which = readUnformattedEnum_;1239 break;1240 case common::DefinedIo::WriteFormatted:1241 which = writeFormattedEnum_;1242 break;1243 case common::DefinedIo::WriteUnformatted:1244 which = writeUnformattedEnum_;1245 break;1246 }1247 if (context_.defaultKinds().GetDefaultKind(TypeCategory::Integer) == 8) {1248 specialCaseFlag = true; // UNIT= & IOSTAT= INTEGER(8)1249 }1250 }1251 if (argThatMightBeDescriptor != 0) {1252 if (const auto *dummyData{1253 std::get_if<evaluate::characteristics::DummyDataObject>(1254 &proc->dummyArguments.at(argThatMightBeDescriptor - 1).u)}) {1255 if (dummyData->IsPassedByDescriptor(proc->IsBindC())) {1256 isArgDescriptorSet |= 1 << (argThatMightBeDescriptor - 1);1257 }1258 }1259 }1260 evaluate::StructureConstructorValues values;1261 auto index{evaluate::ToInt64(which)};1262 CHECK(index.has_value());1263 AddValue(1264 values, specialSchema_, "which"s, SomeExpr{std::move(which.value())});1265 AddValue(values, specialSchema_, "isargdescriptorset"s,1266 IntExpr<1>(isArgDescriptorSet));1267 int bindingIndex{0};1268 if (bindings) {1269 int j{0};1270 for (const Symbol &bind : DEREF(bindings)) {1271 ++j;1272 if (&bind.get<ProcBindingDetails>().symbol() == &specific) {1273 bindingIndex = j; // index offset by 11274 break;1275 }1276 }1277 }1278 CHECK(bindingIndex <= 255);1279 AddValue(values, specialSchema_, "istypebound"s, IntExpr<1>(bindingIndex));1280 AddValue(values, specialSchema_, "specialcaseflag"s,1281 IntExpr<1>(specialCaseFlag));1282 AddValue(values, specialSchema_, procCompName,1283 SomeExpr{evaluate::ProcedureDesignator{specific}});1284 // index might already be present in the case of an override1285 specials.insert_or_assign(*index,1286 evaluate::StructureConstructor{1287 DEREF(specialSchema_.AsDerived()), std::move(values)});1288 }1289}1290 1291void RuntimeTableBuilder::IncorporateDefinedIoGenericInterfaces(1292 std::map<int, evaluate::StructureConstructor> &specials,1293 common::DefinedIo definedIo, const Scope *scope,1294 const DerivedTypeSpec *derivedTypeSpec) {1295 SourceName name{GenericKind::AsFortran(definedIo)};1296 for (; !scope->IsGlobal(); scope = &scope->parent()) {1297 if (auto asst{scope->find(name)}; asst != scope->end()) {1298 const Symbol &generic{asst->second->GetUltimate()};1299 const auto &genericDetails{generic.get<GenericDetails>()};1300 CHECK(std::holds_alternative<common::DefinedIo>(genericDetails.kind().u));1301 CHECK(std::get<common::DefinedIo>(genericDetails.kind().u) == definedIo);1302 for (auto ref : genericDetails.specificProcs()) {1303 DescribeSpecialProc(specials, *ref, false, false, definedIo, nullptr,1304 derivedTypeSpec, /*bindings=*/nullptr);1305 }1306 }1307 }1308}1309 1310RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(1311 SemanticsContext &context) {1312 RuntimeDerivedTypeTables result;1313 // Do not attempt to read __fortran_type_info.mod when compiling1314 // the module on which it depends.1315 const auto &allSources{context.allCookedSources().allSources()};1316 if (auto firstProv{allSources.GetFirstFileProvenance()}) {1317 if (const auto *srcFile{allSources.GetSourceFile(firstProv->start())}) {1318 if (srcFile->path().find("__fortran_builtins.f90") != std::string::npos) {1319 return result;1320 }1321 }1322 }1323 result.schemata = context.GetBuiltinModule(typeInfoBuiltinModule);1324 if (result.schemata) {1325 RuntimeTableBuilder builder{context, result};1326 builder.DescribeTypes(context.globalScope(), false);1327 }1328 return result;1329}1330 1331// Find the type of a defined I/O procedure's interface's initial "dtv"1332// dummy argument. Returns a non-null DeclTypeSpec pointer only if that1333// dtv argument exists and is a derived type.1334static const DeclTypeSpec *GetDefinedIoSpecificArgType(const Symbol &specific) {1335 const Symbol *interface{&specific.GetUltimate()};1336 if (const auto *procEntity{specific.detailsIf<ProcEntityDetails>()}) {1337 interface = procEntity->procInterface();1338 }1339 if (interface) {1340 if (const SubprogramDetails *1341 subprogram{interface->detailsIf<SubprogramDetails>()};1342 subprogram && !subprogram->dummyArgs().empty()) {1343 if (const Symbol * dtvArg{subprogram->dummyArgs().at(0)}) {1344 if (const DeclTypeSpec * declType{dtvArg->GetType()}) {1345 return declType->AsDerived() ? declType : nullptr;1346 }1347 }1348 }1349 }1350 return nullptr;1351}1352 1353// Locate a particular scope's generic interface for a specific kind of1354// defined I/O.1355static const Symbol *FindGenericDefinedIo(1356 const Scope &scope, common::DefinedIo which) {1357 if (const Symbol * symbol{scope.FindSymbol(GenericKind::AsFortran(which))}) {1358 const Symbol &generic{symbol->GetUltimate()};1359 const auto &genericDetails{generic.get<GenericDetails>()};1360 CHECK(std::holds_alternative<common::DefinedIo>(genericDetails.kind().u));1361 CHECK(std::get<common::DefinedIo>(genericDetails.kind().u) == which);1362 return &generic;1363 } else {1364 return nullptr;1365 }1366}1367 1368std::multimap<const Symbol *, NonTbpDefinedIo>1369CollectNonTbpDefinedIoGenericInterfaces(1370 const Scope &scope, bool useRuntimeTypeInfoEntries) {1371 std::multimap<const Symbol *, NonTbpDefinedIo> result;1372 if (!scope.IsTopLevel() &&1373 (scope.GetImportKind() == Scope::ImportKind::All ||1374 scope.GetImportKind() == Scope::ImportKind::Default)) {1375 result = CollectNonTbpDefinedIoGenericInterfaces(1376 scope.parent(), useRuntimeTypeInfoEntries);1377 }1378 if (scope.kind() != Scope::Kind::DerivedType) {1379 for (common::DefinedIo which :1380 {common::DefinedIo::ReadFormatted, common::DefinedIo::ReadUnformatted,1381 common::DefinedIo::WriteFormatted,1382 common::DefinedIo::WriteUnformatted}) {1383 if (const Symbol * generic{FindGenericDefinedIo(scope, which)}) {1384 for (auto specific : generic->get<GenericDetails>().specificProcs()) {1385 if (const DeclTypeSpec *1386 declType{GetDefinedIoSpecificArgType(*specific)}) {1387 const DerivedTypeSpec &derived{DEREF(declType->AsDerived())};1388 const Scope *derivedScope{derived.scope()};1389 if (!declType->IsPolymorphic()) {1390 // A defined I/O subroutine with a monomorphic "dtv" dummy1391 // argument implies a non-extensible sequence or BIND(C) derived1392 // type. Such types may be defined more than once in the program1393 // so long as they are structurally equivalent. If the current1394 // scope has an equivalent type, use it for the table rather1395 // than the "dtv" argument's type.1396 if (const Symbol *inScope{scope.FindSymbol(derived.name())}) {1397 const Symbol &ultimate{inScope->GetUltimate()};1398 DerivedTypeSpec localDerivedType{inScope->name(), ultimate};1399 if (ultimate.has<DerivedTypeDetails>() &&1400 evaluate::DynamicType{derived, /*isPolymorphic=*/false}1401 .IsTkCompatibleWith(evaluate::DynamicType{1402 localDerivedType, /*iP=*/false})) {1403 derivedScope = ultimate.scope();1404 }1405 }1406 }1407 if (const Symbol *dtDesc{derivedScope1408 ? derivedScope->runtimeDerivedTypeDescription()1409 : nullptr}) {1410 if (useRuntimeTypeInfoEntries &&1411 derivedScope == derived.scope() &&1412 &derivedScope->parent() == &generic->owner()) {1413 // This non-TBP defined I/O generic was defined in the1414 // same scope as the derived type, and it will be1415 // included in the derived type's special bindings1416 // by IncorporateDefinedIoGenericInterfaces().1417 } else {1418 // Local scope's specific overrides host's for this type1419 bool updated{false};1420 std::uint8_t flags{0};1421 if (declType->IsPolymorphic()) {1422 flags |= IsDtvArgPolymorphic;1423 }1424 if (scope.context().GetDefaultKind(TypeCategory::Integer) ==1425 8) {1426 flags |= DefinedIoInteger8;1427 }1428 for (auto [iter, end]{result.equal_range(dtDesc)}; iter != end;1429 ++iter) {1430 NonTbpDefinedIo &nonTbp{iter->second};1431 if (nonTbp.definedIo == which) {1432 nonTbp.subroutine = &*specific;1433 nonTbp.flags = flags;1434 updated = true;1435 }1436 }1437 if (!updated) {1438 result.emplace(1439 dtDesc, NonTbpDefinedIo{&*specific, which, flags});1440 }1441 }1442 }1443 }1444 }1445 }1446 }1447 }1448 return result;1449}1450 1451// ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces()1452//1453// Returns a true result when a kind of defined I/O generic procedure1454// has a type (from a symbol or a NAMELIST) such that1455// (1) there is a specific procedure matching that type for a non-type-bound1456// generic defined in the scope of the type, and1457// (2) that specific procedure is unavailable or overridden in a particular1458// local scope.1459// Specific procedures of non-type-bound defined I/O generic interfaces1460// declared in the scope of a derived type are identified as special bindings1461// in the derived type's runtime type information, as if they had been1462// type-bound. This predicate is meant to determine local situations in1463// which those special bindings are not to be used. Its result is intended1464// to be put into the "ignoreNonTbpEntries" flag of1465// runtime::NonTbpDefinedIoTable and passed (negated) as the1466// "useRuntimeTypeInfoEntries" argument of1467// CollectNonTbpDefinedIoGenericInterfaces() above.1468 1469static const Symbol *FindSpecificDefinedIo(const Scope &scope,1470 const evaluate::DynamicType &derived, common::DefinedIo which) {1471 if (const Symbol * generic{FindGenericDefinedIo(scope, which)}) {1472 for (auto ref : generic->get<GenericDetails>().specificProcs()) {1473 const Symbol &specific{*ref};1474 if (const DeclTypeSpec *1475 thisType{GetDefinedIoSpecificArgType(specific)}) {1476 if (evaluate::DynamicType{1477 DEREF(thisType->AsDerived()), thisType->IsPolymorphic()}1478 .IsTkCompatibleWith(derived)) {1479 return &specific.GetUltimate();1480 }1481 }1482 }1483 }1484 return nullptr;1485}1486 1487bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(1488 const Scope &scope, const DerivedTypeSpec *derived) {1489 if (!derived) {1490 return false;1491 }1492 const Symbol &typeSymbol{derived->typeSymbol()};1493 const Scope &typeScope{typeSymbol.GetUltimate().owner()};1494 evaluate::DynamicType dyType{*derived};1495 for (common::DefinedIo which :1496 {common::DefinedIo::ReadFormatted, common::DefinedIo::ReadUnformatted,1497 common::DefinedIo::WriteFormatted,1498 common::DefinedIo::WriteUnformatted}) {1499 if (const Symbol *1500 specific{FindSpecificDefinedIo(typeScope, dyType, which)}) {1501 // There's a non-TBP defined I/O procedure in the scope of the type's1502 // definition that applies to this type. It will appear in the type's1503 // runtime information. Determine whether it still applies in the1504 // scope of interest.1505 if (FindSpecificDefinedIo(scope, dyType, which) != specific) {1506 return true;1507 }1508 }1509 }1510 return false;1511}1512 1513bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(1514 const Scope &scope, const DeclTypeSpec *type) {1515 return type &&1516 ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(1517 scope, type->AsDerived());1518}1519 1520bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(1521 const Scope &scope, const Symbol *symbol) {1522 if (!symbol) {1523 return false;1524 }1525 return common::visit(1526 common::visitors{1527 [&](const NamelistDetails &x) {1528 for (auto ref : x.objects()) {1529 if (ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(1530 scope, &*ref)) {1531 return true;1532 }1533 }1534 return false;1535 },1536 [&](const auto &) {1537 return ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(1538 scope, symbol->GetType());1539 },1540 },1541 symbol->GetUltimate().details());1542}1543 1544} // namespace Fortran::semantics1545