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<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, scope, dtScope, distinctName, parameters));
444               },
445               [&](const ProcEntityDetails &proc) {
446                 if (IsProcedurePointer(symbol)) {
447                   procPtrComponents.emplace_back(
448                       DescribeComponent(symbol, proc, scope));
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     Scope &dtScope, const std::string &distinctName,
610     const SymbolVector *parameters) {
611   evaluate::StructureConstructorValues values;
612   auto &foldingContext{context_.foldingContext()};
613   auto typeAndShape{evaluate::characteristics::TypeAndShape::Characterize(
614       symbol, foldingContext)};
615   CHECK(typeAndShape.has_value());
616   auto dyType{typeAndShape->type()};
617   const auto &shape{typeAndShape->shape()};
618   AddValue(values, componentSchema_, "name"s,
619       SaveNameAsPointerTarget(scope, symbol.name().ToString()));
620   AddValue(values, componentSchema_, "category"s,
621       IntExpr<1>(static_cast<int>(dyType.category())));
622   if (dyType.IsUnlimitedPolymorphic() ||
623       dyType.category() == TypeCategory::Derived) {
624     AddValue(values, componentSchema_, "kind"s, IntExpr<1>(0));
625   } else {
626     AddValue(values, componentSchema_, "kind"s, IntExpr<1>(dyType.kind()));
627   }
628   AddValue(values, componentSchema_, "offset"s, IntExpr<8>(symbol.offset()));
629   // CHARACTER length
630   auto len{typeAndShape->LEN()};
631   if (const semantics::DerivedTypeSpec *
632       pdtInstance{dtScope.derivedTypeSpec()}) {
633     auto restorer{foldingContext.WithPDTInstance(*pdtInstance)};
634     len = Fold(foldingContext, std::move(len));
635   }
636   if (dyType.category() == TypeCategory::Character && len) {
637     AddValue(values, componentSchema_, "characterlen"s,
638         evaluate::AsGenericExpr(GetValue(len, parameters)));
639   } else {
640     AddValue(values, componentSchema_, "characterlen"s,
641         PackageIntValueExpr(deferredEnum_));
642   }
643   // Describe component's derived type
644   std::vector<evaluate::StructureConstructor> lenParams;
645   if (dyType.category() == TypeCategory::Derived &&
646       !dyType.IsUnlimitedPolymorphic()) {
647     const DerivedTypeSpec &spec{dyType.GetDerivedTypeSpec()};
648     Scope *derivedScope{const_cast<Scope *>(
649         spec.scope() ? spec.scope() : spec.typeSymbol().scope())};
650     const Symbol *derivedDescription{DescribeType(DEREF(derivedScope))};
651     AddValue(values, componentSchema_, "derived"s,
652         evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{
653             evaluate::Designator<evaluate::SomeDerived>{
654                 DEREF(derivedDescription)}}));
655     // Package values of LEN parameters, if any
656     if (const SymbolVector * specParams{GetTypeParameters(spec.typeSymbol())}) {
657       for (SymbolRef ref : *specParams) {
658         const auto &tpd{ref->get<TypeParamDetails>()};
659         if (tpd.attr() == common::TypeParamAttr::Len) {
660           if (const ParamValue * paramValue{spec.FindParameter(ref->name())}) {
661             lenParams.emplace_back(GetValue(*paramValue, parameters));
662           } else {
663             lenParams.emplace_back(GetValue(tpd.init(), parameters));
664           }
665         }
666       }
667     }
668   } else {
669     // Subtle: a category of Derived with a null derived type pointer
670     // signifies CLASS(*)
671     AddValue(values, componentSchema_, "derived"s,
672         SomeExpr{evaluate::NullPointer{}});
673   }
674   // LEN type parameter values for the component's type
675   if (!lenParams.empty()) {
676     AddValue(values, componentSchema_, "lenvalue"s,
677         SaveDerivedPointerTarget(scope,
678             SaveObjectName(
679                 ".lv."s + distinctName + "."s + symbol.name().ToString()),
680             std::move(lenParams),
681             evaluate::ConstantSubscripts{
682                 static_cast<evaluate::ConstantSubscript>(lenParams.size())}));
683   } else {
684     AddValue(values, componentSchema_, "lenvalue"s,
685         SomeExpr{evaluate::NullPointer{}});
686   }
687   // Shape information
688   int rank{evaluate::GetRank(shape)};
689   AddValue(values, componentSchema_, "rank"s, IntExpr<1>(rank));
690   if (rank > 0 && !IsAllocatable(symbol) && !IsPointer(symbol)) {
691     std::vector<evaluate::StructureConstructor> bounds;
692     evaluate::NamedEntity entity{symbol};
693     for (int j{0}; j < rank; ++j) {
694       bounds.emplace_back(GetValue(std::make_optional(evaluate::GetLowerBound(
695                                        foldingContext, entity, j)),
696           parameters));
697       bounds.emplace_back(GetValue(
698           evaluate::GetUpperBound(foldingContext, entity, j), parameters));
699     }
700     AddValue(values, componentSchema_, "bounds"s,
701         SaveDerivedPointerTarget(scope,
702             SaveObjectName(
703                 ".b."s + distinctName + "."s + symbol.name().ToString()),
704             std::move(bounds), evaluate::ConstantSubscripts{2, rank}));
705   } else {
706     AddValue(
707         values, componentSchema_, "bounds"s, SomeExpr{evaluate::NullPointer{}});
708   }
709   // Default component initialization
710   bool hasDataInit{false};
711   if (IsAllocatable(symbol)) {
712     AddValue(values, componentSchema_, "genre"s, GetEnumValue("allocatable"));
713   } else if (IsPointer(symbol)) {
714     AddValue(values, componentSchema_, "genre"s, GetEnumValue("pointer"));
715     hasDataInit = object.init().has_value();
716     if (hasDataInit) {
717       AddValue(values, componentSchema_, "initialization"s,
718           SomeExpr{*object.init()});
719     }
720   } else if (IsAutomaticObject(symbol)) {
721     AddValue(values, componentSchema_, "genre"s, GetEnumValue("automatic"));
722   } else {
723     AddValue(values, componentSchema_, "genre"s, GetEnumValue("data"));
724     hasDataInit = object.init().has_value();
725     if (hasDataInit) {
726       AddValue(values, componentSchema_, "initialization"s,
727           SaveObjectInit(scope,
728               SaveObjectName(
729                   ".di."s + distinctName + "."s + symbol.name().ToString()),
730               object));
731     }
732   }
733   if (!hasDataInit) {
734     AddValue(values, componentSchema_, "initialization"s,
735         SomeExpr{evaluate::NullPointer{}});
736   }
737   return {DEREF(componentSchema_.AsDerived()), std::move(values)};
738 }
739 
740 evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
741     const Symbol &symbol, const ProcEntityDetails &proc, Scope &scope) {
742   evaluate::StructureConstructorValues values;
743   AddValue(values, procPtrSchema_, "name"s,
744       SaveNameAsPointerTarget(scope, symbol.name().ToString()));
745   AddValue(values, procPtrSchema_, "offset"s, IntExpr<8>(symbol.offset()));
746   if (auto init{proc.init()}; init && *init) {
747     AddValue(values, procPtrSchema_, "initialization"s,
748         SomeExpr{evaluate::ProcedureDesignator{**init}});
749   } else {
750     AddValue(values, procPtrSchema_, "initialization"s,
751         SomeExpr{evaluate::NullPointer{}});
752   }
753   return {DEREF(procPtrSchema_.AsDerived()), std::move(values)};
754 }
755 
756 evaluate::StructureConstructor RuntimeTableBuilder::PackageIntValue(
757     const SomeExpr &genre, std::int64_t n) const {
758   evaluate::StructureConstructorValues xs;
759   AddValue(xs, valueSchema_, "genre"s, genre);
760   AddValue(xs, valueSchema_, "value"s, IntToExpr(n));
761   return Structure(valueSchema_, std::move(xs));
762 }
763 
764 SomeExpr RuntimeTableBuilder::PackageIntValueExpr(
765     const SomeExpr &genre, std::int64_t n) const {
766   return StructureExpr(PackageIntValue(genre, n));
767 }
768 
769 std::vector<const Symbol *> RuntimeTableBuilder::CollectBindings(
770     const Scope &dtScope) const {
771   std::vector<const Symbol *> result;
772   std::map<SourceName, const Symbol *> localBindings;
773   // Collect local bindings
774   for (auto pair : dtScope) {
775     const Symbol &symbol{*pair.second};
776     if (symbol.has<ProcBindingDetails>()) {
777       localBindings.emplace(symbol.name(), &symbol);
778     }
779   }
780   if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) {
781     result = CollectBindings(*parentScope);
782     // Apply overrides from the local bindings of the extended type
783     for (auto iter{result.begin()}; iter != result.end(); ++iter) {
784       const Symbol &symbol{**iter};
785       auto overridden{localBindings.find(symbol.name())};
786       if (overridden != localBindings.end()) {
787         *iter = overridden->second;
788         localBindings.erase(overridden);
789       }
790     }
791   }
792   // Add remaining (non-overriding) local bindings in name order to the result
793   for (auto pair : localBindings) {
794     result.push_back(pair.second);
795   }
796   return result;
797 }
798 
799 std::vector<evaluate::StructureConstructor>
800 RuntimeTableBuilder::DescribeBindings(const Scope &dtScope, Scope &scope) {
801   std::vector<evaluate::StructureConstructor> result;
802   for (const Symbol *symbol : CollectBindings(dtScope)) {
803     evaluate::StructureConstructorValues values;
804     AddValue(values, bindingSchema_, "proc"s,
805         SomeExpr{evaluate::ProcedureDesignator{
806             symbol->get<ProcBindingDetails>().symbol()}});
807     AddValue(values, bindingSchema_, "name"s,
808         SaveNameAsPointerTarget(scope, symbol->name().ToString()));
809     result.emplace_back(DEREF(bindingSchema_.AsDerived()), std::move(values));
810   }
811   return result;
812 }
813 
814 void RuntimeTableBuilder::DescribeGeneric(const GenericDetails &generic,
815     std::vector<evaluate::StructureConstructor> &specials) {
816   std::visit(common::visitors{
817                  [&](const GenericKind::OtherKind &k) {
818                    if (k == GenericKind::OtherKind::Assignment) {
819                      for (auto ref : generic.specificProcs()) {
820                        DescribeSpecialProc(specials, *ref, true,
821                            false /*!final*/, std::nullopt);
822                      }
823                    }
824                  },
825                  [&](const GenericKind::DefinedIo &io) {
826                    switch (io) {
827                    case GenericKind::DefinedIo::ReadFormatted:
828                    case GenericKind::DefinedIo::ReadUnformatted:
829                    case GenericKind::DefinedIo::WriteFormatted:
830                    case GenericKind::DefinedIo::WriteUnformatted:
831                      for (auto ref : generic.specificProcs()) {
832                        DescribeSpecialProc(
833                            specials, *ref, false, false /*!final*/, io);
834                      }
835                      break;
836                    }
837                  },
838                  [](const auto &) {},
839              },
840       generic.kind().u);
841 }
842 
843 void RuntimeTableBuilder::DescribeSpecialProc(
844     std::vector<evaluate::StructureConstructor> &specials,
845     const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
846     std::optional<GenericKind::DefinedIo> io) {
847   const auto *binding{specificOrBinding.detailsIf<ProcBindingDetails>()};
848   const Symbol &specific{*(binding ? &binding->symbol() : &specificOrBinding)};
849   if (auto proc{evaluate::characteristics::Procedure::Characterize(
850           specific, context_.foldingContext())}) {
851     std::uint8_t rank{0};
852     std::uint8_t isArgDescriptorSet{0};
853     int argThatMightBeDescriptor{0};
854     MaybeExpr which;
855     if (isAssignment) { // only type-bound asst's are germane to runtime
856       CHECK(binding != nullptr);
857       CHECK(proc->dummyArguments.size() == 2);
858       which = proc->IsElemental() ? elementalAssignmentEnum_ : assignmentEnum_;
859       if (binding && binding->passName() &&
860           *binding->passName() == proc->dummyArguments[1].name) {
861         argThatMightBeDescriptor = 1;
862         isArgDescriptorSet |= 2;
863       } else {
864         argThatMightBeDescriptor = 2; // the non-passed-object argument
865         isArgDescriptorSet |= 1;
866       }
867     } else if (isFinal) {
868       CHECK(binding == nullptr); // FINALs are not bindings
869       CHECK(proc->dummyArguments.size() == 1);
870       if (proc->IsElemental()) {
871         which = elementalFinalEnum_;
872       } else {
873         const auto &typeAndShape{
874             std::get<evaluate::characteristics::DummyDataObject>(
875                 proc->dummyArguments.at(0).u)
876                 .type};
877         if (typeAndShape.attrs().test(
878                 evaluate::characteristics::TypeAndShape::Attr::AssumedRank)) {
879           which = assumedRankFinalEnum_;
880           isArgDescriptorSet |= 1;
881         } else {
882           which = finalEnum_;
883           rank = evaluate::GetRank(typeAndShape.shape());
884           if (rank > 0) {
885             argThatMightBeDescriptor = 1;
886           }
887         }
888       }
889     } else { // user defined derived type I/O
890       CHECK(proc->dummyArguments.size() >= 4);
891       if (binding) {
892         isArgDescriptorSet |= 1;
893       }
894       switch (io.value()) {
895       case GenericKind::DefinedIo::ReadFormatted:
896         which = readFormattedEnum_;
897         break;
898       case GenericKind::DefinedIo::ReadUnformatted:
899         which = readUnformattedEnum_;
900         break;
901       case GenericKind::DefinedIo::WriteFormatted:
902         which = writeFormattedEnum_;
903         break;
904       case GenericKind::DefinedIo::WriteUnformatted:
905         which = writeUnformattedEnum_;
906         break;
907       }
908     }
909     if (argThatMightBeDescriptor != 0 &&
910         !proc->dummyArguments.at(argThatMightBeDescriptor - 1)
911              .CanBePassedViaImplicitInterface()) {
912       isArgDescriptorSet |= 1 << (argThatMightBeDescriptor - 1);
913     }
914     evaluate::StructureConstructorValues values;
915     AddValue(
916         values, specialSchema_, "which"s, SomeExpr{std::move(which.value())});
917     AddValue(values, specialSchema_, "rank"s, IntExpr<1>(rank));
918     AddValue(values, specialSchema_, "isargdescriptorset"s,
919         IntExpr<1>(isArgDescriptorSet));
920     AddValue(values, specialSchema_, "proc"s,
921         SomeExpr{evaluate::ProcedureDesignator{specific}});
922     specials.emplace_back(DEREF(specialSchema_.AsDerived()), std::move(values));
923   }
924 }
925 
926 void RuntimeTableBuilder::IncorporateDefinedIoGenericInterfaces(
927     std::vector<evaluate::StructureConstructor> &specials, SourceName name,
928     GenericKind::DefinedIo definedIo, const Scope *scope) {
929   for (; !scope->IsGlobal(); scope = &scope->parent()) {
930     if (auto asst{scope->find(name)}; asst != scope->end()) {
931       const Symbol &generic{*asst->second};
932       const auto &genericDetails{generic.get<GenericDetails>()};
933       CHECK(std::holds_alternative<GenericKind::DefinedIo>(
934           genericDetails.kind().u));
935       CHECK(std::get<GenericKind::DefinedIo>(genericDetails.kind().u) ==
936           definedIo);
937       for (auto ref : genericDetails.specificProcs()) {
938         DescribeSpecialProc(specials, *ref, false, false, definedIo);
939       }
940     }
941   }
942 }
943 
944 RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(
945     SemanticsContext &context) {
946   ModFileReader reader{context};
947   RuntimeDerivedTypeTables result;
948   static const char schemataName[]{"__fortran_type_info"};
949   SourceName schemataModule{schemataName, std::strlen(schemataName)};
950   result.schemata = reader.Read(schemataModule);
951   if (result.schemata) {
952     RuntimeTableBuilder builder{context, result};
953     builder.DescribeTypes(context.globalScope());
954   }
955   return result;
956 }
957 } // namespace Fortran::semantics
958