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-exception
6//
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 component
25// .c.TYPE - TYPE(Component) descriptions for TYPE
26// .di.TYPE.NAME - Data initialization for a component
27// .dp.TYPE.NAME - Data pointer initialization for a component
28// .dt.TYPE - TYPE(DerivedType) description for TYPE
29// .kp.TYPE - KIND type parameter values for TYPE
30// .lpk.TYPE - Integer kinds of LEN type parameter values
31// .lv.TYPE.NAME - LEN type parameter values for a component's type
32// .n.NAME - Character representation of a name
33// .p.TYPE - TYPE(ProcPtrComponent) descriptions for TYPE
34// .s.TYPE - TYPE(SpecialBinding) bindings for TYPE
35// .v.TYPE - TYPE(Binding) bindings for TYPE
36
37namespace Fortran::semantics {
38
39static int FindLenParameterIndex(
40 const SymbolVector &parameters, 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 the
67 // RuntimeDerivedTypeTables instance returned by
68 // BuildRuntimeDerivedTypeTables() so that references to those names remain
69 // 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 Bound
101 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 operations
127 // with a reference to a new anonymous LEN type parameter whose default
128 // value captures the expression. This replacement must take place when
129 // the type is declared so that the new LEN type parameters appear in
130 // 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::Deferred
149 SomeExpr explicitEnum_; // Value::Genre::Explicit
150 SomeExpr lenParameterEnum_; // Value::Genre::LenParameter
151 SomeExpr scalarAssignmentEnum_; // SpecialBinding::Which::ScalarAssignment
152 SomeExpr
153 elementalAssignmentEnum_; // SpecialBinding::Which::ElementalAssignment
154 SomeExpr readFormattedEnum_; // SpecialBinding::Which::ReadFormatted
155 SomeExpr readUnformattedEnum_; // SpecialBinding::Which::ReadUnformatted
156 SomeExpr writeFormattedEnum_; // SpecialBinding::Which::WriteFormatted
157 SomeExpr writeUnformattedEnum_; // SpecialBinding::Which::WriteUnformatted
158 SomeExpr elementalFinalEnum_; // SpecialBinding::Which::ElementalFinal
159 SomeExpr assumedRankFinalEnum_; // SpecialBinding::Which::AssumedRankFinal
160 SomeExpr scalarFinalEnum_; // SpecialBinding::Which::ScalarFinal
161 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 the
191 // PARAMETER attribute (the main issue is that they may be TARGET, and normal
192 // 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 type
200// 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{*scope
228 .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 schema
241 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 order
252const 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::Integer
318 ? dyType->kind()
319 : symbol.owner().context().GetDefaultKind(TypeCategory::Integer);
320}
321
322// Save a rank-1 array constant of some numeric type as an
323// 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{*scope
344 .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{*scope
356 .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 never
407 // used in this compilation (no instantiated DerivedTypeSpec points here).
408 // Create a DerivedTypeSpec now for it so that ComponentIterator
409 // will work. This covers the case of a derived type that's declared in
410 // a module but used only by clients and submodules, enabling the
411 // 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 the
416 // 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 module
435 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 all
448 // 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(scope&: 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 mutual
466 // 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{isPDTInstantiation
484 ? DescribeType(dtScope&: 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 for
501 // each category of parameter. KIND= type parameters are described
502 // by their instantiated (or default) values, while LEN= type
503 // 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= parameter
521 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 type
536 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 order
546 },
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 pass
557 },
558 [&](const GenericDetails &) { // ditto
559 },
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, placing
569 // the parent component first if any.
570 std::sort(first: dataComponentSymbols.begin(), last: dataComponentSymbols.end(),
571 comp: [](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 bindings
596 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/O
610 // subroutines override any parent bindings, but FINAL subroutines do not
611 // (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 for
633 // 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 component
652 AddValue(dtValues, derivedTypeSchema_, "hasparent"s,
653 IntExpr<1>(dtScope.GetDerivedTypeParent() != nullptr));
654 // To avoid wasting run time attempting to initialize derived type
655 // instances without any initialized components, analyze the type
656 // 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 *scope
757 .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 CHECK(typeAndShape.has_value());
775 auto dyType{typeAndShape->type()};
776 int rank{typeAndShape->Rank()};
777 AddValue(values, componentSchema_, "name"s,
778 SaveNameAsPointerTarget(scope, symbol.name().ToString()));
779 AddValue(values, componentSchema_, "category"s,
780 IntExpr<1>(static_cast<int>(dyType.category())));
781 if (dyType.IsUnlimitedPolymorphic() ||
782 dyType.category() == TypeCategory::Derived) {
783 AddValue(values, componentSchema_, "kind"s, IntExpr<1>(0));
784 } else {
785 AddValue(values, componentSchema_, "kind"s, IntExpr<1>(dyType.kind()));
786 }
787 AddValue(values, componentSchema_, "offset"s, IntExpr<8>(symbol.offset()));
788 // CHARACTER length
789 auto len{typeAndShape->LEN()};
790 if (const semantics::DerivedTypeSpec *
791 pdtInstance{dtScope.derivedTypeSpec()}) {
792 auto restorer{foldingContext.WithPDTInstance(*pdtInstance)};
793 len = Fold(foldingContext, std::move(len));
794 }
795 if (dyType.category() == TypeCategory::Character && len) {
796 // Ignore IDIM(x) (represented as MAX(0, x))
797 if (const auto *clamped{evaluate::UnwrapExpr<
798 evaluate::Extremum<evaluate::SubscriptInteger>>(*len)}) {
799 if (clamped->ordering == evaluate::Ordering::Greater &&
800 clamped->left() == evaluate::Expr<evaluate::SubscriptInteger>{0}) {
801 len = common::Clone(clamped->right());
802 }
803 }
804 AddValue(values, componentSchema_, "characterlen"s,
805 evaluate::AsGenericExpr(GetValue(len, parameters)));
806 } else {
807 AddValue(values, componentSchema_, "characterlen"s,
808 PackageIntValueExpr(deferredEnum_));
809 }
810 // Describe component's derived type
811 std::vector<evaluate::StructureConstructor> lenParams;
812 if (dyType.category() == TypeCategory::Derived &&
813 !dyType.IsUnlimitedPolymorphic()) {
814 const DerivedTypeSpec &spec{dyType.GetDerivedTypeSpec()};
815 Scope *derivedScope{const_cast<Scope *>(
816 spec.scope() ? spec.scope() : spec.typeSymbol().scope())};
817 if (const Symbol *
818 derivedDescription{DescribeType(
819 dtScope&: DEREF(derivedScope), /*wantUninstantiatedPDT=*/false)}) {
820 AddValue(values, componentSchema_, "derived"s,
821 evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{
822 evaluate::Designator<evaluate::SomeDerived>{
823 DEREF(derivedDescription)}}));
824 // Package values of LEN parameters, if any
825 if (const SymbolVector *
826 specParams{GetTypeParameters(spec.typeSymbol())}) {
827 for (SymbolRef ref : *specParams) {
828 const auto &tpd{ref->get<TypeParamDetails>()};
829 if (tpd.attr() && *tpd.attr() == common::TypeParamAttr::Len) {
830 if (const ParamValue *
831 paramValue{spec.FindParameter(ref->name())}) {
832 lenParams.emplace_back(GetValue(*paramValue, parameters));
833 } else {
834 lenParams.emplace_back(GetValue(tpd.init(), parameters));
835 }
836 }
837 }
838 }
839 }
840 } else {
841 // Subtle: a category of Derived with a null derived type pointer
842 // signifies CLASS(*)
843 AddValue(values, componentSchema_, "derived"s,
844 SomeExpr{evaluate::NullPointer{}});
845 }
846 // LEN type parameter values for the component's type
847 if (!lenParams.empty()) {
848 AddValue(values, componentSchema_, "lenvalue"s,
849 SaveDerivedPointerTarget(scope,
850 SaveObjectName((fir::kLenParameterSeparator + distinctName +
851 fir::kNameSeparator + symbol.name().ToString())
852 .str()),
853 std::move(lenParams),
854 evaluate::ConstantSubscripts{
855 static_cast<evaluate::ConstantSubscript>(lenParams.size())}));
856 } else {
857 AddValue(values, componentSchema_, "lenvalue"s,
858 SomeExpr{evaluate::NullPointer{}});
859 }
860 // Shape information
861 AddValue(values, componentSchema_, "rank"s, IntExpr<1>(rank));
862 if (rank > 0 && !IsAllocatable(symbol) && !IsPointer(symbol)) {
863 std::vector<evaluate::StructureConstructor> bounds;
864 evaluate::NamedEntity entity{symbol};
865 for (int j{0}; j < rank; ++j) {
866 bounds.emplace_back(
867 GetValue(std::make_optional(
868 evaluate::GetRawLowerBound(foldingContext, entity, j)),
869 parameters));
870 bounds.emplace_back(GetValue(
871 evaluate::GetRawUpperBound(foldingContext, entity, j), parameters));
872 }
873 AddValue(values, componentSchema_, "bounds"s,
874 SaveDerivedPointerTarget(scope,
875 SaveObjectName((fir::kBoundsSeparator + distinctName +
876 fir::kNameSeparator + symbol.name().ToString())
877 .str()),
878 std::move(bounds), evaluate::ConstantSubscripts{2, rank}));
879 } else {
880 AddValue(
881 values, componentSchema_, "bounds"s, SomeExpr{evaluate::NullPointer{}});
882 }
883 // Default component initialization
884 bool hasDataInit{false};
885 if (IsAllocatable(symbol)) {
886 AddValue(values, componentSchema_, "genre"s, GetEnumValue("allocatable"));
887 } else if (IsPointer(symbol)) {
888 AddValue(values, componentSchema_, "genre"s, GetEnumValue("pointer"));
889 hasDataInit = InitializeDataPointer(
890 values, symbol, object, scope, dtScope, distinctName);
891 } else if (IsAutomatic(symbol)) {
892 AddValue(values, componentSchema_, "genre"s, GetEnumValue("automatic"));
893 } else {
894 AddValue(values, componentSchema_, "genre"s, GetEnumValue("data"));
895 hasDataInit = object.init().has_value();
896 if (hasDataInit) {
897 AddValue(values, componentSchema_, "initialization"s,
898 SaveObjectInit(scope,
899 SaveObjectName((fir::kComponentInitSeparator + distinctName +
900 fir::kNameSeparator + symbol.name().ToString())
901 .str()),
902 object));
903 }
904 }
905 if (!hasDataInit) {
906 AddValue(values, componentSchema_, "initialization"s,
907 SomeExpr{evaluate::NullPointer{}});
908 }
909 return {DEREF(componentSchema_.AsDerived()), std::move(values)};
910}
911
912evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
913 const Symbol &symbol, const ProcEntityDetails &proc, Scope &scope) {
914 evaluate::StructureConstructorValues values;
915 AddValue(values, procPtrSchema_, "name"s,
916 SaveNameAsPointerTarget(scope, symbol.name().ToString()));
917 AddValue(values, procPtrSchema_, "offset"s, IntExpr<8>(symbol.offset()));
918 if (auto init{proc.init()}; init && *init) {
919 AddValue(values, procPtrSchema_, "initialization"s,
920 SomeExpr{evaluate::ProcedureDesignator{**init}});
921 } else {
922 AddValue(values, procPtrSchema_, "initialization"s,
923 SomeExpr{evaluate::NullPointer{}});
924 }
925 return {DEREF(procPtrSchema_.AsDerived()), std::move(values)};
926}
927
928// Create a static pointer object with the same initialization
929// from whence the runtime can memcpy() the data pointer
930// component initialization.
931// Creates and interconnects the symbols, scopes, and types for
932// TYPE :: ptrDt
933// type, POINTER :: name
934// END TYPE
935// TYPE(ptrDt), TARGET, SAVE :: ptrInit = ptrDt(designator)
936// and then initializes the original component by setting
937// initialization = ptrInit
938// which takes the address of ptrInit because the type is C_PTR.
939// This technique of wrapping the data pointer component into
940// a derived type instance disables any reason for lowering to
941// attempt to dereference the RHS of an initializer, thereby
942// allowing the runtime to actually perform the initialization
943// by means of a simple memcpy() of the wrapped descriptor in
944// ptrInit to the data pointer component being initialized.
945bool RuntimeTableBuilder::InitializeDataPointer(
946 evaluate::StructureConstructorValues &values, const Symbol &symbol,
947 const ObjectEntityDetails &object, Scope &scope, Scope &dtScope,
948 const std::string &distinctName) {
949 if (object.init().has_value()) {
950 SourceName ptrDtName{SaveObjectName((fir::kDataPtrInitSeparator +
951 distinctName + fir::kNameSeparator + symbol.name().ToString())
952 .str())};
953 Symbol &ptrDtSym{
954 *scope.try_emplace(ptrDtName, Attrs{}, UnknownDetails{}).first->second};
955 SetReadOnlyCompilerCreatedFlags(ptrDtSym);
956 Scope &ptrDtScope{scope.MakeScope(Scope::Kind::DerivedType, &ptrDtSym)};
957 ignoreScopes_.insert(&ptrDtScope);
958 ObjectEntityDetails ptrDtObj;
959 ptrDtObj.set_type(DEREF(object.type()));
960 ptrDtObj.set_shape(object.shape());
961 Symbol &ptrDtComp{*ptrDtScope
962 .try_emplace(symbol.name(), Attrs{Attr::POINTER},
963 std::move(ptrDtObj))
964 .first->second};
965 DerivedTypeDetails ptrDtDetails;
966 ptrDtDetails.add_component(ptrDtComp);
967 ptrDtSym.set_details(std::move(ptrDtDetails));
968 ptrDtSym.set_scope(&ptrDtScope);
969 DeclTypeSpec &ptrDtDeclType{
970 scope.MakeDerivedType(DeclTypeSpec::Category::TypeDerived,
971 DerivedTypeSpec{ptrDtName, ptrDtSym})};
972 DerivedTypeSpec &ptrDtDerived{DEREF(ptrDtDeclType.AsDerived())};
973 ptrDtDerived.set_scope(ptrDtScope);
974 ptrDtDerived.CookParameters(context_.foldingContext());
975 ptrDtDerived.Instantiate(scope);
976 ObjectEntityDetails ptrInitObj;
977 ptrInitObj.set_type(ptrDtDeclType);
978 evaluate::StructureConstructorValues ptrInitValues;
979 AddValue(
980 ptrInitValues, ptrDtDeclType, symbol.name().ToString(), *object.init());
981 ptrInitObj.set_init(evaluate::AsGenericExpr(
982 Structure(ptrDtDeclType, std::move(ptrInitValues))));
983 AddValue(values, componentSchema_, "initialization"s,
984 SaveObjectInit(scope,
985 SaveObjectName((fir::kComponentInitSeparator + distinctName +
986 fir::kNameSeparator + symbol.name().ToString())
987 .str()),
988 ptrInitObj));
989 return true;
990 } else {
991 return false;
992 }
993}
994
995evaluate::StructureConstructor RuntimeTableBuilder::PackageIntValue(
996 const SomeExpr &genre, std::int64_t n) const {
997 evaluate::StructureConstructorValues xs;
998 AddValue(xs, valueSchema_, "genre"s, genre);
999 AddValue(xs, valueSchema_, "value"s, IntToExpr(n));
1000 return Structure(valueSchema_, std::move(xs));
1001}
1002
1003SomeExpr RuntimeTableBuilder::PackageIntValueExpr(
1004 const SomeExpr &genre, std::int64_t n) const {
1005 return StructureExpr(PackageIntValue(genre, n));
1006}
1007
1008SymbolVector CollectBindings(const Scope &dtScope) {
1009 SymbolVector result;
1010 std::map<SourceName, Symbol *> localBindings;
1011 // Collect local bindings
1012 for (auto pair : dtScope) {
1013 Symbol &symbol{const_cast<Symbol &>(*pair.second)};
1014 if (auto *binding{symbol.detailsIf<ProcBindingDetails>()}) {
1015 localBindings.emplace(symbol.name(), &symbol);
1016 binding->set_numPrivatesNotOverridden(0);
1017 }
1018 }
1019 if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) {
1020 result = CollectBindings(*parentScope);
1021 // Apply overrides from the local bindings of the extended type
1022 for (auto iter{result.begin()}; iter != result.end(); ++iter) {
1023 const Symbol &symbol{**iter};
1024 auto overriderIter{localBindings.find(symbol.name())};
1025 if (overriderIter != localBindings.end()) {
1026 Symbol &overrider{*overriderIter->second};
1027 if (symbol.attrs().test(Attr::PRIVATE) &&
1028 !symbol.attrs().test(Attr::DEFERRED) &&
1029 FindModuleContaining(symbol.owner()) !=
1030 FindModuleContaining(dtScope)) {
1031 // Don't override inaccessible PRIVATE bindings, unless
1032 // they are deferred
1033 auto &binding{overrider.get<ProcBindingDetails>()};
1034 binding.set_numPrivatesNotOverridden(
1035 binding.numPrivatesNotOverridden() + 1);
1036 } else {
1037 *iter = overrider;
1038 localBindings.erase(overriderIter);
1039 }
1040 }
1041 }
1042 }
1043 // Add remaining (non-overriding) local bindings in name order to the result
1044 for (auto pair : localBindings) {
1045 result.push_back(*pair.second);
1046 }
1047 return result;
1048}
1049
1050std::vector<evaluate::StructureConstructor>
1051RuntimeTableBuilder::DescribeBindings(
1052 const Scope &dtScope, Scope &scope, const SymbolVector &bindings) {
1053 std::vector<evaluate::StructureConstructor> result;
1054 for (const Symbol &symbol : bindings) {
1055 evaluate::StructureConstructorValues values;
1056 AddValue(values, bindingSchema_, procCompName,
1057 SomeExpr{evaluate::ProcedureDesignator{
1058 symbol.get<ProcBindingDetails>().symbol()}});
1059 AddValue(values, bindingSchema_, "name"s,
1060 SaveNameAsPointerTarget(scope, symbol.name().ToString()));
1061 result.emplace_back(DEREF(bindingSchema_.AsDerived()), std::move(values));
1062 }
1063 return result;
1064}
1065
1066std::map<int, evaluate::StructureConstructor>
1067RuntimeTableBuilder::DescribeSpecialGenerics(const Scope &dtScope,
1068 const Scope &thisScope, const DerivedTypeSpec *derivedTypeSpec,
1069 const SymbolVector &bindings) const {
1070 std::map<int, evaluate::StructureConstructor> specials;
1071 if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) {
1072 specials = DescribeSpecialGenerics(
1073 *parentScope, thisScope, derivedTypeSpec, bindings);
1074 }
1075 for (const auto &pair : dtScope) {
1076 const Symbol &symbol{*pair.second};
1077 if (const auto *generic{symbol.detailsIf<GenericDetails>()}) {
1078 DescribeSpecialGeneric(
1079 *generic, specials, thisScope, derivedTypeSpec, bindings);
1080 }
1081 }
1082 return specials;
1083}
1084
1085void RuntimeTableBuilder::DescribeSpecialGeneric(const GenericDetails &generic,
1086 std::map<int, evaluate::StructureConstructor> &specials,
1087 const Scope &dtScope, const DerivedTypeSpec *derivedTypeSpec,
1088 const SymbolVector &bindings) const {
1089 common::visit(
1090 common::visitors{
1091 [&](const GenericKind::OtherKind &k) {
1092 if (k == GenericKind::OtherKind::Assignment) {
1093 for (const Symbol &specific : generic.specificProcs()) {
1094 DescribeSpecialProc(specials, specific, /*isAssignment=*/true,
1095 /*isFinal=*/false, std::nullopt, &dtScope, derivedTypeSpec,
1096 &bindings);
1097 }
1098 }
1099 },
1100 [&](const common::DefinedIo &io) {
1101 switch (io) {
1102 case common::DefinedIo::ReadFormatted:
1103 case common::DefinedIo::ReadUnformatted:
1104 case common::DefinedIo::WriteFormatted:
1105 case common::DefinedIo::WriteUnformatted:
1106 for (const Symbol &specific : generic.specificProcs()) {
1107 DescribeSpecialProc(specials, specific, /*isAssignment=*/false,
1108 /*isFinal=*/false, io, &dtScope, derivedTypeSpec,
1109 &bindings);
1110 }
1111 break;
1112 }
1113 },
1114 [](const auto &) {},
1115 },
1116 generic.kind().u);
1117}
1118
1119void RuntimeTableBuilder::DescribeSpecialProc(
1120 std::map<int, evaluate::StructureConstructor> &specials,
1121 const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
1122 std::optional<common::DefinedIo> io, const Scope *dtScope,
1123 const DerivedTypeSpec *derivedTypeSpec,
1124 const SymbolVector *bindings) const {
1125 const auto *binding{specificOrBinding.detailsIf<ProcBindingDetails>()};
1126 if (binding && dtScope) { // use most recent override
1127 binding = &DEREF(dtScope->FindComponent(specificOrBinding.name()))
1128 .get<ProcBindingDetails>();
1129 }
1130 const Symbol &specific{*(binding ? &binding->symbol() : &specificOrBinding)};
1131 if (auto proc{evaluate::characteristics::Procedure::Characterize(
1132 specific, context_.foldingContext())}) {
1133 std::uint8_t isArgDescriptorSet{0};
1134 std::uint8_t isArgContiguousSet{0};
1135 int argThatMightBeDescriptor{0};
1136 MaybeExpr which;
1137 if (isAssignment) {
1138 // Only type-bound asst's with compatible types on both dummy arguments
1139 // are germane to the runtime, which needs only these to implement
1140 // component assignment as part of intrinsic assignment.
1141 // Non-type-bound generic INTERFACEs and assignments from incompatible
1142 // types must not be used for component intrinsic assignment.
1143 if (!binding) {
1144 return;
1145 }
1146 CHECK(proc->dummyArguments.size() == 2);
1147 const auto t1{
1148 DEREF(std::get_if<evaluate::characteristics::DummyDataObject>(
1149 &proc->dummyArguments[0].u))
1150 .type.type()};
1151 const auto t2{
1152 DEREF(std::get_if<evaluate::characteristics::DummyDataObject>(
1153 &proc->dummyArguments[1].u))
1154 .type.type()};
1155 if (t1.category() != TypeCategory::Derived ||
1156 t2.category() != TypeCategory::Derived ||
1157 t1.IsUnlimitedPolymorphic() || t2.IsUnlimitedPolymorphic()) {
1158 return;
1159 }
1160 if (!derivedTypeSpec ||
1161 !derivedTypeSpec->MatchesOrExtends(t1.GetDerivedTypeSpec()) ||
1162 !derivedTypeSpec->MatchesOrExtends(t2.GetDerivedTypeSpec())) {
1163 return;
1164 }
1165 which = proc->IsElemental() ? elementalAssignmentEnum_
1166 : scalarAssignmentEnum_;
1167 if (binding->passName() &&
1168 *binding->passName() == proc->dummyArguments[1].name) {
1169 argThatMightBeDescriptor = 1;
1170 isArgDescriptorSet |= 2;
1171 } else {
1172 argThatMightBeDescriptor = 2; // the non-passed-object argument
1173 isArgDescriptorSet |= 1;
1174 }
1175 } else if (isFinal) {
1176 CHECK(binding == nullptr); // FINALs are not bindings
1177 CHECK(proc->dummyArguments.size() == 1);
1178 if (proc->IsElemental()) {
1179 which = elementalFinalEnum_;
1180 } else {
1181 const auto &dummyData{
1182 std::get<evaluate::characteristics::DummyDataObject>(
1183 proc->dummyArguments.at(0).u)};
1184 const auto &typeAndShape{dummyData.type};
1185 if (typeAndShape.attrs().test(
1186 evaluate::characteristics::TypeAndShape::Attr::AssumedRank)) {
1187 which = assumedRankFinalEnum_;
1188 isArgDescriptorSet |= 1;
1189 } else {
1190 which = scalarFinalEnum_;
1191 if (int rank{typeAndShape.Rank()}; rank > 0) {
1192 which = IntExpr<1>(ToInt64(which).value() + rank);
1193 if (dummyData.IsPassedByDescriptor(proc->IsBindC())) {
1194 argThatMightBeDescriptor = 1;
1195 }
1196 if (!typeAndShape.attrs().test(evaluate::characteristics::
1197 TypeAndShape::Attr::AssumedShape) ||
1198 dummyData.attrs.test(evaluate::characteristics::
1199 DummyDataObject::Attr::Contiguous)) {
1200 isArgContiguousSet |= 1;
1201 }
1202 }
1203 }
1204 }
1205 } else { // defined derived type I/O
1206 CHECK(proc->dummyArguments.size() >= 4);
1207 const auto *ddo{std::get_if<evaluate::characteristics::DummyDataObject>(
1208 &proc->dummyArguments[0].u)};
1209 if (!ddo) {
1210 return;
1211 }
1212 if (derivedTypeSpec &&
1213 !ddo->type.type().IsTkCompatibleWith(
1214 evaluate::DynamicType{*derivedTypeSpec})) {
1215 // Defined I/O specific procedure is not for this derived type.
1216 return;
1217 }
1218 if (ddo->type.type().IsPolymorphic()) {
1219 isArgDescriptorSet |= 1;
1220 }
1221 switch (io.value()) {
1222 case common::DefinedIo::ReadFormatted:
1223 which = readFormattedEnum_;
1224 break;
1225 case common::DefinedIo::ReadUnformatted:
1226 which = readUnformattedEnum_;
1227 break;
1228 case common::DefinedIo::WriteFormatted:
1229 which = writeFormattedEnum_;
1230 break;
1231 case common::DefinedIo::WriteUnformatted:
1232 which = writeUnformattedEnum_;
1233 break;
1234 }
1235 }
1236 if (argThatMightBeDescriptor != 0) {
1237 if (const auto *dummyData{
1238 std::get_if<evaluate::characteristics::DummyDataObject>(
1239 &proc->dummyArguments.at(argThatMightBeDescriptor - 1).u)}) {
1240 if (dummyData->IsPassedByDescriptor(proc->IsBindC())) {
1241 isArgDescriptorSet |= 1 << (argThatMightBeDescriptor - 1);
1242 }
1243 }
1244 }
1245 evaluate::StructureConstructorValues values;
1246 auto index{evaluate::ToInt64(which)};
1247 CHECK(index.has_value());
1248 AddValue(
1249 values, specialSchema_, "which"s, SomeExpr{std::move(which.value())});
1250 AddValue(values, specialSchema_, "isargdescriptorset"s,
1251 IntExpr<1>(isArgDescriptorSet));
1252 int bindingIndex{0};
1253 if (bindings) {
1254 int j{0};
1255 for (const Symbol &bind : DEREF(bindings)) {
1256 ++j;
1257 if (&bind.get<ProcBindingDetails>().symbol() == &specific) {
1258 bindingIndex = j; // index offset by 1
1259 break;
1260 }
1261 }
1262 }
1263 CHECK(bindingIndex <= 255);
1264 AddValue(values, specialSchema_, "istypebound"s, IntExpr<1>(bindingIndex));
1265 AddValue(values, specialSchema_, "isargcontiguousset"s,
1266 IntExpr<1>(isArgContiguousSet));
1267 AddValue(values, specialSchema_, procCompName,
1268 SomeExpr{evaluate::ProcedureDesignator{specific}});
1269 // index might already be present in the case of an override
1270 specials.insert_or_assign(*index,
1271 evaluate::StructureConstructor{
1272 DEREF(specialSchema_.AsDerived()), std::move(values)});
1273 }
1274}
1275
1276void RuntimeTableBuilder::IncorporateDefinedIoGenericInterfaces(
1277 std::map<int, evaluate::StructureConstructor> &specials,
1278 common::DefinedIo definedIo, const Scope *scope,
1279 const DerivedTypeSpec *derivedTypeSpec) {
1280 SourceName name{GenericKind::AsFortran(definedIo)};
1281 for (; !scope->IsGlobal(); scope = &scope->parent()) {
1282 if (auto asst{scope->find(name)}; asst != scope->end()) {
1283 const Symbol &generic{asst->second->GetUltimate()};
1284 const auto &genericDetails{generic.get<GenericDetails>()};
1285 CHECK(std::holds_alternative<common::DefinedIo>(genericDetails.kind().u));
1286 CHECK(std::get<common::DefinedIo>(genericDetails.kind().u) == definedIo);
1287 for (auto ref : genericDetails.specificProcs()) {
1288 DescribeSpecialProc(specials, *ref, false, false, definedIo, nullptr,
1289 derivedTypeSpec, /*bindings=*/nullptr);
1290 }
1291 }
1292 }
1293}
1294
1295RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(
1296 SemanticsContext &context) {
1297 RuntimeDerivedTypeTables result;
1298 // Do not attempt to read __fortran_type_info.mod when compiling
1299 // the module on which it depends.
1300 const auto &allSources{context.allCookedSources().allSources()};
1301 if (auto firstProv{allSources.GetFirstFileProvenance()}) {
1302 if (const auto *srcFile{allSources.GetSourceFile(firstProv->start())}) {
1303 if (srcFile->path().find("__fortran_builtins.f90") != std::string::npos) {
1304 return result;
1305 }
1306 }
1307 }
1308 result.schemata = context.GetBuiltinModule(typeInfoBuiltinModule);
1309 if (result.schemata) {
1310 RuntimeTableBuilder builder{context, result};
1311 builder.DescribeTypes(scope&: context.globalScope(), inSchemata: false);
1312 }
1313 return result;
1314}
1315
1316// Find the type of a defined I/O procedure's interface's initial "dtv"
1317// dummy argument. Returns a non-null DeclTypeSpec pointer only if that
1318// dtv argument exists and is a derived type.
1319static const DeclTypeSpec *GetDefinedIoSpecificArgType(const Symbol &specific) {
1320 const Symbol *interface{&specific.GetUltimate()};
1321 if (const auto *procEntity{specific.detailsIf<ProcEntityDetails>()}) {
1322 interface = procEntity->procInterface();
1323 }
1324 if (interface) {
1325 if (const SubprogramDetails *
1326 subprogram{interface->detailsIf<SubprogramDetails>()};
1327 subprogram && !subprogram->dummyArgs().empty()) {
1328 if (const Symbol * dtvArg{subprogram->dummyArgs().at(0)}) {
1329 if (const DeclTypeSpec * declType{dtvArg->GetType()}) {
1330 return declType->AsDerived() ? declType : nullptr;
1331 }
1332 }
1333 }
1334 }
1335 return nullptr;
1336}
1337
1338// Locate a particular scope's generic interface for a specific kind of
1339// defined I/O.
1340static const Symbol *FindGenericDefinedIo(
1341 const Scope &scope, common::DefinedIo which) {
1342 if (const Symbol * symbol{scope.FindSymbol(GenericKind::AsFortran(which))}) {
1343 const Symbol &generic{symbol->GetUltimate()};
1344 const auto &genericDetails{generic.get<GenericDetails>()};
1345 CHECK(std::holds_alternative<common::DefinedIo>(genericDetails.kind().u));
1346 CHECK(std::get<common::DefinedIo>(genericDetails.kind().u) == which);
1347 return &generic;
1348 } else {
1349 return nullptr;
1350 }
1351}
1352
1353std::multimap<const Symbol *, NonTbpDefinedIo>
1354CollectNonTbpDefinedIoGenericInterfaces(
1355 const Scope &scope, bool useRuntimeTypeInfoEntries) {
1356 std::multimap<const Symbol *, NonTbpDefinedIo> result;
1357 if (!scope.IsTopLevel() &&
1358 (scope.GetImportKind() == Scope::ImportKind::All ||
1359 scope.GetImportKind() == Scope::ImportKind::Default)) {
1360 result = CollectNonTbpDefinedIoGenericInterfaces(
1361 scope.parent(), useRuntimeTypeInfoEntries);
1362 }
1363 if (scope.kind() != Scope::Kind::DerivedType) {
1364 for (common::DefinedIo which :
1365 {common::DefinedIo::ReadFormatted, common::DefinedIo::ReadUnformatted,
1366 common::DefinedIo::WriteFormatted,
1367 common::DefinedIo::WriteUnformatted}) {
1368 if (const Symbol * generic{FindGenericDefinedIo(scope, which)}) {
1369 for (auto specific : generic->get<GenericDetails>().specificProcs()) {
1370 if (const DeclTypeSpec *
1371 declType{GetDefinedIoSpecificArgType(*specific)}) {
1372 const DerivedTypeSpec &derived{DEREF(declType->AsDerived())};
1373 if (const Symbol *
1374 dtDesc{derived.scope()
1375 ? derived.scope()->runtimeDerivedTypeDescription()
1376 : nullptr}) {
1377 if (useRuntimeTypeInfoEntries &&
1378 &derived.scope()->parent() == &generic->owner()) {
1379 // This non-TBP defined I/O generic was defined in the
1380 // same scope as the derived type, and it will be
1381 // included in the derived type's special bindings
1382 // by IncorporateDefinedIoGenericInterfaces().
1383 } else {
1384 // Local scope's specific overrides host's for this type
1385 bool updated{false};
1386 for (auto [iter, end]{result.equal_range(dtDesc)}; iter != end;
1387 ++iter) {
1388 NonTbpDefinedIo &nonTbp{iter->second};
1389 if (nonTbp.definedIo == which) {
1390 nonTbp.subroutine = &*specific;
1391 nonTbp.isDtvArgPolymorphic = declType->IsPolymorphic();
1392 updated = true;
1393 }
1394 }
1395 if (!updated) {
1396 result.emplace(dtDesc,
1397 NonTbpDefinedIo{
1398 &*specific, which, declType->IsPolymorphic()});
1399 }
1400 }
1401 }
1402 }
1403 }
1404 }
1405 }
1406 }
1407 return result;
1408}
1409
1410// ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces()
1411//
1412// Returns a true result when a kind of defined I/O generic procedure
1413// has a type (from a symbol or a NAMELIST) such that
1414// (1) there is a specific procedure matching that type for a non-type-bound
1415// generic defined in the scope of the type, and
1416// (2) that specific procedure is unavailable or overridden in a particular
1417// local scope.
1418// Specific procedures of non-type-bound defined I/O generic interfaces
1419// declared in the scope of a derived type are identified as special bindings
1420// in the derived type's runtime type information, as if they had been
1421// type-bound. This predicate is meant to determine local situations in
1422// which those special bindings are not to be used. Its result is intended
1423// to be put into the "ignoreNonTbpEntries" flag of
1424// runtime::NonTbpDefinedIoTable and passed (negated) as the
1425// "useRuntimeTypeInfoEntries" argument of
1426// CollectNonTbpDefinedIoGenericInterfaces() above.
1427
1428static const Symbol *FindSpecificDefinedIo(const Scope &scope,
1429 const evaluate::DynamicType &derived, common::DefinedIo which) {
1430 if (const Symbol * generic{FindGenericDefinedIo(scope, which)}) {
1431 for (auto ref : generic->get<GenericDetails>().specificProcs()) {
1432 const Symbol &specific{*ref};
1433 if (const DeclTypeSpec *
1434 thisType{GetDefinedIoSpecificArgType(specific)}) {
1435 if (evaluate::DynamicType{DEREF(thisType->AsDerived()), true}
1436 .IsTkCompatibleWith(derived)) {
1437 return &specific.GetUltimate();
1438 }
1439 }
1440 }
1441 }
1442 return nullptr;
1443}
1444
1445bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1446 const Scope &scope, const DerivedTypeSpec *derived) {
1447 if (!derived) {
1448 return false;
1449 }
1450 const Symbol &typeSymbol{derived->typeSymbol()};
1451 const Scope &typeScope{typeSymbol.GetUltimate().owner()};
1452 evaluate::DynamicType dyType{*derived};
1453 for (common::DefinedIo which :
1454 {common::DefinedIo::ReadFormatted, common::DefinedIo::ReadUnformatted,
1455 common::DefinedIo::WriteFormatted,
1456 common::DefinedIo::WriteUnformatted}) {
1457 if (const Symbol *
1458 specific{FindSpecificDefinedIo(typeScope, dyType, which)}) {
1459 // There's a non-TBP defined I/O procedure in the scope of the type's
1460 // definition that applies to this type. It will appear in the type's
1461 // runtime information. Determine whether it still applies in the
1462 // scope of interest.
1463 if (FindSpecificDefinedIo(scope, dyType, which) != specific) {
1464 return true;
1465 }
1466 }
1467 }
1468 return false;
1469}
1470
1471bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1472 const Scope &scope, const DeclTypeSpec *type) {
1473 return type &&
1474 ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1475 scope, type->AsDerived());
1476}
1477
1478bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1479 const Scope &scope, const Symbol *symbol) {
1480 if (!symbol) {
1481 return false;
1482 }
1483 return common::visit(
1484 common::visitors{
1485 [&](const NamelistDetails &x) {
1486 for (auto ref : x.objects()) {
1487 if (ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1488 scope, &*ref)) {
1489 return true;
1490 }
1491 }
1492 return false;
1493 },
1494 [&](const auto &) {
1495 return ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1496 scope, symbol->GetType());
1497 },
1498 },
1499 symbol->GetUltimate().details());
1500}
1501
1502} // namespace Fortran::semantics
1503

source code of flang/lib/Semantics/runtime-type-info.cpp