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