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 "
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<evaluate::StructureConstructor> dataComponents;
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 &object) {
442                 dataComponents.emplace_back(DescribeComponent(
443                     symbol, object, dtScope, distinctName, parameters));
444               },
445               [&](const ProcEntityDetails &proc) {
446                 if (IsProcedurePointer(symbol)) {
447                   procPtrComponents.emplace_back(
448                       DescribeComponent(symbol, proc, dtScope));
449                 }
450               },
451               [&](const ProcBindingDetails &) { // handled in a later pass
452               },
453               [&](const GenericDetails &generic) {
454                 DescribeGeneric(generic, specials);
455               },
456               [&](const auto &) {
457                 common::die(
458                     "unexpected details on symbol '%s' in derived type scope",
459                     symbol.name().ToString().c_str());
460               },
461           },
462           symbol.details());
463     }
464     AddValue(dtValues, derivedTypeSchema_, "component"s,
465         SaveDerivedPointerTarget(scope, SaveObjectName(".c."s + distinctName),
466             std::move(dataComponents),
467             evaluate::ConstantSubscripts{
468                 static_cast<evaluate::ConstantSubscript>(
469                     dataComponents.size())}));
470     AddValue(dtValues, derivedTypeSchema_, "procptr"s,
471         SaveDerivedPointerTarget(scope, SaveObjectName(".p."s + distinctName),
472             std::move(procPtrComponents),
473             evaluate::ConstantSubscripts{
474                 static_cast<evaluate::ConstantSubscript>(
475                     procPtrComponents.size())}));
476     // Compile the "vtable" of type-bound procedure bindings
477     std::vector<evaluate::StructureConstructor> bindings{
478         DescribeBindings(dtScope, scope)};
479     AddValue(dtValues, derivedTypeSchema_, "binding"s,
480         SaveDerivedPointerTarget(scope, SaveObjectName(".v."s + distinctName),
481             std::move(bindings),
482             evaluate::ConstantSubscripts{
483                 static_cast<evaluate::ConstantSubscript>(bindings.size())}));
484     // Describe "special" bindings to defined assignments, FINAL subroutines,
485     // and user-defined derived type I/O subroutines.
486     if (dtScope.symbol()) {
487       for (const auto &pair :
488           dtScope.symbol()->get<DerivedTypeDetails>().finals()) {
489         DescribeSpecialProc(specials, *pair.second, false /*!isAssignment*/,
490             true, std::nullopt);
491       }
492     }
493     IncorporateDefinedIoGenericInterfaces(specials,
494         SourceName{"read(formatted)", 15},
495         GenericKind::DefinedIo::ReadFormatted, &scope);
496     IncorporateDefinedIoGenericInterfaces(specials,
497         SourceName{"read(unformatted)", 17},
498         GenericKind::DefinedIo::ReadUnformatted, &scope);
499     IncorporateDefinedIoGenericInterfaces(specials,
500         SourceName{"write(formatted)", 16},
501         GenericKind::DefinedIo::WriteFormatted, &scope);
502     IncorporateDefinedIoGenericInterfaces(specials,
503         SourceName{"write(unformatted)", 18},
504         GenericKind::DefinedIo::WriteUnformatted, &scope);
505     AddValue(dtValues, derivedTypeSchema_, "special"s,
506         SaveDerivedPointerTarget(scope, SaveObjectName(".s."s + distinctName),
507             std::move(specials),
508             evaluate::ConstantSubscripts{
509                 static_cast<evaluate::ConstantSubscript>(specials.size())}));
510   }
511   dtObject.get<ObjectEntityDetails>().set_init(MaybeExpr{
512       StructureExpr(Structure(derivedTypeSchema_, std::move(dtValues)))});
513   return &dtObject;
514 }
515 
516 static const Symbol &GetSymbol(const Scope &schemata, SourceName name) {
517   auto iter{schemata.find(name)};
518   CHECK(iter != schemata.end());
519   const Symbol &symbol{*iter->second};
520   return symbol;
521 }
522 
523 const Symbol &RuntimeTableBuilder::GetSchemaSymbol(const char *name) const {
524   return GetSymbol(
525       DEREF(tables_.schemata), SourceName{name, std::strlen(name)});
526 }
527 
528 const DeclTypeSpec &RuntimeTableBuilder::GetSchema(
529     const char *schemaName) const {
530   Scope &schemata{DEREF(tables_.schemata)};
531   SourceName name{schemaName, std::strlen(schemaName)};
532   const Symbol &symbol{GetSymbol(schemata, name)};
533   CHECK(symbol.has<DerivedTypeDetails>());
534   CHECK(symbol.scope());
535   CHECK(symbol.scope()->IsDerivedType());
536   const DeclTypeSpec *spec{nullptr};
537   if (symbol.scope()->derivedTypeSpec()) {
538     DeclTypeSpec typeSpec{
539         DeclTypeSpec::TypeDerived, *symbol.scope()->derivedTypeSpec()};
540     spec = schemata.FindType(typeSpec);
541   }
542   if (!spec) {
543     DeclTypeSpec typeSpec{
544         DeclTypeSpec::TypeDerived, DerivedTypeSpec{name, symbol}};
545     spec = schemata.FindType(typeSpec);
546   }
547   if (!spec) {
548     spec = &schemata.MakeDerivedType(
549         DeclTypeSpec::TypeDerived, DerivedTypeSpec{name, symbol});
550   }
551   CHECK(spec->AsDerived());
552   return *spec;
553 }
554 
555 template <int KIND> static SomeExpr IntExpr(std::int64_t n) {
556   return evaluate::AsGenericExpr(
557       evaluate::Constant<evaluate::Type<TypeCategory::Integer, KIND>>{n});
558 }
559 
560 SomeExpr RuntimeTableBuilder::GetEnumValue(const char *name) const {
561   const Symbol &symbol{GetSchemaSymbol(name)};
562   auto value{evaluate::ToInt64(symbol.get<ObjectEntityDetails>().init())};
563   CHECK(value.has_value());
564   return IntExpr<1>(*value);
565 }
566 
567 Symbol &RuntimeTableBuilder::CreateObject(
568     const std::string &name, const DeclTypeSpec &type, Scope &scope) {
569   ObjectEntityDetails object;
570   object.set_type(type);
571   auto pair{scope.try_emplace(SaveObjectName(name),
572       Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))};
573   CHECK(pair.second);
574   Symbol &result{*pair.first->second};
575   return result;
576 }
577 
578 SourceName RuntimeTableBuilder::SaveObjectName(const std::string &name) {
579   return *tables_.names.insert(name).first;
580 }
581 
582 SomeExpr RuntimeTableBuilder::SaveNameAsPointerTarget(
583     Scope &scope, const std::string &name) {
584   CHECK(!name.empty());
585   CHECK(name.front() != '.');
586   ObjectEntityDetails object;
587   auto len{static_cast<common::ConstantSubscript>(name.size())};
588   if (const auto *spec{scope.FindType(DeclTypeSpec{CharacterTypeSpec{
589           ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1}}})}) {
590     object.set_type(*spec);
591   } else {
592     object.set_type(scope.MakeCharacterType(
593         ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1}));
594   }
595   using Ascii = evaluate::Type<TypeCategory::Character, 1>;
596   using AsciiExpr = evaluate::Expr<Ascii>;
597   object.set_init(evaluate::AsGenericExpr(AsciiExpr{name}));
598   const Symbol &symbol{
599       *scope
600            .try_emplace(SaveObjectName(".n."s + name),
601                Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))
602            .first->second};
603   return evaluate::AsGenericExpr(
604       AsciiExpr{evaluate::Designator<Ascii>{symbol}});
605 }
606 
607 evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
608     const Symbol &symbol, const ObjectEntityDetails &object, Scope &scope,
609     const std::string &distinctName, const SymbolVector *parameters) {
610   evaluate::StructureConstructorValues values;
611   auto &foldingContext{context_.foldingContext()};
612   auto typeAndShape{evaluate::characteristics::TypeAndShape::Characterize(
613       symbol, foldingContext)};
614   CHECK(typeAndShape.has_value());
615   auto dyType{typeAndShape->type()};
616   const auto &shape{typeAndShape->shape()};
617   AddValue(values, componentSchema_, "name"s,
618       SaveNameAsPointerTarget(scope, symbol.name().ToString()));
619   AddValue(values, componentSchema_, "category"s,
620       IntExpr<1>(static_cast<int>(dyType.category())));
621   if (dyType.IsUnlimitedPolymorphic() ||
622       dyType.category() == TypeCategory::Derived) {
623     AddValue(values, componentSchema_, "kind"s, IntExpr<1>(0));
624   } else {
625     AddValue(values, componentSchema_, "kind"s, IntExpr<1>(dyType.kind()));
626   }
627   AddValue(values, componentSchema_, "offset"s, IntExpr<8>(symbol.offset()));
628   // CHARACTER length
629   auto len{typeAndShape->LEN()};
630   if (const semantics::DerivedTypeSpec * pdtInstance{scope.derivedTypeSpec()}) {
631     auto restorer{foldingContext.WithPDTInstance(*pdtInstance)};
632     len = Fold(foldingContext, std::move(len));
633   }
634   if (dyType.category() == TypeCategory::Character && len) {
635     AddValue(values, componentSchema_, "characterlen"s,
636         evaluate::AsGenericExpr(GetValue(len, parameters)));
637   } else {
638     AddValue(values, componentSchema_, "characterlen"s,
639         PackageIntValueExpr(deferredEnum_));
640   }
641   // Describe component's derived type
642   std::vector<evaluate::StructureConstructor> lenParams;
643   if (dyType.category() == TypeCategory::Derived &&
644       !dyType.IsUnlimitedPolymorphic()) {
645     const DerivedTypeSpec &spec{dyType.GetDerivedTypeSpec()};
646     Scope *derivedScope{const_cast<Scope *>(
647         spec.scope() ? spec.scope() : spec.typeSymbol().scope())};
648     const Symbol *derivedDescription{DescribeType(DEREF(derivedScope))};
649     AddValue(values, componentSchema_, "derived"s,
650         evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{
651             evaluate::Designator<evaluate::SomeDerived>{
652                 DEREF(derivedDescription)}}));
653     // Package values of LEN parameters, if any
654     if (const SymbolVector * specParams{GetTypeParameters(spec.typeSymbol())}) {
655       for (SymbolRef ref : *specParams) {
656         const auto &tpd{ref->get<TypeParamDetails>()};
657         if (tpd.attr() == common::TypeParamAttr::Len) {
658           if (const ParamValue * paramValue{spec.FindParameter(ref->name())}) {
659             lenParams.emplace_back(GetValue(*paramValue, parameters));
660           } else {
661             lenParams.emplace_back(GetValue(tpd.init(), parameters));
662           }
663         }
664       }
665     }
666   } else {
667     // Subtle: a category of Derived with a null derived type pointer
668     // signifies CLASS(*)
669     AddValue(values, componentSchema_, "derived"s,
670         SomeExpr{evaluate::NullPointer{}});
671   }
672   // LEN type parameter values for the component's type
673   if (!lenParams.empty()) {
674     AddValue(values, componentSchema_, "lenvalue"s,
675         SaveDerivedPointerTarget(scope,
676             SaveObjectName(
677                 ".lv."s + distinctName + "."s + symbol.name().ToString()),
678             std::move(lenParams),
679             evaluate::ConstantSubscripts{
680                 static_cast<evaluate::ConstantSubscript>(lenParams.size())}));
681   } else {
682     AddValue(values, componentSchema_, "lenvalue"s,
683         SomeExpr{evaluate::NullPointer{}});
684   }
685   // Shape information
686   int rank{evaluate::GetRank(shape)};
687   AddValue(values, componentSchema_, "rank"s, IntExpr<1>(rank));
688   if (rank > 0 && !IsAllocatable(symbol) && !IsPointer(symbol)) {
689     std::vector<evaluate::StructureConstructor> bounds;
690     evaluate::NamedEntity entity{symbol};
691     for (int j{0}; j < rank; ++j) {
692       bounds.emplace_back(GetValue(std::make_optional(evaluate::GetLowerBound(
693                                        foldingContext, entity, j)),
694           parameters));
695       bounds.emplace_back(GetValue(
696           evaluate::GetUpperBound(foldingContext, entity, j), parameters));
697     }
698     AddValue(values, componentSchema_, "bounds"s,
699         SaveDerivedPointerTarget(scope,
700             SaveObjectName(
701                 ".b."s + distinctName + "."s + symbol.name().ToString()),
702             std::move(bounds), evaluate::ConstantSubscripts{2, rank}));
703   } else {
704     AddValue(
705         values, componentSchema_, "bounds"s, SomeExpr{evaluate::NullPointer{}});
706   }
707   // Default component initialization
708   bool hasDataInit{false};
709   if (IsAllocatable(symbol)) {
710     AddValue(values, componentSchema_, "genre"s, GetEnumValue("allocatable"));
711   } else if (IsPointer(symbol)) {
712     AddValue(values, componentSchema_, "genre"s, GetEnumValue("pointer"));
713     hasDataInit = object.init().has_value();
714     if (hasDataInit) {
715       AddValue(values, componentSchema_, "initialization"s,
716           SomeExpr{*object.init()});
717     }
718   } else if (IsAutomaticObject(symbol)) {
719     AddValue(values, componentSchema_, "genre"s, GetEnumValue("automatic"));
720   } else {
721     AddValue(values, componentSchema_, "genre"s, GetEnumValue("data"));
722     hasDataInit = object.init().has_value();
723     if (hasDataInit) {
724       AddValue(values, componentSchema_, "initialization"s,
725           SaveObjectInit(scope,
726               SaveObjectName(
727                   ".di."s + distinctName + "."s + symbol.name().ToString()),
728               object));
729     }
730   }
731   if (!hasDataInit) {
732     AddValue(values, componentSchema_, "initialization"s,
733         SomeExpr{evaluate::NullPointer{}});
734   }
735   return {DEREF(componentSchema_.AsDerived()), std::move(values)};
736 }
737 
738 evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
739     const Symbol &symbol, const ProcEntityDetails &proc, Scope &scope) {
740   evaluate::StructureConstructorValues values;
741   AddValue(values, procPtrSchema_, "name"s,
742       SaveNameAsPointerTarget(scope, symbol.name().ToString()));
743   AddValue(values, procPtrSchema_, "offset"s, IntExpr<8>(symbol.offset()));
744   if (auto init{proc.init()}; init && *init) {
745     AddValue(values, procPtrSchema_, "initialization"s,
746         SomeExpr{evaluate::ProcedureDesignator{**init}});
747   } else {
748     AddValue(values, procPtrSchema_, "initialization"s,
749         SomeExpr{evaluate::NullPointer{}});
750   }
751   return {DEREF(procPtrSchema_.AsDerived()), std::move(values)};
752 }
753 
754 evaluate::StructureConstructor RuntimeTableBuilder::PackageIntValue(
755     const SomeExpr &genre, std::int64_t n) const {
756   evaluate::StructureConstructorValues xs;
757   AddValue(xs, valueSchema_, "genre"s, genre);
758   AddValue(xs, valueSchema_, "value"s, IntToExpr(n));
759   return Structure(valueSchema_, std::move(xs));
760 }
761 
762 SomeExpr RuntimeTableBuilder::PackageIntValueExpr(
763     const SomeExpr &genre, std::int64_t n) const {
764   return StructureExpr(PackageIntValue(genre, n));
765 }
766 
767 std::vector<const Symbol *> RuntimeTableBuilder::CollectBindings(
768     const Scope &dtScope) const {
769   std::vector<const Symbol *> result;
770   std::map<SourceName, const Symbol *> localBindings;
771   // Collect local bindings
772   for (auto pair : dtScope) {
773     const Symbol &symbol{*pair.second};
774     if (symbol.has<ProcBindingDetails>()) {
775       localBindings.emplace(symbol.name(), &symbol);
776     }
777   }
778   if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) {
779     result = CollectBindings(*parentScope);
780     // Apply overrides from the local bindings of the extended type
781     for (auto iter{result.begin()}; iter != result.end(); ++iter) {
782       const Symbol &symbol{**iter};
783       auto overridden{localBindings.find(symbol.name())};
784       if (overridden != localBindings.end()) {
785         *iter = overridden->second;
786         localBindings.erase(overridden);
787       }
788     }
789   }
790   // Add remaining (non-overriding) local bindings in name order to the result
791   for (auto pair : localBindings) {
792     result.push_back(pair.second);
793   }
794   return result;
795 }
796 
797 std::vector<evaluate::StructureConstructor>
798 RuntimeTableBuilder::DescribeBindings(const Scope &dtScope, Scope &scope) {
799   std::vector<evaluate::StructureConstructor> result;
800   for (const Symbol *symbol : CollectBindings(dtScope)) {
801     evaluate::StructureConstructorValues values;
802     AddValue(values, bindingSchema_, "proc"s,
803         SomeExpr{evaluate::ProcedureDesignator{
804             symbol->get<ProcBindingDetails>().symbol()}});
805     AddValue(values, bindingSchema_, "name"s,
806         SaveNameAsPointerTarget(scope, symbol->name().ToString()));
807     result.emplace_back(DEREF(bindingSchema_.AsDerived()), std::move(values));
808   }
809   return result;
810 }
811 
812 void RuntimeTableBuilder::DescribeGeneric(const GenericDetails &generic,
813     std::vector<evaluate::StructureConstructor> &specials) {
814   std::visit(common::visitors{
815                  [&](const GenericKind::OtherKind &k) {
816                    if (k == GenericKind::OtherKind::Assignment) {
817                      for (auto ref : generic.specificProcs()) {
818                        DescribeSpecialProc(specials, *ref, true,
819                            false /*!final*/, std::nullopt);
820                      }
821                    }
822                  },
823                  [&](const GenericKind::DefinedIo &io) {
824                    switch (io) {
825                    case GenericKind::DefinedIo::ReadFormatted:
826                    case GenericKind::DefinedIo::ReadUnformatted:
827                    case GenericKind::DefinedIo::WriteFormatted:
828                    case GenericKind::DefinedIo::WriteUnformatted:
829                      for (auto ref : generic.specificProcs()) {
830                        DescribeSpecialProc(
831                            specials, *ref, false, false /*!final*/, io);
832                      }
833                      break;
834                    }
835                  },
836                  [](const auto &) {},
837              },
838       generic.kind().u);
839 }
840 
841 void RuntimeTableBuilder::DescribeSpecialProc(
842     std::vector<evaluate::StructureConstructor> &specials,
843     const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
844     std::optional<GenericKind::DefinedIo> io) {
845   const auto *binding{specificOrBinding.detailsIf<ProcBindingDetails>()};
846   const Symbol &specific{*(binding ? &binding->symbol() : &specificOrBinding)};
847   if (auto proc{evaluate::characteristics::Procedure::Characterize(
848           specific, context_.foldingContext())}) {
849     std::uint8_t rank{0};
850     std::uint8_t isArgDescriptorSet{0};
851     int argThatMightBeDescriptor{0};
852     MaybeExpr which;
853     if (isAssignment) { // only type-bound asst's are germane to runtime
854       CHECK(binding != nullptr);
855       CHECK(proc->dummyArguments.size() == 2);
856       which = proc->IsElemental() ? elementalAssignmentEnum_ : assignmentEnum_;
857       if (binding && binding->passName() &&
858           *binding->passName() == proc->dummyArguments[1].name) {
859         argThatMightBeDescriptor = 1;
860         isArgDescriptorSet |= 2;
861       } else {
862         argThatMightBeDescriptor = 2; // the non-passed-object argument
863         isArgDescriptorSet |= 1;
864       }
865     } else if (isFinal) {
866       CHECK(binding == nullptr); // FINALs are not bindings
867       CHECK(proc->dummyArguments.size() == 1);
868       if (proc->IsElemental()) {
869         which = elementalFinalEnum_;
870       } else {
871         const auto &typeAndShape{
872             std::get<evaluate::characteristics::DummyDataObject>(
873                 proc->dummyArguments.at(0).u)
874                 .type};
875         if (typeAndShape.attrs().test(
876                 evaluate::characteristics::TypeAndShape::Attr::AssumedRank)) {
877           which = assumedRankFinalEnum_;
878           isArgDescriptorSet |= 1;
879         } else {
880           which = finalEnum_;
881           rank = evaluate::GetRank(typeAndShape.shape());
882           if (rank > 0) {
883             argThatMightBeDescriptor = 1;
884           }
885         }
886       }
887     } else { // user defined derived type I/O
888       CHECK(proc->dummyArguments.size() >= 4);
889       bool isArg0Descriptor{
890           !proc->dummyArguments.at(0).CanBePassedViaImplicitInterface()};
891       // N.B. When the user defined I/O subroutine is a type bound procedure,
892       // its first argument is always a descriptor, otherwise, when it was an
893       // interface, it never is.
894       CHECK(!!binding == isArg0Descriptor);
895       if (binding) {
896         isArgDescriptorSet |= 1;
897       }
898       switch (io.value()) {
899       case GenericKind::DefinedIo::ReadFormatted:
900         which = readFormattedEnum_;
901         break;
902       case GenericKind::DefinedIo::ReadUnformatted:
903         which = readUnformattedEnum_;
904         break;
905       case GenericKind::DefinedIo::WriteFormatted:
906         which = writeFormattedEnum_;
907         break;
908       case GenericKind::DefinedIo::WriteUnformatted:
909         which = writeUnformattedEnum_;
910         break;
911       }
912     }
913     if (argThatMightBeDescriptor != 0 &&
914         !proc->dummyArguments.at(argThatMightBeDescriptor - 1)
915              .CanBePassedViaImplicitInterface()) {
916       isArgDescriptorSet |= 1 << (argThatMightBeDescriptor - 1);
917     }
918     evaluate::StructureConstructorValues values;
919     AddValue(
920         values, specialSchema_, "which"s, SomeExpr{std::move(which.value())});
921     AddValue(values, specialSchema_, "rank"s, IntExpr<1>(rank));
922     AddValue(values, specialSchema_, "isargdescriptorset"s,
923         IntExpr<1>(isArgDescriptorSet));
924     AddValue(values, specialSchema_, "proc"s,
925         SomeExpr{evaluate::ProcedureDesignator{specific}});
926     specials.emplace_back(DEREF(specialSchema_.AsDerived()), std::move(values));
927   }
928 }
929 
930 void RuntimeTableBuilder::IncorporateDefinedIoGenericInterfaces(
931     std::vector<evaluate::StructureConstructor> &specials, SourceName name,
932     GenericKind::DefinedIo definedIo, const Scope *scope) {
933   for (; !scope->IsGlobal(); scope = &scope->parent()) {
934     if (auto asst{scope->find(name)}; asst != scope->end()) {
935       const Symbol &generic{*asst->second};
936       const auto &genericDetails{generic.get<GenericDetails>()};
937       CHECK(std::holds_alternative<GenericKind::DefinedIo>(
938           genericDetails.kind().u));
939       CHECK(std::get<GenericKind::DefinedIo>(genericDetails.kind().u) ==
940           definedIo);
941       for (auto ref : genericDetails.specificProcs()) {
942         DescribeSpecialProc(specials, *ref, false, false, definedIo);
943       }
944     }
945   }
946 }
947 
948 RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(
949     SemanticsContext &context) {
950   ModFileReader reader{context};
951   RuntimeDerivedTypeTables result;
952   static const char schemataName[]{"__fortran_type_info"};
953   SourceName schemataModule{schemataName, std::strlen(schemataName)};
954   result.schemata = reader.Read(schemataModule);
955   if (result.schemata) {
956     RuntimeTableBuilder builder{context, result};
957     builder.DescribeTypes(context.globalScope());
958   }
959   return result;
960 }
961 } // namespace Fortran::semantics
962