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

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