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 <list>
18 #include <map>
19 #include <string>
20 
21 namespace Fortran::semantics {
22 
23 static int FindLenParameterIndex(
24     const SymbolVector &parameters, const Symbol &symbol) {
25   int lenIndex{0};
26   for (SymbolRef ref : parameters) {
27     if (&*ref == &symbol) {
28       return lenIndex;
29     }
30     if (ref->get<TypeParamDetails>().attr() == common::TypeParamAttr::Len) {
31       ++lenIndex;
32     }
33   }
34   DIE("Length type parameter not found in parameter order");
35   return -1;
36 }
37 
38 class RuntimeTableBuilder {
39 public:
40   RuntimeTableBuilder(SemanticsContext &, RuntimeDerivedTypeTables &);
41   void DescribeTypes(Scope &scope);
42 
43 private:
44   const Symbol *DescribeType(Scope &);
45   const Symbol &GetSchemaSymbol(const char *) const;
46   const DeclTypeSpec &GetSchema(const char *) const;
47   SomeExpr GetEnumValue(const char *) const;
48   Symbol &CreateObject(const std::string &, const DeclTypeSpec &, Scope &);
49   // The names of created symbols are saved in and owned by the
50   // RuntimeDerivedTypeTables instance returned by
51   // BuildRuntimeDerivedTypeTables() so that references to those names remain
52   // valid for lowering.
53   SourceName SaveObjectName(const std::string &);
54   SomeExpr SaveNameAsPointerTarget(Scope &, const std::string &);
55   const SymbolVector *GetTypeParameters(const Symbol &);
56   evaluate::StructureConstructor DescribeComponent(const Symbol &,
57       const ObjectEntityDetails &, Scope &, Scope &,
58       const std::string &distinctName, const SymbolVector *parameters);
59   evaluate::StructureConstructor DescribeComponent(
60       const Symbol &, const ProcEntityDetails &, Scope &);
61   evaluate::StructureConstructor PackageIntValue(
62       const SomeExpr &genre, std::int64_t = 0) const;
63   SomeExpr PackageIntValueExpr(const SomeExpr &genre, std::int64_t = 0) const;
64   std::vector<const Symbol *> CollectBindings(const Scope &dtScope) const;
65   std::vector<evaluate::StructureConstructor> DescribeBindings(
66       const Scope &dtScope, Scope &);
67   void DescribeGeneric(
68       const GenericDetails &, std::vector<evaluate::StructureConstructor> &);
69   void DescribeSpecialProc(std::vector<evaluate::StructureConstructor> &,
70       const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
71       std::optional<GenericKind::DefinedIo>);
72   void IncorporateDefinedIoGenericInterfaces(
73       std::vector<evaluate::StructureConstructor> &, SourceName,
74       GenericKind::DefinedIo, const Scope *);
75 
76   // Instantiated for ParamValue and Bound
77   template <typename A>
78   evaluate::StructureConstructor GetValue(
79       const A &x, const SymbolVector *parameters) {
80     if (x.isExplicit()) {
81       return GetValue(x.GetExplicit(), parameters);
82     } else {
83       return PackageIntValue(deferredEnum_);
84     }
85   }
86 
87   // Specialization for optional<Expr<SomeInteger and SubscriptInteger>>
88   template <typename T>
89   evaluate::StructureConstructor GetValue(
90       const std::optional<evaluate::Expr<T>> &expr,
91       const SymbolVector *parameters) {
92     if (auto constValue{evaluate::ToInt64(expr)}) {
93       return PackageIntValue(explicitEnum_, *constValue);
94     }
95     if (expr) {
96       if (parameters) {
97         if (const Symbol * lenParam{evaluate::ExtractBareLenParameter(*expr)}) {
98           return PackageIntValue(
99               lenParameterEnum_, FindLenParameterIndex(*parameters, *lenParam));
100         }
101       }
102       context_.Say(location_,
103           "Specification expression '%s' is neither constant nor a length "
104           "type parameter"_err_en_US,
105           expr->AsFortran());
106     }
107     return PackageIntValue(deferredEnum_);
108   }
109 
110   SemanticsContext &context_;
111   RuntimeDerivedTypeTables &tables_;
112   std::map<const Symbol *, SymbolVector> orderedTypeParameters_;
113   int anonymousTypes_{0};
114 
115   const DeclTypeSpec &derivedTypeSchema_; // TYPE(DerivedType)
116   const DeclTypeSpec &componentSchema_; // TYPE(Component)
117   const DeclTypeSpec &procPtrSchema_; // TYPE(ProcPtrComponent)
118   const DeclTypeSpec &valueSchema_; // TYPE(Value)
119   const DeclTypeSpec &bindingSchema_; // TYPE(Binding)
120   const DeclTypeSpec &specialSchema_; // TYPE(SpecialBinding)
121   SomeExpr deferredEnum_; // Value::Genre::Deferred
122   SomeExpr explicitEnum_; // Value::Genre::Explicit
123   SomeExpr lenParameterEnum_; // Value::Genre::LenParameter
124   SomeExpr assignmentEnum_; // SpecialBinding::Which::Assignment
125   SomeExpr
126       elementalAssignmentEnum_; // SpecialBinding::Which::ElementalAssignment
127   SomeExpr finalEnum_; // SpecialBinding::Which::Final
128   SomeExpr elementalFinalEnum_; // SpecialBinding::Which::ElementalFinal
129   SomeExpr assumedRankFinalEnum_; // SpecialBinding::Which::AssumedRankFinal
130   SomeExpr readFormattedEnum_; // SpecialBinding::Which::ReadFormatted
131   SomeExpr readUnformattedEnum_; // SpecialBinding::Which::ReadUnformatted
132   SomeExpr writeFormattedEnum_; // SpecialBinding::Which::WriteFormatted
133   SomeExpr writeUnformattedEnum_; // SpecialBinding::Which::WriteUnformatted
134   parser::CharBlock location_;
135 };
136 
137 RuntimeTableBuilder::RuntimeTableBuilder(
138     SemanticsContext &c, RuntimeDerivedTypeTables &t)
139     : context_{c}, tables_{t}, derivedTypeSchema_{GetSchema("derivedtype")},
140       componentSchema_{GetSchema("component")}, procPtrSchema_{GetSchema(
141                                                     "procptrcomponent")},
142       valueSchema_{GetSchema("value")}, bindingSchema_{GetSchema("binding")},
143       specialSchema_{GetSchema("specialbinding")}, deferredEnum_{GetEnumValue(
144                                                        "deferred")},
145       explicitEnum_{GetEnumValue("explicit")}, lenParameterEnum_{GetEnumValue(
146                                                    "lenparameter")},
147       assignmentEnum_{GetEnumValue("assignment")},
148       elementalAssignmentEnum_{GetEnumValue("elementalassignment")},
149       finalEnum_{GetEnumValue("final")}, elementalFinalEnum_{GetEnumValue(
150                                              "elementalfinal")},
151       assumedRankFinalEnum_{GetEnumValue("assumedrankfinal")},
152       readFormattedEnum_{GetEnumValue("readformatted")},
153       readUnformattedEnum_{GetEnumValue("readunformatted")},
154       writeFormattedEnum_{GetEnumValue("writeformatted")},
155       writeUnformattedEnum_{GetEnumValue("writeunformatted")} {}
156 
157 void RuntimeTableBuilder::DescribeTypes(Scope &scope) {
158   if (&scope == tables_.schemata) {
159     return; // don't loop trying to describe a schema...
160   }
161   if (scope.IsDerivedType()) {
162     DescribeType(scope);
163   } else {
164     for (Scope &child : scope.children()) {
165       DescribeTypes(child);
166     }
167   }
168 }
169 
170 // Returns derived type instantiation's parameters in declaration order
171 const SymbolVector *RuntimeTableBuilder::GetTypeParameters(
172     const Symbol &symbol) {
173   auto iter{orderedTypeParameters_.find(&symbol)};
174   if (iter != orderedTypeParameters_.end()) {
175     return &iter->second;
176   } else {
177     return &orderedTypeParameters_
178                 .emplace(&symbol, OrderParameterDeclarations(symbol))
179                 .first->second;
180   }
181 }
182 
183 static Scope &GetContainingNonDerivedScope(Scope &scope) {
184   Scope *p{&scope};
185   while (p->IsDerivedType()) {
186     p = &p->parent();
187   }
188   return *p;
189 }
190 
191 static const Symbol &GetSchemaField(
192     const DerivedTypeSpec &derived, const std::string &name) {
193   const Scope &scope{
194       DEREF(derived.scope() ? derived.scope() : derived.typeSymbol().scope())};
195   auto iter{scope.find(SourceName(name))};
196   CHECK(iter != scope.end());
197   return *iter->second;
198 }
199 
200 static const Symbol &GetSchemaField(
201     const DeclTypeSpec &derived, const std::string &name) {
202   return GetSchemaField(DEREF(derived.AsDerived()), name);
203 }
204 
205 static evaluate::StructureConstructorValues &AddValue(
206     evaluate::StructureConstructorValues &values, const DeclTypeSpec &spec,
207     const std::string &name, SomeExpr &&x) {
208   values.emplace(GetSchemaField(spec, name), std::move(x));
209   return values;
210 }
211 
212 static evaluate::StructureConstructorValues &AddValue(
213     evaluate::StructureConstructorValues &values, const DeclTypeSpec &spec,
214     const std::string &name, const SomeExpr &x) {
215   values.emplace(GetSchemaField(spec, name), x);
216   return values;
217 }
218 
219 static SomeExpr IntToExpr(std::int64_t n) {
220   return evaluate::AsGenericExpr(evaluate::ExtentExpr{n});
221 }
222 
223 static evaluate::StructureConstructor Structure(
224     const DeclTypeSpec &spec, evaluate::StructureConstructorValues &&values) {
225   return {DEREF(spec.AsDerived()), std::move(values)};
226 }
227 
228 static SomeExpr StructureExpr(evaluate::StructureConstructor &&x) {
229   return SomeExpr{evaluate::Expr<evaluate::SomeDerived>{std::move(x)}};
230 }
231 
232 static int GetIntegerKind(const Symbol &symbol) {
233   auto dyType{evaluate::DynamicType::From(symbol)};
234   CHECK(dyType && dyType->category() == TypeCategory::Integer);
235   return dyType->kind();
236 }
237 
238 // Save a rank-1 array constant of some numeric type as an
239 // initialized data object in a scope.
240 template <typename T>
241 static SomeExpr SaveNumericPointerTarget(
242     Scope &scope, SourceName name, std::vector<typename T::Scalar> &&x) {
243   if (x.empty()) {
244     return SomeExpr{evaluate::NullPointer{}};
245   } else {
246     ObjectEntityDetails object;
247     if (const auto *spec{scope.FindType(
248             DeclTypeSpec{NumericTypeSpec{T::category, KindExpr{T::kind}}})}) {
249       object.set_type(*spec);
250     } else {
251       object.set_type(scope.MakeNumericType(T::category, KindExpr{T::kind}));
252     }
253     auto elements{static_cast<evaluate::ConstantSubscript>(x.size())};
254     ArraySpec arraySpec;
255     arraySpec.push_back(ShapeSpec::MakeExplicit(Bound{0}, Bound{elements - 1}));
256     object.set_shape(arraySpec);
257     object.set_init(evaluate::AsGenericExpr(evaluate::Constant<T>{
258         std::move(x), evaluate::ConstantSubscripts{elements}}));
259     const Symbol &symbol{
260         *scope
261              .try_emplace(
262                  name, Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))
263              .first->second};
264     return evaluate::AsGenericExpr(
265         evaluate::Expr<T>{evaluate::Designator<T>{symbol}});
266   }
267 }
268 
269 // Save an arbitrarily shaped array constant of some derived type
270 // as an initialized data object in a scope.
271 static SomeExpr SaveDerivedPointerTarget(Scope &scope, SourceName name,
272     std::vector<evaluate::StructureConstructor> &&x,
273     evaluate::ConstantSubscripts &&shape) {
274   if (x.empty()) {
275     return SomeExpr{evaluate::NullPointer{}};
276   } else {
277     const auto &derivedType{x.front().GetType().GetDerivedTypeSpec()};
278     ObjectEntityDetails object;
279     DeclTypeSpec typeSpec{DeclTypeSpec::TypeDerived, derivedType};
280     if (const DeclTypeSpec * spec{scope.FindType(typeSpec)}) {
281       object.set_type(*spec);
282     } else {
283       object.set_type(scope.MakeDerivedType(
284           DeclTypeSpec::TypeDerived, common::Clone(derivedType)));
285     }
286     if (!shape.empty()) {
287       ArraySpec arraySpec;
288       for (auto n : shape) {
289         arraySpec.push_back(ShapeSpec::MakeExplicit(Bound{0}, Bound{n - 1}));
290       }
291       object.set_shape(arraySpec);
292     }
293     object.set_init(
294         evaluate::AsGenericExpr(evaluate::Constant<evaluate::SomeDerived>{
295             derivedType, std::move(x), std::move(shape)}));
296     const Symbol &symbol{
297         *scope
298              .try_emplace(
299                  name, Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))
300              .first->second};
301     return evaluate::AsGenericExpr(
302         evaluate::Designator<evaluate::SomeDerived>{symbol});
303   }
304 }
305 
306 static SomeExpr SaveObjectInit(
307     Scope &scope, SourceName name, const ObjectEntityDetails &object) {
308   const Symbol &symbol{*scope
309                             .try_emplace(name, Attrs{Attr::TARGET, Attr::SAVE},
310                                 ObjectEntityDetails{object})
311                             .first->second};
312   CHECK(symbol.get<ObjectEntityDetails>().init().has_value());
313   return evaluate::AsGenericExpr(
314       evaluate::Designator<evaluate::SomeDerived>{symbol});
315 }
316 
317 const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
318   if (const Symbol * info{dtScope.runtimeDerivedTypeDescription()}) {
319     return info;
320   }
321   const DerivedTypeSpec *derivedTypeSpec{dtScope.derivedTypeSpec()};
322   const Symbol *dtSymbol{
323       derivedTypeSpec ? &derivedTypeSpec->typeSymbol() : dtScope.symbol()};
324   if (!dtSymbol) {
325     return nullptr;
326   }
327   auto locationRestorer{common::ScopedSet(location_, dtSymbol->name())};
328   // Check for an existing description that can be imported from a USE'd module
329   std::string typeName{dtSymbol->name().ToString()};
330   if (typeName.empty() || typeName[0] == '.') {
331     return nullptr;
332   }
333   std::string distinctName{typeName};
334   if (&dtScope != dtSymbol->scope()) {
335     distinctName += "."s + std::to_string(anonymousTypes_++);
336   }
337   std::string dtDescName{".dt."s + distinctName};
338   Scope &scope{GetContainingNonDerivedScope(dtScope)};
339   if (distinctName == typeName && scope.IsModule()) {
340     if (const Symbol * description{scope.FindSymbol(SourceName{dtDescName})}) {
341       dtScope.set_runtimeDerivedTypeDescription(*description);
342       return description;
343     }
344   }
345   // Create a new description object before populating it so that mutual
346   // references will work as pointer targets.
347   Symbol &dtObject{CreateObject(dtDescName, derivedTypeSchema_, scope)};
348   dtScope.set_runtimeDerivedTypeDescription(dtObject);
349   evaluate::StructureConstructorValues dtValues;
350   AddValue(dtValues, derivedTypeSchema_, "name"s,
351       SaveNameAsPointerTarget(scope, typeName));
352   bool isPDTdefinition{
353       !derivedTypeSpec && dtScope.IsParameterizedDerivedType()};
354   if (!isPDTdefinition) {
355     auto sizeInBytes{static_cast<common::ConstantSubscript>(dtScope.size())};
356     if (auto alignment{dtScope.alignment().value_or(0)}) {
357       sizeInBytes += alignment - 1;
358       sizeInBytes /= alignment;
359       sizeInBytes *= alignment;
360     }
361     AddValue(
362         dtValues, derivedTypeSchema_, "sizeinbytes"s, IntToExpr(sizeInBytes));
363   }
364   const Symbol *parentDescObject{nullptr};
365   if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) {
366     parentDescObject = DescribeType(*const_cast<Scope *>(parentScope));
367   }
368   if (parentDescObject) {
369     AddValue(dtValues, derivedTypeSchema_, "parent"s,
370         evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{
371             evaluate::Designator<evaluate::SomeDerived>{*parentDescObject}}));
372   } else {
373     AddValue(dtValues, derivedTypeSchema_, "parent"s,
374         SomeExpr{evaluate::NullPointer{}});
375   }
376   bool isPDTinstantiation{derivedTypeSpec && &dtScope != dtSymbol->scope()};
377   if (isPDTinstantiation) {
378     // is PDT instantiation
379     const Symbol *uninstDescObject{
380         DescribeType(DEREF(const_cast<Scope *>(dtSymbol->scope())))};
381     AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s,
382         evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{
383             evaluate::Designator<evaluate::SomeDerived>{
384                 DEREF(uninstDescObject)}}));
385   } else {
386     AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s,
387         SomeExpr{evaluate::NullPointer{}});
388   }
389 
390   // TODO: compute typeHash
391 
392   using Int8 = evaluate::Type<TypeCategory::Integer, 8>;
393   using Int1 = evaluate::Type<TypeCategory::Integer, 1>;
394   std::vector<Int8::Scalar> kinds;
395   std::vector<Int1::Scalar> lenKinds;
396   const SymbolVector *parameters{GetTypeParameters(*dtSymbol)};
397   if (parameters) {
398     // Package the derived type's parameters in declaration order for
399     // each category of parameter.  KIND= type parameters are described
400     // by their instantiated (or default) values, while LEN= type
401     // parameters are described by their INTEGER kinds.
402     for (SymbolRef ref : *parameters) {
403       const auto &tpd{ref->get<TypeParamDetails>()};
404       if (tpd.attr() == common::TypeParamAttr::Kind) {
405         auto value{evaluate::ToInt64(tpd.init()).value_or(0)};
406         if (derivedTypeSpec) {
407           if (const auto *pv{derivedTypeSpec->FindParameter(ref->name())}) {
408             if (pv->GetExplicit()) {
409               if (auto instantiatedValue{
410                       evaluate::ToInt64(*pv->GetExplicit())}) {
411                 value = *instantiatedValue;
412               }
413             }
414           }
415         }
416         kinds.emplace_back(value);
417       } else { // LEN= parameter
418         lenKinds.emplace_back(GetIntegerKind(*ref));
419       }
420     }
421   }
422   AddValue(dtValues, derivedTypeSchema_, "kindparameter"s,
423       SaveNumericPointerTarget<Int8>(
424           scope, SaveObjectName(".kp."s + distinctName), std::move(kinds)));
425   AddValue(dtValues, derivedTypeSchema_, "lenparameterkind"s,
426       SaveNumericPointerTarget<Int1>(
427           scope, SaveObjectName(".lpk."s + distinctName), std::move(lenKinds)));
428   // Traverse the components of the derived type
429   if (!isPDTdefinition) {
430     std::vector<const Symbol *> dataComponentSymbols;
431     std::vector<evaluate::StructureConstructor> procPtrComponents;
432     std::vector<evaluate::StructureConstructor> specials;
433     for (const auto &pair : dtScope) {
434       const Symbol &symbol{*pair.second};
435       auto locationRestorer{common::ScopedSet(location_, symbol.name())};
436       std::visit(
437           common::visitors{
438               [&](const TypeParamDetails &) {
439                 // already handled above in declaration order
440               },
441               [&](const ObjectEntityDetails &) {
442                 dataComponentSymbols.push_back(&symbol);
443               },
444               [&](const ProcEntityDetails &proc) {
445                 if (IsProcedurePointer(symbol)) {
446                   procPtrComponents.emplace_back(
447                       DescribeComponent(symbol, proc, scope));
448                 }
449               },
450               [&](const ProcBindingDetails &) { // handled in a later pass
451               },
452               [&](const GenericDetails &generic) {
453                 DescribeGeneric(generic, specials);
454               },
455               [&](const auto &) {
456                 common::die(
457                     "unexpected details on symbol '%s' in derived type scope",
458                     symbol.name().ToString().c_str());
459               },
460           },
461           symbol.details());
462     }
463     // Sort the data component symbols by offset before emitting them
464     std::sort(dataComponentSymbols.begin(), dataComponentSymbols.end(),
465         [](const Symbol *x, const Symbol *y) {
466           return x->offset() < y->offset();
467         });
468     std::vector<evaluate::StructureConstructor> dataComponents;
469     for (const Symbol *symbol : dataComponentSymbols) {
470       auto locationRestorer{common::ScopedSet(location_, symbol->name())};
471       dataComponents.emplace_back(
472           DescribeComponent(*symbol, symbol->get<ObjectEntityDetails>(), scope,
473               dtScope, distinctName, parameters));
474     }
475     AddValue(dtValues, derivedTypeSchema_, "component"s,
476         SaveDerivedPointerTarget(scope, SaveObjectName(".c."s + distinctName),
477             std::move(dataComponents),
478             evaluate::ConstantSubscripts{
479                 static_cast<evaluate::ConstantSubscript>(
480                     dataComponents.size())}));
481     AddValue(dtValues, derivedTypeSchema_, "procptr"s,
482         SaveDerivedPointerTarget(scope, SaveObjectName(".p."s + distinctName),
483             std::move(procPtrComponents),
484             evaluate::ConstantSubscripts{
485                 static_cast<evaluate::ConstantSubscript>(
486                     procPtrComponents.size())}));
487     // Compile the "vtable" of type-bound procedure bindings
488     std::vector<evaluate::StructureConstructor> bindings{
489         DescribeBindings(dtScope, scope)};
490     AddValue(dtValues, derivedTypeSchema_, "binding"s,
491         SaveDerivedPointerTarget(scope, SaveObjectName(".v."s + distinctName),
492             std::move(bindings),
493             evaluate::ConstantSubscripts{
494                 static_cast<evaluate::ConstantSubscript>(bindings.size())}));
495     // Describe "special" bindings to defined assignments, FINAL subroutines,
496     // and user-defined derived type I/O subroutines.
497     if (dtScope.symbol()) {
498       for (const auto &pair :
499           dtScope.symbol()->get<DerivedTypeDetails>().finals()) {
500         DescribeSpecialProc(specials, *pair.second, false /*!isAssignment*/,
501             true, std::nullopt);
502       }
503     }
504     IncorporateDefinedIoGenericInterfaces(specials,
505         SourceName{"read(formatted)", 15},
506         GenericKind::DefinedIo::ReadFormatted, &scope);
507     IncorporateDefinedIoGenericInterfaces(specials,
508         SourceName{"read(unformatted)", 17},
509         GenericKind::DefinedIo::ReadUnformatted, &scope);
510     IncorporateDefinedIoGenericInterfaces(specials,
511         SourceName{"write(formatted)", 16},
512         GenericKind::DefinedIo::WriteFormatted, &scope);
513     IncorporateDefinedIoGenericInterfaces(specials,
514         SourceName{"write(unformatted)", 18},
515         GenericKind::DefinedIo::WriteUnformatted, &scope);
516     AddValue(dtValues, derivedTypeSchema_, "special"s,
517         SaveDerivedPointerTarget(scope, SaveObjectName(".s."s + distinctName),
518             std::move(specials),
519             evaluate::ConstantSubscripts{
520                 static_cast<evaluate::ConstantSubscript>(specials.size())}));
521   }
522   dtObject.get<ObjectEntityDetails>().set_init(MaybeExpr{
523       StructureExpr(Structure(derivedTypeSchema_, std::move(dtValues)))});
524   return &dtObject;
525 }
526 
527 static const Symbol &GetSymbol(const Scope &schemata, SourceName name) {
528   auto iter{schemata.find(name)};
529   CHECK(iter != schemata.end());
530   const Symbol &symbol{*iter->second};
531   return symbol;
532 }
533 
534 const Symbol &RuntimeTableBuilder::GetSchemaSymbol(const char *name) const {
535   return GetSymbol(
536       DEREF(tables_.schemata), SourceName{name, std::strlen(name)});
537 }
538 
539 const DeclTypeSpec &RuntimeTableBuilder::GetSchema(
540     const char *schemaName) const {
541   Scope &schemata{DEREF(tables_.schemata)};
542   SourceName name{schemaName, std::strlen(schemaName)};
543   const Symbol &symbol{GetSymbol(schemata, name)};
544   CHECK(symbol.has<DerivedTypeDetails>());
545   CHECK(symbol.scope());
546   CHECK(symbol.scope()->IsDerivedType());
547   const DeclTypeSpec *spec{nullptr};
548   if (symbol.scope()->derivedTypeSpec()) {
549     DeclTypeSpec typeSpec{
550         DeclTypeSpec::TypeDerived, *symbol.scope()->derivedTypeSpec()};
551     spec = schemata.FindType(typeSpec);
552   }
553   if (!spec) {
554     DeclTypeSpec typeSpec{
555         DeclTypeSpec::TypeDerived, DerivedTypeSpec{name, symbol}};
556     spec = schemata.FindType(typeSpec);
557   }
558   if (!spec) {
559     spec = &schemata.MakeDerivedType(
560         DeclTypeSpec::TypeDerived, DerivedTypeSpec{name, symbol});
561   }
562   CHECK(spec->AsDerived());
563   return *spec;
564 }
565 
566 template <int KIND> static SomeExpr IntExpr(std::int64_t n) {
567   return evaluate::AsGenericExpr(
568       evaluate::Constant<evaluate::Type<TypeCategory::Integer, KIND>>{n});
569 }
570 
571 SomeExpr RuntimeTableBuilder::GetEnumValue(const char *name) const {
572   const Symbol &symbol{GetSchemaSymbol(name)};
573   auto value{evaluate::ToInt64(symbol.get<ObjectEntityDetails>().init())};
574   CHECK(value.has_value());
575   return IntExpr<1>(*value);
576 }
577 
578 Symbol &RuntimeTableBuilder::CreateObject(
579     const std::string &name, const DeclTypeSpec &type, Scope &scope) {
580   ObjectEntityDetails object;
581   object.set_type(type);
582   auto pair{scope.try_emplace(SaveObjectName(name),
583       Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))};
584   CHECK(pair.second);
585   Symbol &result{*pair.first->second};
586   return result;
587 }
588 
589 SourceName RuntimeTableBuilder::SaveObjectName(const std::string &name) {
590   return *tables_.names.insert(name).first;
591 }
592 
593 SomeExpr RuntimeTableBuilder::SaveNameAsPointerTarget(
594     Scope &scope, const std::string &name) {
595   CHECK(!name.empty());
596   CHECK(name.front() != '.');
597   ObjectEntityDetails object;
598   auto len{static_cast<common::ConstantSubscript>(name.size())};
599   if (const auto *spec{scope.FindType(DeclTypeSpec{CharacterTypeSpec{
600           ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1}}})}) {
601     object.set_type(*spec);
602   } else {
603     object.set_type(scope.MakeCharacterType(
604         ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1}));
605   }
606   using Ascii = evaluate::Type<TypeCategory::Character, 1>;
607   using AsciiExpr = evaluate::Expr<Ascii>;
608   object.set_init(evaluate::AsGenericExpr(AsciiExpr{name}));
609   const Symbol &symbol{
610       *scope
611            .try_emplace(SaveObjectName(".n."s + name),
612                Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))
613            .first->second};
614   return evaluate::AsGenericExpr(
615       AsciiExpr{evaluate::Designator<Ascii>{symbol}});
616 }
617 
618 evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
619     const Symbol &symbol, const ObjectEntityDetails &object, Scope &scope,
620     Scope &dtScope, const std::string &distinctName,
621     const SymbolVector *parameters) {
622   evaluate::StructureConstructorValues values;
623   auto &foldingContext{context_.foldingContext()};
624   auto typeAndShape{evaluate::characteristics::TypeAndShape::Characterize(
625       symbol, foldingContext)};
626   CHECK(typeAndShape.has_value());
627   auto dyType{typeAndShape->type()};
628   const auto &shape{typeAndShape->shape()};
629   AddValue(values, componentSchema_, "name"s,
630       SaveNameAsPointerTarget(scope, symbol.name().ToString()));
631   AddValue(values, componentSchema_, "category"s,
632       IntExpr<1>(static_cast<int>(dyType.category())));
633   if (dyType.IsUnlimitedPolymorphic() ||
634       dyType.category() == TypeCategory::Derived) {
635     AddValue(values, componentSchema_, "kind"s, IntExpr<1>(0));
636   } else {
637     AddValue(values, componentSchema_, "kind"s, IntExpr<1>(dyType.kind()));
638   }
639   AddValue(values, componentSchema_, "offset"s, IntExpr<8>(symbol.offset()));
640   // CHARACTER length
641   auto len{typeAndShape->LEN()};
642   if (const semantics::DerivedTypeSpec *
643       pdtInstance{dtScope.derivedTypeSpec()}) {
644     auto restorer{foldingContext.WithPDTInstance(*pdtInstance)};
645     len = Fold(foldingContext, std::move(len));
646   }
647   if (dyType.category() == TypeCategory::Character && len) {
648     AddValue(values, componentSchema_, "characterlen"s,
649         evaluate::AsGenericExpr(GetValue(len, parameters)));
650   } else {
651     AddValue(values, componentSchema_, "characterlen"s,
652         PackageIntValueExpr(deferredEnum_));
653   }
654   // Describe component's derived type
655   std::vector<evaluate::StructureConstructor> lenParams;
656   if (dyType.category() == TypeCategory::Derived &&
657       !dyType.IsUnlimitedPolymorphic()) {
658     const DerivedTypeSpec &spec{dyType.GetDerivedTypeSpec()};
659     Scope *derivedScope{const_cast<Scope *>(
660         spec.scope() ? spec.scope() : spec.typeSymbol().scope())};
661     const Symbol *derivedDescription{DescribeType(DEREF(derivedScope))};
662     AddValue(values, componentSchema_, "derived"s,
663         evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{
664             evaluate::Designator<evaluate::SomeDerived>{
665                 DEREF(derivedDescription)}}));
666     // Package values of LEN parameters, if any
667     if (const SymbolVector * specParams{GetTypeParameters(spec.typeSymbol())}) {
668       for (SymbolRef ref : *specParams) {
669         const auto &tpd{ref->get<TypeParamDetails>()};
670         if (tpd.attr() == common::TypeParamAttr::Len) {
671           if (const ParamValue * paramValue{spec.FindParameter(ref->name())}) {
672             lenParams.emplace_back(GetValue(*paramValue, parameters));
673           } else {
674             lenParams.emplace_back(GetValue(tpd.init(), parameters));
675           }
676         }
677       }
678     }
679   } else {
680     // Subtle: a category of Derived with a null derived type pointer
681     // signifies CLASS(*)
682     AddValue(values, componentSchema_, "derived"s,
683         SomeExpr{evaluate::NullPointer{}});
684   }
685   // LEN type parameter values for the component's type
686   if (!lenParams.empty()) {
687     AddValue(values, componentSchema_, "lenvalue"s,
688         SaveDerivedPointerTarget(scope,
689             SaveObjectName(
690                 ".lv."s + distinctName + "."s + symbol.name().ToString()),
691             std::move(lenParams),
692             evaluate::ConstantSubscripts{
693                 static_cast<evaluate::ConstantSubscript>(lenParams.size())}));
694   } else {
695     AddValue(values, componentSchema_, "lenvalue"s,
696         SomeExpr{evaluate::NullPointer{}});
697   }
698   // Shape information
699   int rank{evaluate::GetRank(shape)};
700   AddValue(values, componentSchema_, "rank"s, IntExpr<1>(rank));
701   if (rank > 0 && !IsAllocatable(symbol) && !IsPointer(symbol)) {
702     std::vector<evaluate::StructureConstructor> bounds;
703     evaluate::NamedEntity entity{symbol};
704     for (int j{0}; j < rank; ++j) {
705       bounds.emplace_back(GetValue(std::make_optional(evaluate::GetLowerBound(
706                                        foldingContext, entity, j)),
707           parameters));
708       bounds.emplace_back(GetValue(
709           evaluate::GetUpperBound(foldingContext, entity, j), parameters));
710     }
711     AddValue(values, componentSchema_, "bounds"s,
712         SaveDerivedPointerTarget(scope,
713             SaveObjectName(
714                 ".b."s + distinctName + "."s + symbol.name().ToString()),
715             std::move(bounds), evaluate::ConstantSubscripts{2, rank}));
716   } else {
717     AddValue(
718         values, componentSchema_, "bounds"s, SomeExpr{evaluate::NullPointer{}});
719   }
720   // Default component initialization
721   bool hasDataInit{false};
722   if (IsAllocatable(symbol)) {
723     AddValue(values, componentSchema_, "genre"s, GetEnumValue("allocatable"));
724   } else if (IsPointer(symbol)) {
725     AddValue(values, componentSchema_, "genre"s, GetEnumValue("pointer"));
726     hasDataInit = object.init().has_value();
727     if (hasDataInit) {
728       AddValue(values, componentSchema_, "initialization"s,
729           SomeExpr{*object.init()});
730     }
731   } else if (IsAutomaticObject(symbol)) {
732     AddValue(values, componentSchema_, "genre"s, GetEnumValue("automatic"));
733   } else {
734     AddValue(values, componentSchema_, "genre"s, GetEnumValue("data"));
735     hasDataInit = object.init().has_value();
736     if (hasDataInit) {
737       AddValue(values, componentSchema_, "initialization"s,
738           SaveObjectInit(scope,
739               SaveObjectName(
740                   ".di."s + distinctName + "."s + symbol.name().ToString()),
741               object));
742     }
743   }
744   if (!hasDataInit) {
745     AddValue(values, componentSchema_, "initialization"s,
746         SomeExpr{evaluate::NullPointer{}});
747   }
748   return {DEREF(componentSchema_.AsDerived()), std::move(values)};
749 }
750 
751 evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
752     const Symbol &symbol, const ProcEntityDetails &proc, Scope &scope) {
753   evaluate::StructureConstructorValues values;
754   AddValue(values, procPtrSchema_, "name"s,
755       SaveNameAsPointerTarget(scope, symbol.name().ToString()));
756   AddValue(values, procPtrSchema_, "offset"s, IntExpr<8>(symbol.offset()));
757   if (auto init{proc.init()}; init && *init) {
758     AddValue(values, procPtrSchema_, "initialization"s,
759         SomeExpr{evaluate::ProcedureDesignator{**init}});
760   } else {
761     AddValue(values, procPtrSchema_, "initialization"s,
762         SomeExpr{evaluate::NullPointer{}});
763   }
764   return {DEREF(procPtrSchema_.AsDerived()), std::move(values)};
765 }
766 
767 evaluate::StructureConstructor RuntimeTableBuilder::PackageIntValue(
768     const SomeExpr &genre, std::int64_t n) const {
769   evaluate::StructureConstructorValues xs;
770   AddValue(xs, valueSchema_, "genre"s, genre);
771   AddValue(xs, valueSchema_, "value"s, IntToExpr(n));
772   return Structure(valueSchema_, std::move(xs));
773 }
774 
775 SomeExpr RuntimeTableBuilder::PackageIntValueExpr(
776     const SomeExpr &genre, std::int64_t n) const {
777   return StructureExpr(PackageIntValue(genre, n));
778 }
779 
780 std::vector<const Symbol *> RuntimeTableBuilder::CollectBindings(
781     const Scope &dtScope) const {
782   std::vector<const Symbol *> result;
783   std::map<SourceName, const Symbol *> localBindings;
784   // Collect local bindings
785   for (auto pair : dtScope) {
786     const Symbol &symbol{*pair.second};
787     if (symbol.has<ProcBindingDetails>()) {
788       localBindings.emplace(symbol.name(), &symbol);
789     }
790   }
791   if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) {
792     result = CollectBindings(*parentScope);
793     // Apply overrides from the local bindings of the extended type
794     for (auto iter{result.begin()}; iter != result.end(); ++iter) {
795       const Symbol &symbol{**iter};
796       auto overridden{localBindings.find(symbol.name())};
797       if (overridden != localBindings.end()) {
798         *iter = overridden->second;
799         localBindings.erase(overridden);
800       }
801     }
802   }
803   // Add remaining (non-overriding) local bindings in name order to the result
804   for (auto pair : localBindings) {
805     result.push_back(pair.second);
806   }
807   return result;
808 }
809 
810 std::vector<evaluate::StructureConstructor>
811 RuntimeTableBuilder::DescribeBindings(const Scope &dtScope, Scope &scope) {
812   std::vector<evaluate::StructureConstructor> result;
813   for (const Symbol *symbol : CollectBindings(dtScope)) {
814     evaluate::StructureConstructorValues values;
815     AddValue(values, bindingSchema_, "proc"s,
816         SomeExpr{evaluate::ProcedureDesignator{
817             symbol->get<ProcBindingDetails>().symbol()}});
818     AddValue(values, bindingSchema_, "name"s,
819         SaveNameAsPointerTarget(scope, symbol->name().ToString()));
820     result.emplace_back(DEREF(bindingSchema_.AsDerived()), std::move(values));
821   }
822   return result;
823 }
824 
825 void RuntimeTableBuilder::DescribeGeneric(const GenericDetails &generic,
826     std::vector<evaluate::StructureConstructor> &specials) {
827   std::visit(common::visitors{
828                  [&](const GenericKind::OtherKind &k) {
829                    if (k == GenericKind::OtherKind::Assignment) {
830                      for (auto ref : generic.specificProcs()) {
831                        DescribeSpecialProc(specials, *ref, true,
832                            false /*!final*/, std::nullopt);
833                      }
834                    }
835                  },
836                  [&](const GenericKind::DefinedIo &io) {
837                    switch (io) {
838                    case GenericKind::DefinedIo::ReadFormatted:
839                    case GenericKind::DefinedIo::ReadUnformatted:
840                    case GenericKind::DefinedIo::WriteFormatted:
841                    case GenericKind::DefinedIo::WriteUnformatted:
842                      for (auto ref : generic.specificProcs()) {
843                        DescribeSpecialProc(
844                            specials, *ref, false, false /*!final*/, io);
845                      }
846                      break;
847                    }
848                  },
849                  [](const auto &) {},
850              },
851       generic.kind().u);
852 }
853 
854 void RuntimeTableBuilder::DescribeSpecialProc(
855     std::vector<evaluate::StructureConstructor> &specials,
856     const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
857     std::optional<GenericKind::DefinedIo> io) {
858   const auto *binding{specificOrBinding.detailsIf<ProcBindingDetails>()};
859   const Symbol &specific{*(binding ? &binding->symbol() : &specificOrBinding)};
860   if (auto proc{evaluate::characteristics::Procedure::Characterize(
861           specific, context_.foldingContext())}) {
862     std::uint8_t rank{0};
863     std::uint8_t isArgDescriptorSet{0};
864     int argThatMightBeDescriptor{0};
865     MaybeExpr which;
866     if (isAssignment) { // only type-bound asst's are germane to runtime
867       CHECK(binding != nullptr);
868       CHECK(proc->dummyArguments.size() == 2);
869       which = proc->IsElemental() ? elementalAssignmentEnum_ : assignmentEnum_;
870       if (binding && binding->passName() &&
871           *binding->passName() == proc->dummyArguments[1].name) {
872         argThatMightBeDescriptor = 1;
873         isArgDescriptorSet |= 2;
874       } else {
875         argThatMightBeDescriptor = 2; // the non-passed-object argument
876         isArgDescriptorSet |= 1;
877       }
878     } else if (isFinal) {
879       CHECK(binding == nullptr); // FINALs are not bindings
880       CHECK(proc->dummyArguments.size() == 1);
881       if (proc->IsElemental()) {
882         which = elementalFinalEnum_;
883       } else {
884         const auto &typeAndShape{
885             std::get<evaluate::characteristics::DummyDataObject>(
886                 proc->dummyArguments.at(0).u)
887                 .type};
888         if (typeAndShape.attrs().test(
889                 evaluate::characteristics::TypeAndShape::Attr::AssumedRank)) {
890           which = assumedRankFinalEnum_;
891           isArgDescriptorSet |= 1;
892         } else {
893           which = finalEnum_;
894           rank = evaluate::GetRank(typeAndShape.shape());
895           if (rank > 0) {
896             argThatMightBeDescriptor = 1;
897           }
898         }
899       }
900     } else { // user defined derived type I/O
901       CHECK(proc->dummyArguments.size() >= 4);
902       if (binding) {
903         isArgDescriptorSet |= 1;
904       }
905       switch (io.value()) {
906       case GenericKind::DefinedIo::ReadFormatted:
907         which = readFormattedEnum_;
908         break;
909       case GenericKind::DefinedIo::ReadUnformatted:
910         which = readUnformattedEnum_;
911         break;
912       case GenericKind::DefinedIo::WriteFormatted:
913         which = writeFormattedEnum_;
914         break;
915       case GenericKind::DefinedIo::WriteUnformatted:
916         which = writeUnformattedEnum_;
917         break;
918       }
919     }
920     if (argThatMightBeDescriptor != 0 &&
921         !proc->dummyArguments.at(argThatMightBeDescriptor - 1)
922              .CanBePassedViaImplicitInterface()) {
923       isArgDescriptorSet |= 1 << (argThatMightBeDescriptor - 1);
924     }
925     evaluate::StructureConstructorValues values;
926     AddValue(
927         values, specialSchema_, "which"s, SomeExpr{std::move(which.value())});
928     AddValue(values, specialSchema_, "rank"s, IntExpr<1>(rank));
929     AddValue(values, specialSchema_, "isargdescriptorset"s,
930         IntExpr<1>(isArgDescriptorSet));
931     AddValue(values, specialSchema_, "proc"s,
932         SomeExpr{evaluate::ProcedureDesignator{specific}});
933     specials.emplace_back(DEREF(specialSchema_.AsDerived()), std::move(values));
934   }
935 }
936 
937 void RuntimeTableBuilder::IncorporateDefinedIoGenericInterfaces(
938     std::vector<evaluate::StructureConstructor> &specials, SourceName name,
939     GenericKind::DefinedIo definedIo, const Scope *scope) {
940   for (; !scope->IsGlobal(); scope = &scope->parent()) {
941     if (auto asst{scope->find(name)}; asst != scope->end()) {
942       const Symbol &generic{*asst->second};
943       const auto &genericDetails{generic.get<GenericDetails>()};
944       CHECK(std::holds_alternative<GenericKind::DefinedIo>(
945           genericDetails.kind().u));
946       CHECK(std::get<GenericKind::DefinedIo>(genericDetails.kind().u) ==
947           definedIo);
948       for (auto ref : genericDetails.specificProcs()) {
949         DescribeSpecialProc(specials, *ref, false, false, definedIo);
950       }
951     }
952   }
953 }
954 
955 RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(
956     SemanticsContext &context) {
957   ModFileReader reader{context};
958   RuntimeDerivedTypeTables result;
959   static const char schemataName[]{"__fortran_type_info"};
960   SourceName schemataModule{schemataName, std::strlen(schemataName)};
961   result.schemata = reader.Read(schemataModule);
962   if (result.schemata) {
963     RuntimeTableBuilder builder{context, result};
964     builder.DescribeTypes(context.globalScope());
965   }
966   return result;
967 }
968 } // namespace Fortran::semantics
969