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 &);
86 std::map<int, evaluate::StructureConstructor> DescribeSpecialGenerics(
87 const Scope &dtScope, const Scope &thisScope,
88 const DerivedTypeSpec *) const;
89 void DescribeSpecialGeneric(const GenericDetails &,
90 std::map<int, evaluate::StructureConstructor> &, const Scope &,
91 const DerivedTypeSpec *) 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 bool isTypeBound) 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 std::vector<evaluate::StructureConstructor> bindings{
599 DescribeBindings(dtScope, scope)};
600 AddValue(dtValues, derivedTypeSchema_, bindingDescCompName,
601 SaveDerivedPointerTarget(scope,
602 SaveObjectName(
603 (fir::kBindingTableSeparator + distinctName).str()),
604 std::move(bindings),
605 evaluate::ConstantSubscripts{
606 static_cast<evaluate::ConstantSubscript>(bindings.size())}));
607 // Describe "special" bindings to defined assignments, FINAL subroutines,
608 // and defined derived type I/O subroutines. Defined assignments and I/O
609 // subroutines override any parent bindings, but FINAL subroutines do not
610 // (the runtime will call all of them).
611 std::map<int, evaluate::StructureConstructor> specials{
612 DescribeSpecialGenerics(dtScope, dtScope, derivedTypeSpec)};
613 if (derivedTypeSpec) {
614 for (auto &ref : FinalsForDerivedTypeInstantiation(*derivedTypeSpec)) {
615 DescribeSpecialProc(specials, *ref, /*isAssignment-*/ false,
616 /*isFinal=*/true, std::nullopt, nullptr, derivedTypeSpec,
617 /*isTypeBound=*/true);
618 }
619 IncorporateDefinedIoGenericInterfaces(specials,
620 common::DefinedIo::ReadFormatted, &scope, derivedTypeSpec);
621 IncorporateDefinedIoGenericInterfaces(specials,
622 common::DefinedIo::ReadUnformatted, &scope, derivedTypeSpec);
623 IncorporateDefinedIoGenericInterfaces(specials,
624 common::DefinedIo::WriteFormatted, &scope, derivedTypeSpec);
625 IncorporateDefinedIoGenericInterfaces(specials,
626 common::DefinedIo::WriteUnformatted, &scope, derivedTypeSpec);
627 }
628 // Pack the special procedure bindings in ascending order of their "which"
629 // code values, and compile a little-endian bit-set of those codes for
630 // use in O(1) look-up at run time.
631 std::vector<evaluate::StructureConstructor> sortedSpecials;
632 for (auto &pair : specials) {
633 auto bit{std::uint32_t{1} << pair.first};
634 CHECK(!(specialBitSet & bit));
635 specialBitSet |= bit;
636 sortedSpecials.emplace_back(std::move(pair.second));
637 }
638 AddValue(dtValues, derivedTypeSchema_, "special"s,
639 SaveDerivedPointerTarget(scope,
640 SaveObjectName(
641 (fir::kSpecialBindingSeparator + distinctName).str()),
642 std::move(sortedSpecials),
643 evaluate::ConstantSubscripts{
644 static_cast<evaluate::ConstantSubscript>(specials.size())}));
645 }
646 AddValue(dtValues, derivedTypeSchema_, "specialbitset"s,
647 IntExpr<4>(specialBitSet));
648 // Note the presence/absence of a parent component
649 AddValue(dtValues, derivedTypeSchema_, "hasparent"s,
650 IntExpr<1>(dtScope.GetDerivedTypeParent() != nullptr));
651 // To avoid wasting run time attempting to initialize derived type
652 // instances without any initialized components, analyze the type
653 // and set a flag if there's nothing to do for it at run time.
654 AddValue(dtValues, derivedTypeSchema_, "noinitializationneeded"s,
655 IntExpr<1>(derivedTypeSpec &&
656 !derivedTypeSpec->HasDefaultInitialization(false, false)));
657 // Similarly, a flag to short-circuit destruction when not needed.
658 AddValue(dtValues, derivedTypeSchema_, "nodestructionneeded"s,
659 IntExpr<1>(derivedTypeSpec && !derivedTypeSpec->HasDestruction()));
660 // Similarly, a flag to short-circuit finalization when not needed.
661 AddValue(dtValues, derivedTypeSchema_, "nofinalizationneeded"s,
662 IntExpr<1>(
663 derivedTypeSpec && !MayRequireFinalization(*derivedTypeSpec)));
664 }
665 dtObject.get<ObjectEntityDetails>().set_init(MaybeExpr{
666 StructureExpr(Structure(derivedTypeSchema_, std::move(dtValues)))});
667 return &dtObject;
668}
669
670static const Symbol &GetSymbol(const Scope &schemata, SourceName name) {
671 auto iter{schemata.find(name)};
672 CHECK(iter != schemata.end());
673 const Symbol &symbol{*iter->second};
674 return symbol;
675}
676
677const Symbol &RuntimeTableBuilder::GetSchemaSymbol(const char *name) const {
678 return GetSymbol(
679 DEREF(tables_.schemata), SourceName{name, std::strlen(name)});
680}
681
682const DeclTypeSpec &RuntimeTableBuilder::GetSchema(
683 const char *schemaName) const {
684 Scope &schemata{DEREF(tables_.schemata)};
685 SourceName name{schemaName, std::strlen(schemaName)};
686 const Symbol &symbol{GetSymbol(schemata, name)};
687 CHECK(symbol.has<DerivedTypeDetails>());
688 CHECK(symbol.scope());
689 CHECK(symbol.scope()->IsDerivedType());
690 const DeclTypeSpec *spec{nullptr};
691 if (symbol.scope()->derivedTypeSpec()) {
692 DeclTypeSpec typeSpec{
693 DeclTypeSpec::TypeDerived, *symbol.scope()->derivedTypeSpec()};
694 spec = schemata.FindType(typeSpec);
695 }
696 if (!spec) {
697 DeclTypeSpec typeSpec{
698 DeclTypeSpec::TypeDerived, DerivedTypeSpec{name, symbol}};
699 spec = schemata.FindType(typeSpec);
700 }
701 if (!spec) {
702 spec = &schemata.MakeDerivedType(
703 DeclTypeSpec::TypeDerived, DerivedTypeSpec{name, symbol});
704 }
705 CHECK(spec->AsDerived());
706 return *spec;
707}
708
709SomeExpr RuntimeTableBuilder::GetEnumValue(const char *name) const {
710 const Symbol &symbol{GetSchemaSymbol(name)};
711 auto value{evaluate::ToInt64(symbol.get<ObjectEntityDetails>().init())};
712 CHECK(value.has_value());
713 return IntExpr<1>(*value);
714}
715
716Symbol &RuntimeTableBuilder::CreateObject(
717 const std::string &name, const DeclTypeSpec &type, Scope &scope) {
718 ObjectEntityDetails object;
719 object.set_type(type);
720 auto pair{scope.try_emplace(SaveObjectName(name),
721 Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))};
722 CHECK(pair.second);
723 Symbol &result{*pair.first->second};
724 SetReadOnlyCompilerCreatedFlags(result);
725 return result;
726}
727
728SourceName RuntimeTableBuilder::SaveObjectName(const std::string &name) {
729 return *tables_.names.insert(name).first;
730}
731
732SomeExpr RuntimeTableBuilder::SaveNameAsPointerTarget(
733 Scope &scope, const std::string &name) {
734 CHECK(!name.empty());
735 CHECK(name.front() != '.' || context_.IsTempName(name));
736 ObjectEntityDetails object;
737 auto len{static_cast<common::ConstantSubscript>(name.size())};
738 if (const auto *spec{scope.FindType(DeclTypeSpec{CharacterTypeSpec{
739 ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1}}})}) {
740 object.set_type(*spec);
741 } else {
742 object.set_type(scope.MakeCharacterType(
743 ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1}));
744 }
745 using evaluate::Ascii;
746 using AsciiExpr = evaluate::Expr<Ascii>;
747 object.set_init(evaluate::AsGenericExpr(AsciiExpr{name}));
748 Symbol &symbol{
749 *scope
750 .try_emplace(
751 SaveObjectName((fir::kNameStringSeparator + name).str()),
752 Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))
753 .first->second};
754 SetReadOnlyCompilerCreatedFlags(symbol);
755 return evaluate::AsGenericExpr(
756 AsciiExpr{evaluate::Designator<Ascii>{symbol}});
757}
758
759evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
760 const Symbol &symbol, const ObjectEntityDetails &object, Scope &scope,
761 Scope &dtScope, const std::string &distinctName,
762 const SymbolVector *parameters) {
763 evaluate::StructureConstructorValues values;
764 auto &foldingContext{context_.foldingContext()};
765 auto typeAndShape{evaluate::characteristics::TypeAndShape::Characterize(
766 symbol, foldingContext)};
767 CHECK(typeAndShape.has_value());
768 auto dyType{typeAndShape->type()};
769 int rank{typeAndShape->Rank()};
770 AddValue(values, componentSchema_, "name"s,
771 SaveNameAsPointerTarget(scope, symbol.name().ToString()));
772 AddValue(values, componentSchema_, "category"s,
773 IntExpr<1>(static_cast<int>(dyType.category())));
774 if (dyType.IsUnlimitedPolymorphic() ||
775 dyType.category() == TypeCategory::Derived) {
776 AddValue(values, componentSchema_, "kind"s, IntExpr<1>(0));
777 } else {
778 AddValue(values, componentSchema_, "kind"s, IntExpr<1>(dyType.kind()));
779 }
780 AddValue(values, componentSchema_, "offset"s, IntExpr<8>(symbol.offset()));
781 // CHARACTER length
782 auto len{typeAndShape->LEN()};
783 if (const semantics::DerivedTypeSpec *
784 pdtInstance{dtScope.derivedTypeSpec()}) {
785 auto restorer{foldingContext.WithPDTInstance(*pdtInstance)};
786 len = Fold(foldingContext, std::move(len));
787 }
788 if (dyType.category() == TypeCategory::Character && len) {
789 // Ignore IDIM(x) (represented as MAX(0, x))
790 if (const auto *clamped{evaluate::UnwrapExpr<
791 evaluate::Extremum<evaluate::SubscriptInteger>>(*len)}) {
792 if (clamped->ordering == evaluate::Ordering::Greater &&
793 clamped->left() == evaluate::Expr<evaluate::SubscriptInteger>{0}) {
794 len = common::Clone(clamped->right());
795 }
796 }
797 AddValue(values, componentSchema_, "characterlen"s,
798 evaluate::AsGenericExpr(GetValue(len, parameters)));
799 } else {
800 AddValue(values, componentSchema_, "characterlen"s,
801 PackageIntValueExpr(deferredEnum_));
802 }
803 // Describe component's derived type
804 std::vector<evaluate::StructureConstructor> lenParams;
805 if (dyType.category() == TypeCategory::Derived &&
806 !dyType.IsUnlimitedPolymorphic()) {
807 const DerivedTypeSpec &spec{dyType.GetDerivedTypeSpec()};
808 Scope *derivedScope{const_cast<Scope *>(
809 spec.scope() ? spec.scope() : spec.typeSymbol().scope())};
810 if (const Symbol *
811 derivedDescription{DescribeType(
812 dtScope&: DEREF(derivedScope), /*wantUninstantiatedPDT=*/false)}) {
813 AddValue(values, componentSchema_, "derived"s,
814 evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{
815 evaluate::Designator<evaluate::SomeDerived>{
816 DEREF(derivedDescription)}}));
817 // Package values of LEN parameters, if any
818 if (const SymbolVector *
819 specParams{GetTypeParameters(spec.typeSymbol())}) {
820 for (SymbolRef ref : *specParams) {
821 const auto &tpd{ref->get<TypeParamDetails>()};
822 if (tpd.attr() && *tpd.attr() == common::TypeParamAttr::Len) {
823 if (const ParamValue *
824 paramValue{spec.FindParameter(ref->name())}) {
825 lenParams.emplace_back(GetValue(*paramValue, parameters));
826 } else {
827 lenParams.emplace_back(GetValue(tpd.init(), parameters));
828 }
829 }
830 }
831 }
832 }
833 } else {
834 // Subtle: a category of Derived with a null derived type pointer
835 // signifies CLASS(*)
836 AddValue(values, componentSchema_, "derived"s,
837 SomeExpr{evaluate::NullPointer{}});
838 }
839 // LEN type parameter values for the component's type
840 if (!lenParams.empty()) {
841 AddValue(values, componentSchema_, "lenvalue"s,
842 SaveDerivedPointerTarget(scope,
843 SaveObjectName((fir::kLenParameterSeparator + distinctName +
844 fir::kNameSeparator + symbol.name().ToString())
845 .str()),
846 std::move(lenParams),
847 evaluate::ConstantSubscripts{
848 static_cast<evaluate::ConstantSubscript>(lenParams.size())}));
849 } else {
850 AddValue(values, componentSchema_, "lenvalue"s,
851 SomeExpr{evaluate::NullPointer{}});
852 }
853 // Shape information
854 AddValue(values, componentSchema_, "rank"s, IntExpr<1>(rank));
855 if (rank > 0 && !IsAllocatable(symbol) && !IsPointer(symbol)) {
856 std::vector<evaluate::StructureConstructor> bounds;
857 evaluate::NamedEntity entity{symbol};
858 for (int j{0}; j < rank; ++j) {
859 bounds.emplace_back(
860 GetValue(std::make_optional(
861 evaluate::GetRawLowerBound(foldingContext, entity, j)),
862 parameters));
863 bounds.emplace_back(GetValue(
864 evaluate::GetRawUpperBound(foldingContext, entity, j), parameters));
865 }
866 AddValue(values, componentSchema_, "bounds"s,
867 SaveDerivedPointerTarget(scope,
868 SaveObjectName((fir::kBoundsSeparator + distinctName +
869 fir::kNameSeparator + symbol.name().ToString())
870 .str()),
871 std::move(bounds), evaluate::ConstantSubscripts{2, rank}));
872 } else {
873 AddValue(
874 values, componentSchema_, "bounds"s, SomeExpr{evaluate::NullPointer{}});
875 }
876 // Default component initialization
877 bool hasDataInit{false};
878 if (IsAllocatable(symbol)) {
879 AddValue(values, componentSchema_, "genre"s, GetEnumValue("allocatable"));
880 } else if (IsPointer(symbol)) {
881 AddValue(values, componentSchema_, "genre"s, GetEnumValue("pointer"));
882 hasDataInit = InitializeDataPointer(
883 values, symbol, object, scope, dtScope, distinctName);
884 } else if (IsAutomatic(symbol)) {
885 AddValue(values, componentSchema_, "genre"s, GetEnumValue("automatic"));
886 } else {
887 AddValue(values, componentSchema_, "genre"s, GetEnumValue("data"));
888 hasDataInit = object.init().has_value();
889 if (hasDataInit) {
890 AddValue(values, componentSchema_, "initialization"s,
891 SaveObjectInit(scope,
892 SaveObjectName((fir::kComponentInitSeparator + distinctName +
893 fir::kNameSeparator + symbol.name().ToString())
894 .str()),
895 object));
896 }
897 }
898 if (!hasDataInit) {
899 AddValue(values, componentSchema_, "initialization"s,
900 SomeExpr{evaluate::NullPointer{}});
901 }
902 return {DEREF(componentSchema_.AsDerived()), std::move(values)};
903}
904
905evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
906 const Symbol &symbol, const ProcEntityDetails &proc, Scope &scope) {
907 evaluate::StructureConstructorValues values;
908 AddValue(values, procPtrSchema_, "name"s,
909 SaveNameAsPointerTarget(scope, symbol.name().ToString()));
910 AddValue(values, procPtrSchema_, "offset"s, IntExpr<8>(symbol.offset()));
911 if (auto init{proc.init()}; init && *init) {
912 AddValue(values, procPtrSchema_, "initialization"s,
913 SomeExpr{evaluate::ProcedureDesignator{**init}});
914 } else {
915 AddValue(values, procPtrSchema_, "initialization"s,
916 SomeExpr{evaluate::NullPointer{}});
917 }
918 return {DEREF(procPtrSchema_.AsDerived()), std::move(values)};
919}
920
921// Create a static pointer object with the same initialization
922// from whence the runtime can memcpy() the data pointer
923// component initialization.
924// Creates and interconnects the symbols, scopes, and types for
925// TYPE :: ptrDt
926// type, POINTER :: name
927// END TYPE
928// TYPE(ptrDt), TARGET, SAVE :: ptrInit = ptrDt(designator)
929// and then initializes the original component by setting
930// initialization = ptrInit
931// which takes the address of ptrInit because the type is C_PTR.
932// This technique of wrapping the data pointer component into
933// a derived type instance disables any reason for lowering to
934// attempt to dereference the RHS of an initializer, thereby
935// allowing the runtime to actually perform the initialization
936// by means of a simple memcpy() of the wrapped descriptor in
937// ptrInit to the data pointer component being initialized.
938bool RuntimeTableBuilder::InitializeDataPointer(
939 evaluate::StructureConstructorValues &values, const Symbol &symbol,
940 const ObjectEntityDetails &object, Scope &scope, Scope &dtScope,
941 const std::string &distinctName) {
942 if (object.init().has_value()) {
943 SourceName ptrDtName{SaveObjectName((fir::kDataPtrInitSeparator +
944 distinctName + fir::kNameSeparator + symbol.name().ToString())
945 .str())};
946 Symbol &ptrDtSym{
947 *scope.try_emplace(ptrDtName, Attrs{}, UnknownDetails{}).first->second};
948 SetReadOnlyCompilerCreatedFlags(ptrDtSym);
949 Scope &ptrDtScope{scope.MakeScope(Scope::Kind::DerivedType, &ptrDtSym)};
950 ignoreScopes_.insert(&ptrDtScope);
951 ObjectEntityDetails ptrDtObj;
952 ptrDtObj.set_type(DEREF(object.type()));
953 ptrDtObj.set_shape(object.shape());
954 Symbol &ptrDtComp{*ptrDtScope
955 .try_emplace(symbol.name(), Attrs{Attr::POINTER},
956 std::move(ptrDtObj))
957 .first->second};
958 DerivedTypeDetails ptrDtDetails;
959 ptrDtDetails.add_component(ptrDtComp);
960 ptrDtSym.set_details(std::move(ptrDtDetails));
961 ptrDtSym.set_scope(&ptrDtScope);
962 DeclTypeSpec &ptrDtDeclType{
963 scope.MakeDerivedType(DeclTypeSpec::Category::TypeDerived,
964 DerivedTypeSpec{ptrDtName, ptrDtSym})};
965 DerivedTypeSpec &ptrDtDerived{DEREF(ptrDtDeclType.AsDerived())};
966 ptrDtDerived.set_scope(ptrDtScope);
967 ptrDtDerived.CookParameters(context_.foldingContext());
968 ptrDtDerived.Instantiate(scope);
969 ObjectEntityDetails ptrInitObj;
970 ptrInitObj.set_type(ptrDtDeclType);
971 evaluate::StructureConstructorValues ptrInitValues;
972 AddValue(
973 ptrInitValues, ptrDtDeclType, symbol.name().ToString(), *object.init());
974 ptrInitObj.set_init(evaluate::AsGenericExpr(
975 Structure(ptrDtDeclType, std::move(ptrInitValues))));
976 AddValue(values, componentSchema_, "initialization"s,
977 SaveObjectInit(scope,
978 SaveObjectName((fir::kComponentInitSeparator + distinctName +
979 fir::kNameSeparator + symbol.name().ToString())
980 .str()),
981 ptrInitObj));
982 return true;
983 } else {
984 return false;
985 }
986}
987
988evaluate::StructureConstructor RuntimeTableBuilder::PackageIntValue(
989 const SomeExpr &genre, std::int64_t n) const {
990 evaluate::StructureConstructorValues xs;
991 AddValue(xs, valueSchema_, "genre"s, genre);
992 AddValue(xs, valueSchema_, "value"s, IntToExpr(n));
993 return Structure(valueSchema_, std::move(xs));
994}
995
996SomeExpr RuntimeTableBuilder::PackageIntValueExpr(
997 const SomeExpr &genre, std::int64_t n) const {
998 return StructureExpr(PackageIntValue(genre, n));
999}
1000
1001SymbolVector CollectBindings(const Scope &dtScope) {
1002 SymbolVector result;
1003 std::map<SourceName, Symbol *> localBindings;
1004 // Collect local bindings
1005 for (auto pair : dtScope) {
1006 Symbol &symbol{const_cast<Symbol &>(*pair.second)};
1007 if (auto *binding{symbol.detailsIf<ProcBindingDetails>()}) {
1008 localBindings.emplace(symbol.name(), &symbol);
1009 binding->set_numPrivatesNotOverridden(0);
1010 }
1011 }
1012 if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) {
1013 result = CollectBindings(*parentScope);
1014 // Apply overrides from the local bindings of the extended type
1015 for (auto iter{result.begin()}; iter != result.end(); ++iter) {
1016 const Symbol &symbol{**iter};
1017 auto overriderIter{localBindings.find(symbol.name())};
1018 if (overriderIter != localBindings.end()) {
1019 Symbol &overrider{*overriderIter->second};
1020 if (symbol.attrs().test(Attr::PRIVATE) &&
1021 !symbol.attrs().test(Attr::DEFERRED) &&
1022 FindModuleContaining(symbol.owner()) !=
1023 FindModuleContaining(dtScope)) {
1024 // Don't override inaccessible PRIVATE bindings, unless
1025 // they are deferred
1026 auto &binding{overrider.get<ProcBindingDetails>()};
1027 binding.set_numPrivatesNotOverridden(
1028 binding.numPrivatesNotOverridden() + 1);
1029 } else {
1030 *iter = overrider;
1031 localBindings.erase(overriderIter);
1032 }
1033 }
1034 }
1035 }
1036 // Add remaining (non-overriding) local bindings in name order to the result
1037 for (auto pair : localBindings) {
1038 result.push_back(*pair.second);
1039 }
1040 return result;
1041}
1042
1043std::vector<evaluate::StructureConstructor>
1044RuntimeTableBuilder::DescribeBindings(const Scope &dtScope, Scope &scope) {
1045 std::vector<evaluate::StructureConstructor> result;
1046 for (const SymbolRef &ref : CollectBindings(dtScope)) {
1047 evaluate::StructureConstructorValues values;
1048 AddValue(values, bindingSchema_, procCompName,
1049 SomeExpr{evaluate::ProcedureDesignator{
1050 ref.get().get<ProcBindingDetails>().symbol()}});
1051 AddValue(values, bindingSchema_, "name"s,
1052 SaveNameAsPointerTarget(scope, ref.get().name().ToString()));
1053 result.emplace_back(DEREF(bindingSchema_.AsDerived()), std::move(values));
1054 }
1055 return result;
1056}
1057
1058std::map<int, evaluate::StructureConstructor>
1059RuntimeTableBuilder::DescribeSpecialGenerics(const Scope &dtScope,
1060 const Scope &thisScope, const DerivedTypeSpec *derivedTypeSpec) const {
1061 std::map<int, evaluate::StructureConstructor> specials;
1062 if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) {
1063 specials =
1064 DescribeSpecialGenerics(*parentScope, thisScope, derivedTypeSpec);
1065 }
1066 for (const auto &pair : dtScope) {
1067 const Symbol &symbol{*pair.second};
1068 if (const auto *generic{symbol.detailsIf<GenericDetails>()}) {
1069 DescribeSpecialGeneric(*generic, specials, thisScope, derivedTypeSpec);
1070 }
1071 }
1072 return specials;
1073}
1074
1075void RuntimeTableBuilder::DescribeSpecialGeneric(const GenericDetails &generic,
1076 std::map<int, evaluate::StructureConstructor> &specials,
1077 const Scope &dtScope, const DerivedTypeSpec *derivedTypeSpec) const {
1078 common::visit(
1079 common::visitors{
1080 [&](const GenericKind::OtherKind &k) {
1081 if (k == GenericKind::OtherKind::Assignment) {
1082 for (auto ref : generic.specificProcs()) {
1083 DescribeSpecialProc(specials, *ref, /*isAssignment=*/true,
1084 /*isFinal=*/false, std::nullopt, &dtScope, derivedTypeSpec,
1085 /*isTypeBound=*/true);
1086 }
1087 }
1088 },
1089 [&](const common::DefinedIo &io) {
1090 switch (io) {
1091 case common::DefinedIo::ReadFormatted:
1092 case common::DefinedIo::ReadUnformatted:
1093 case common::DefinedIo::WriteFormatted:
1094 case common::DefinedIo::WriteUnformatted:
1095 for (auto ref : generic.specificProcs()) {
1096 DescribeSpecialProc(specials, *ref, /*isAssignment=*/false,
1097 /*isFinal=*/false, io, &dtScope, derivedTypeSpec,
1098 /*isTypeBound=*/true);
1099 }
1100 break;
1101 }
1102 },
1103 [](const auto &) {},
1104 },
1105 generic.kind().u);
1106}
1107
1108void RuntimeTableBuilder::DescribeSpecialProc(
1109 std::map<int, evaluate::StructureConstructor> &specials,
1110 const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
1111 std::optional<common::DefinedIo> io, const Scope *dtScope,
1112 const DerivedTypeSpec *derivedTypeSpec, bool isTypeBound) const {
1113 const auto *binding{specificOrBinding.detailsIf<ProcBindingDetails>()};
1114 if (binding && dtScope) { // use most recent override
1115 binding = &DEREF(dtScope->FindComponent(specificOrBinding.name()))
1116 .get<ProcBindingDetails>();
1117 }
1118 const Symbol &specific{*(binding ? &binding->symbol() : &specificOrBinding)};
1119 if (auto proc{evaluate::characteristics::Procedure::Characterize(
1120 specific, context_.foldingContext())}) {
1121 std::uint8_t isArgDescriptorSet{0};
1122 std::uint8_t isArgContiguousSet{0};
1123 int argThatMightBeDescriptor{0};
1124 MaybeExpr which;
1125 if (isAssignment) {
1126 // Only type-bound asst's with compatible types on both dummy arguments
1127 // are germane to the runtime, which needs only these to implement
1128 // component assignment as part of intrinsic assignment.
1129 // Non-type-bound generic INTERFACEs and assignments from incompatible
1130 // types must not be used for component intrinsic assignment.
1131 CHECK(proc->dummyArguments.size() == 2);
1132 const auto t1{
1133 DEREF(std::get_if<evaluate::characteristics::DummyDataObject>(
1134 &proc->dummyArguments[0].u))
1135 .type.type()};
1136 const auto t2{
1137 DEREF(std::get_if<evaluate::characteristics::DummyDataObject>(
1138 &proc->dummyArguments[1].u))
1139 .type.type()};
1140 if (!binding || t1.category() != TypeCategory::Derived ||
1141 t2.category() != TypeCategory::Derived ||
1142 t1.IsUnlimitedPolymorphic() || t2.IsUnlimitedPolymorphic()) {
1143 return;
1144 }
1145 if (!derivedTypeSpec ||
1146 !derivedTypeSpec->MatchesOrExtends(t1.GetDerivedTypeSpec()) ||
1147 !derivedTypeSpec->MatchesOrExtends(t2.GetDerivedTypeSpec())) {
1148 return;
1149 }
1150 which = proc->IsElemental() ? elementalAssignmentEnum_
1151 : scalarAssignmentEnum_;
1152 if (binding && binding->passName() &&
1153 *binding->passName() == proc->dummyArguments[1].name) {
1154 argThatMightBeDescriptor = 1;
1155 isArgDescriptorSet |= 2;
1156 } else {
1157 argThatMightBeDescriptor = 2; // the non-passed-object argument
1158 isArgDescriptorSet |= 1;
1159 }
1160 } else if (isFinal) {
1161 CHECK(binding == nullptr); // FINALs are not bindings
1162 CHECK(proc->dummyArguments.size() == 1);
1163 if (proc->IsElemental()) {
1164 which = elementalFinalEnum_;
1165 } else {
1166 const auto &dummyData{
1167 std::get<evaluate::characteristics::DummyDataObject>(
1168 proc->dummyArguments.at(0).u)};
1169 const auto &typeAndShape{dummyData.type};
1170 if (typeAndShape.attrs().test(
1171 evaluate::characteristics::TypeAndShape::Attr::AssumedRank)) {
1172 which = assumedRankFinalEnum_;
1173 isArgDescriptorSet |= 1;
1174 } else {
1175 which = scalarFinalEnum_;
1176 if (int rank{typeAndShape.Rank()}; rank > 0) {
1177 which = IntExpr<1>(ToInt64(which).value() + rank);
1178 if (dummyData.IsPassedByDescriptor(proc->IsBindC())) {
1179 argThatMightBeDescriptor = 1;
1180 }
1181 if (!typeAndShape.attrs().test(evaluate::characteristics::
1182 TypeAndShape::Attr::AssumedShape) ||
1183 dummyData.attrs.test(evaluate::characteristics::
1184 DummyDataObject::Attr::Contiguous)) {
1185 isArgContiguousSet |= 1;
1186 }
1187 }
1188 }
1189 }
1190 } else { // defined derived type I/O
1191 CHECK(proc->dummyArguments.size() >= 4);
1192 const auto *ddo{std::get_if<evaluate::characteristics::DummyDataObject>(
1193 &proc->dummyArguments[0].u)};
1194 if (!ddo) {
1195 return;
1196 }
1197 if (derivedTypeSpec &&
1198 !ddo->type.type().IsTkCompatibleWith(
1199 evaluate::DynamicType{*derivedTypeSpec})) {
1200 // Defined I/O specific procedure is not for this derived type.
1201 return;
1202 }
1203 if (ddo->type.type().IsPolymorphic()) {
1204 isArgDescriptorSet |= 1;
1205 }
1206 switch (io.value()) {
1207 case common::DefinedIo::ReadFormatted:
1208 which = readFormattedEnum_;
1209 break;
1210 case common::DefinedIo::ReadUnformatted:
1211 which = readUnformattedEnum_;
1212 break;
1213 case common::DefinedIo::WriteFormatted:
1214 which = writeFormattedEnum_;
1215 break;
1216 case common::DefinedIo::WriteUnformatted:
1217 which = writeUnformattedEnum_;
1218 break;
1219 }
1220 }
1221 if (argThatMightBeDescriptor != 0) {
1222 if (const auto *dummyData{
1223 std::get_if<evaluate::characteristics::DummyDataObject>(
1224 &proc->dummyArguments.at(argThatMightBeDescriptor - 1).u)}) {
1225 if (dummyData->IsPassedByDescriptor(proc->IsBindC())) {
1226 isArgDescriptorSet |= 1 << (argThatMightBeDescriptor - 1);
1227 }
1228 }
1229 }
1230 evaluate::StructureConstructorValues values;
1231 auto index{evaluate::ToInt64(which)};
1232 CHECK(index.has_value());
1233 AddValue(
1234 values, specialSchema_, "which"s, SomeExpr{std::move(which.value())});
1235 AddValue(values, specialSchema_, "isargdescriptorset"s,
1236 IntExpr<1>(isArgDescriptorSet));
1237 AddValue(values, specialSchema_, "istypebound"s,
1238 IntExpr<1>(isTypeBound ? 1 : 0));
1239 AddValue(values, specialSchema_, "isargcontiguousset"s,
1240 IntExpr<1>(isArgContiguousSet));
1241 AddValue(values, specialSchema_, procCompName,
1242 SomeExpr{evaluate::ProcedureDesignator{specific}});
1243 // index might already be present in the case of an override
1244 specials.insert_or_assign(*index,
1245 evaluate::StructureConstructor{
1246 DEREF(specialSchema_.AsDerived()), std::move(values)});
1247 }
1248}
1249
1250void RuntimeTableBuilder::IncorporateDefinedIoGenericInterfaces(
1251 std::map<int, evaluate::StructureConstructor> &specials,
1252 common::DefinedIo definedIo, const Scope *scope,
1253 const DerivedTypeSpec *derivedTypeSpec) {
1254 SourceName name{GenericKind::AsFortran(definedIo)};
1255 for (; !scope->IsGlobal(); scope = &scope->parent()) {
1256 if (auto asst{scope->find(name)}; asst != scope->end()) {
1257 const Symbol &generic{asst->second->GetUltimate()};
1258 const auto &genericDetails{generic.get<GenericDetails>()};
1259 CHECK(std::holds_alternative<common::DefinedIo>(genericDetails.kind().u));
1260 CHECK(std::get<common::DefinedIo>(genericDetails.kind().u) == definedIo);
1261 for (auto ref : genericDetails.specificProcs()) {
1262 DescribeSpecialProc(specials, *ref, false, false, definedIo, nullptr,
1263 derivedTypeSpec, false);
1264 }
1265 }
1266 }
1267}
1268
1269RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(
1270 SemanticsContext &context) {
1271 RuntimeDerivedTypeTables result;
1272 // Do not attempt to read __fortran_type_info.mod when compiling
1273 // the module on which it depends.
1274 const auto &allSources{context.allCookedSources().allSources()};
1275 if (auto firstProv{allSources.GetFirstFileProvenance()}) {
1276 if (const auto *srcFile{allSources.GetSourceFile(firstProv->start())}) {
1277 if (srcFile->path().find("__fortran_builtins.f90") != std::string::npos) {
1278 return result;
1279 }
1280 }
1281 }
1282 result.schemata = context.GetBuiltinModule(typeInfoBuiltinModule);
1283 if (result.schemata) {
1284 RuntimeTableBuilder builder{context, result};
1285 builder.DescribeTypes(scope&: context.globalScope(), inSchemata: false);
1286 }
1287 return result;
1288}
1289
1290// Find the type of a defined I/O procedure's interface's initial "dtv"
1291// dummy argument. Returns a non-null DeclTypeSpec pointer only if that
1292// dtv argument exists and is a derived type.
1293static const DeclTypeSpec *GetDefinedIoSpecificArgType(const Symbol &specific) {
1294 const Symbol *interface{&specific.GetUltimate()};
1295 if (const auto *procEntity{specific.detailsIf<ProcEntityDetails>()}) {
1296 interface = procEntity->procInterface();
1297 }
1298 if (interface) {
1299 if (const SubprogramDetails *
1300 subprogram{interface->detailsIf<SubprogramDetails>()};
1301 subprogram && !subprogram->dummyArgs().empty()) {
1302 if (const Symbol * dtvArg{subprogram->dummyArgs().at(0)}) {
1303 if (const DeclTypeSpec * declType{dtvArg->GetType()}) {
1304 return declType->AsDerived() ? declType : nullptr;
1305 }
1306 }
1307 }
1308 }
1309 return nullptr;
1310}
1311
1312// Locate a particular scope's generic interface for a specific kind of
1313// defined I/O.
1314static const Symbol *FindGenericDefinedIo(
1315 const Scope &scope, common::DefinedIo which) {
1316 if (const Symbol * symbol{scope.FindSymbol(GenericKind::AsFortran(which))}) {
1317 const Symbol &generic{symbol->GetUltimate()};
1318 const auto &genericDetails{generic.get<GenericDetails>()};
1319 CHECK(std::holds_alternative<common::DefinedIo>(genericDetails.kind().u));
1320 CHECK(std::get<common::DefinedIo>(genericDetails.kind().u) == which);
1321 return &generic;
1322 } else {
1323 return nullptr;
1324 }
1325}
1326
1327std::multimap<const Symbol *, NonTbpDefinedIo>
1328CollectNonTbpDefinedIoGenericInterfaces(
1329 const Scope &scope, bool useRuntimeTypeInfoEntries) {
1330 std::multimap<const Symbol *, NonTbpDefinedIo> result;
1331 if (!scope.IsTopLevel() &&
1332 (scope.GetImportKind() == Scope::ImportKind::All ||
1333 scope.GetImportKind() == Scope::ImportKind::Default)) {
1334 result = CollectNonTbpDefinedIoGenericInterfaces(
1335 scope.parent(), useRuntimeTypeInfoEntries);
1336 }
1337 if (scope.kind() != Scope::Kind::DerivedType) {
1338 for (common::DefinedIo which :
1339 {common::DefinedIo::ReadFormatted, common::DefinedIo::ReadUnformatted,
1340 common::DefinedIo::WriteFormatted,
1341 common::DefinedIo::WriteUnformatted}) {
1342 if (const Symbol * generic{FindGenericDefinedIo(scope, which)}) {
1343 for (auto specific : generic->get<GenericDetails>().specificProcs()) {
1344 if (const DeclTypeSpec *
1345 declType{GetDefinedIoSpecificArgType(*specific)}) {
1346 const DerivedTypeSpec &derived{DEREF(declType->AsDerived())};
1347 if (const Symbol *
1348 dtDesc{derived.scope()
1349 ? derived.scope()->runtimeDerivedTypeDescription()
1350 : nullptr}) {
1351 if (useRuntimeTypeInfoEntries &&
1352 &derived.scope()->parent() == &generic->owner()) {
1353 // This non-TBP defined I/O generic was defined in the
1354 // same scope as the derived type, and it will be
1355 // included in the derived type's special bindings
1356 // by IncorporateDefinedIoGenericInterfaces().
1357 } else {
1358 // Local scope's specific overrides host's for this type
1359 bool updated{false};
1360 for (auto [iter, end]{result.equal_range(dtDesc)}; iter != end;
1361 ++iter) {
1362 NonTbpDefinedIo &nonTbp{iter->second};
1363 if (nonTbp.definedIo == which) {
1364 nonTbp.subroutine = &*specific;
1365 nonTbp.isDtvArgPolymorphic = declType->IsPolymorphic();
1366 updated = true;
1367 }
1368 }
1369 if (!updated) {
1370 result.emplace(dtDesc,
1371 NonTbpDefinedIo{
1372 &*specific, which, declType->IsPolymorphic()});
1373 }
1374 }
1375 }
1376 }
1377 }
1378 }
1379 }
1380 }
1381 return result;
1382}
1383
1384// ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces()
1385//
1386// Returns a true result when a kind of defined I/O generic procedure
1387// has a type (from a symbol or a NAMELIST) such that
1388// (1) there is a specific procedure matching that type for a non-type-bound
1389// generic defined in the scope of the type, and
1390// (2) that specific procedure is unavailable or overridden in a particular
1391// local scope.
1392// Specific procedures of non-type-bound defined I/O generic interfaces
1393// declared in the scope of a derived type are identified as special bindings
1394// in the derived type's runtime type information, as if they had been
1395// type-bound. This predicate is meant to determine local situations in
1396// which those special bindings are not to be used. Its result is intended
1397// to be put into the "ignoreNonTbpEntries" flag of
1398// runtime::NonTbpDefinedIoTable and passed (negated) as the
1399// "useRuntimeTypeInfoEntries" argument of
1400// CollectNonTbpDefinedIoGenericInterfaces() above.
1401
1402static const Symbol *FindSpecificDefinedIo(const Scope &scope,
1403 const evaluate::DynamicType &derived, common::DefinedIo which) {
1404 if (const Symbol * generic{FindGenericDefinedIo(scope, which)}) {
1405 for (auto ref : generic->get<GenericDetails>().specificProcs()) {
1406 const Symbol &specific{*ref};
1407 if (const DeclTypeSpec *
1408 thisType{GetDefinedIoSpecificArgType(specific)}) {
1409 if (evaluate::DynamicType{DEREF(thisType->AsDerived()), true}
1410 .IsTkCompatibleWith(derived)) {
1411 return &specific.GetUltimate();
1412 }
1413 }
1414 }
1415 }
1416 return nullptr;
1417}
1418
1419bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1420 const Scope &scope, const DerivedTypeSpec *derived) {
1421 if (!derived) {
1422 return false;
1423 }
1424 const Symbol &typeSymbol{derived->typeSymbol()};
1425 const Scope &typeScope{typeSymbol.GetUltimate().owner()};
1426 evaluate::DynamicType dyType{*derived};
1427 for (common::DefinedIo which :
1428 {common::DefinedIo::ReadFormatted, common::DefinedIo::ReadUnformatted,
1429 common::DefinedIo::WriteFormatted,
1430 common::DefinedIo::WriteUnformatted}) {
1431 if (const Symbol *
1432 specific{FindSpecificDefinedIo(typeScope, dyType, which)}) {
1433 // There's a non-TBP defined I/O procedure in the scope of the type's
1434 // definition that applies to this type. It will appear in the type's
1435 // runtime information. Determine whether it still applies in the
1436 // scope of interest.
1437 if (FindSpecificDefinedIo(scope, dyType, which) != specific) {
1438 return true;
1439 }
1440 }
1441 }
1442 return false;
1443}
1444
1445bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1446 const Scope &scope, const DeclTypeSpec *type) {
1447 return type &&
1448 ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1449 scope, type->AsDerived());
1450}
1451
1452bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1453 const Scope &scope, const Symbol *symbol) {
1454 if (!symbol) {
1455 return false;
1456 }
1457 return common::visit(
1458 common::visitors{
1459 [&](const NamelistDetails &x) {
1460 for (auto ref : x.objects()) {
1461 if (ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1462 scope, &*ref)) {
1463 return true;
1464 }
1465 }
1466 return false;
1467 },
1468 [&](const auto &) {
1469 return ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1470 scope, symbol->GetType());
1471 },
1472 },
1473 symbol->GetUltimate().details());
1474}
1475
1476} // namespace Fortran::semantics
1477

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