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